通过识别函数的瓶颈来改进速度函数

Question

我希望这个问题不会被认为是宽泛的。但是我不知道如何以不同的方式提问：在his youtube video 中，Ed Boone 用 R 介绍了 ABM。他编写了以下代码（仅更改了一些变量名称）。代码在 1000 次观察时运行良好，但是当我放大观察时它变得非常慢。因此，我想提高功能的速度。我可以在每一行之后手动添加start.time_x <- Sys.time() 等（看看什么需要很多时间），但我想知道是否有更好的方法来识别瓶颈，因为所有嵌套的 for 循环甚至都相当复杂（因为我还必须考虑每个代码运行多少次）：

# ABM_Covid - II

start.time <- Sys.time()
Data_Generator <- function(nPop1, E0, I0) {
    # Create a population of susceptibles
    Data <- data.frame( AgentNo=1:nPop1,
                        State="Susceptible",
                        Mixing= runif(nPop1,0,1),
                        TimeE = 0,
                        TimeI = 0,
                        stringsAsFactors = FALSE)
    Data$State[1:E0] <- "Exposed"  # This just says that the first person is exposed, since the mixing is random anyway, this is not an issue (because the mixing of Exposed is random)
    Data$Time[1:E0] <- rbinom(E0, 13, 0.5) + 1 # Exposure up to 14 days
    Data$State[(E0+1):(E0+I0)] <- "Infected"
    Data$Time[(E0+1):(E0+I0)] <- rbinom(I0, 12, 0.5)
    return(Data)
}

ABM_Covid <- function(Data, parameters, runtime){
    nPop1 <- nrow(Data)
    # runtime <- 15
    Results <- data.frame(  Susceptible     = rep (0, runtime),
                            Exposed         = rep (0, runtime),
                            Infected        = rep (0, runtime),
                            Recovered       = rep (0, runtime),
                            Deaths          = rep (0, runtime))
    # Move people through time
    for (k in 1:runtime){
        # Moving people through time
        StateSusceptible <- (1:nPop1)[Data$State == "Susceptible"]
        StateSusceptible_or_Exposed <- (1:nPop1)[Data$State == "Susceptible" | Data$State == "Exposed"]
        for (i in StateSusceptible) {
            # Determine if they like to meet others
            Mix1 <- Data$Mixing[i]
            # How many agents will they meet? The plus one meets everybody meets somebody
            Meetings <- round(Mix1*parameters$MaxMix,0) + 1
            # Grab the agents they will meet
            People_met <- sample(StateSusceptible_or_Exposed, Meetings, replace=TRUE, prob = Data$Mixing[StateSusceptible_or_Exposed])
            for (j in 1:length(People_met)) {
                    # Grab who they will meet
                    Meetingsa <- Data[People_met[j], ]
                    # If exposed change State
                    if(Meetingsa$State== "Exposed") {
                        Urand1 <- runif(1,0,1)
                        if (Urand1 < parameters$S2E){
                            Data$State[i] <-  "Exposed"
                        }   
                    }
                }
            }
            # Grab those who have been exposed and increment
            StateE1 <- (1:nPop1)[Data$State== "Exposed"]
            Data$TimeE[StateE1] = Data$TimeE[StateE1] + 1
            StateE2 <- (1:nPop1)[Data$State== "Exposed" & Data$TimeE > 14]
            Data$State[StateE2] <- "Recovered"    
            # Grab those who could become sick
            StateE3 <- (1:nPop1)[Data$State== "Exposed" & Data$TimeE > 3]
            for (i in StateE3){
                Urand1 <- runif(1,0,1)
                # randomly assign whether they get sick or not
                if ( Urand1 < parameters$E2I ) {
                    Data$State[i] <- "Infected"
                }
            }
            # Update how long they have been sick
            StateI1 <- (1:nPop1)[Data$State== "Infected"]
            Data$TimeI[StateI1] = Data$TimeI[StateI1] + 1
            # Recovered bin
            StateI2 <- (1:nPop1)[Data$State== "Infected" & Data$TimeI > 14]
            Data$State[StateI2] <- "R"
            # Not recovered could potentially die
            StateI3 <- (1:nPop1)[Data$State== "Infected" & Data$TimeI < 15]
            Data$State[StateI3] <- ifelse(runif(length(StateI3), 0, 1 ) > parameters$I2D, "Infected", "Deaths")
            Results$Susceptible[k] <- length(Data$State[Data$State=="Susceptible"])
            Results$Exposed[k] <- length(Data$State[Data$State=="Exposed"])
            Results$Infected[k] <- length(Data$State[Data$State=="Infected"])
            Results$Recovered[k] <- length(Data$State[Data$State=="Recovered"])
            Results$Deaths[k] <- length(Data$State[Data$State=="Deaths"])
    }
    return(Results)
}

Data <- Data_Generator(1000, E0=5, I0=2)
parameters <- data.frame( MaxMix = 10,
                    S2E = 0.25,
                    E2I = 0.1,
                    I2D = 0.1)
Model1 <- ABM_Covid(Data, parameters, runtime=25)
plot(1:25, Model1$Susceptible, type="l", col="purple", ylim = c(0,1000))
lines(1:25, Model1$Exposed, type="l", col="orange")
lines(1:25, Model1$Infected, type="l", col="red")
lines(1:25, Model1$Recovered, type="l", col="seagreen")
lines(1:25, Model1$Deaths, type="l", col="black")
end.time <- Sys.time()
time.taken <- end.time - start.time

Answer 1

这是优化功能的一部分（状态更新）的一种方法。 这样你就摆脱了i 循环和j 循环。

我不确定我是否理解算法的每一个细节。但也许您无论如何都可以使用此解决方案的某些部分和想法。

update_State <- function(nmeeting, seed = 123) {
  set.seed(seed)
  x <- Data %>%
    filter(State %in% c("Susceptible", "Exposed")) %>%
    slice_sample(n = nmeeting) %>%
    filter(State == "Exposed") %>%
    summarise(prob = any(runif(n()) <= paramters$S2E)) %>%
    pull(prob)
  
  return(if (x) "Exposed" else "Susceptible")
  
}

Data %>% 
  filter(State %in% c("Susceptible", "Exposed")) %>%
  mutate(
    n_meetings =  round(Mixing*parameters$MaxMix,0) + 1,
    new_State = map(n_meetings, update_State) #this is the new State after all the Meetings have been made
  )

这个想法是一次性检查与给定人员会面的所有暴露人员。

这会在 4-5 秒内运行。

Answer 2

大多数版本的 R 编译时都支持分析，请参阅 ?Rprof。用途类似于：

Rprof()
# <Your code without the system.time calls>
Rprof(Null)

summaryRprof()
# $by.self
#                 self.time self.pct total.time total.pct
# "["                  0.20    26.32       0.62     81.58
# "[[.data.frame"      0.16    21.05       0.24     31.58
# "[.data.frame"       0.10    13.16       0.42     55.26
# ...

基于this page的示例。