correct_size function runs very slowly for large datasets

[cpiponiot]

I'm trying to run the correct_size function for the entire Paracou dataset, following the workflow in the vignette (nice job with the vignette by the way, it's very easy to follow), but it's taking hours.

I'm working on a way to speed up the function by applying the .correct_size_tree function only to the individual trees with a detectable problem. The method seems to work on the example_census data and is > 20 times faster (see script below), and gives the same results as the previous version.

## prepare data ------------------
devtools::load_all()
prepare_forestdata(example_census,
                   plot_col="Plot",
                   id_col="idTree",
                   time_col="CensusYear",
                   status_col = "CodeAlive",
                   size_col="Circ",
                   measure_type = "C",
                   POM_col = "POM")
data = example_census
size_col = getOption("size_col")
time_col = getOption("time_col")
status_col = "CodeAlive"
species_col = "binomial_name"
id_col = getOption("id_col")
POM_col = getOption("POM_col")
measure_type =getOption("measure_type")
positive_growth_threshold = 5
negative_growth_threshold = -2
default_POM = 1.3
pioneers = c("Cecropia","Pourouma")
pioneers_treshold = 7.5
ignore_POM = FALSE

data <- check_rename_variable_col(size_col, "size",data)
data <- check_rename_variable_col(status_col, "status",data)
data <- check_rename_variable_col(time_col, "time",data)
data <- check_rename_variable_col(id_col, "id",data)
data <- check_rename_variable_col(species_col, "species",data) #tag pioneer
data <- check_rename_variable_col(POM_col, "POM",data)
data$code_corr <- as.character(rep("0",nrow(data)))
data$size_corr <- data$size
data <- data[order(data$id,data$time),]

positive_growth_threshold <- positive_growth_threshold*pi
negative_growth_threshold <- negative_growth_threshold*pi
pioneers_treshold <- pioneers_treshold*pi #tag pioneer

#tag pioneer
pioneer_sp <- data.frame(sp =  unique(data$species), pioneer = FALSE)
for(i in pioneers){
  pioneer_sp$pioneer <- ifelse(pioneer_sp$pioneer,
                               TRUE,
                               grepl(i, pioneer_sp$sp))
}
pioneer_sp <- pioneer_sp$sp[which(pioneer_sp$pioneer)]#tag pioneer


## version 1: .original version ---------------------------------
# correct_size_tree applied to all trees

t0=Sys.time() # set timer

# code copied from the correct_size function
ids <- unique(data$id)
res1 <- do.call(rbind,lapply(ids,
                            function(i){
                              tree <- data[which(data$id == i),]
                              #tag pioneer
                              if(unique(tree$species %in% pioneer_sp)){
                                thresh <- pioneers_treshold#tag pioneer
                              }
                              else{
                                thresh <- positive_growth_threshold#tag pioneer
                              }
                              if(isTRUE(ignore_POM)){
                                POMt <- NULL
                              }
                              else{
                                POMt <- tree$POM
                              }
                              # print(tree)

                              return(.correct_size_tree(size = tree$size,
                                                        size_corr = tree$size_corr,
                                                        code_corr = tree$code_corr,
                                                        time = tree$time,
                                                        status = tree$status,
                                                        ignore_POM = ignore_POM,
                                                        POM = POMt,
                                                        default_POM = default_POM,
                                                        positive_growth_threshold = thresh,
                                                        negative_growth_threshold = negative_growth_threshold,
                                                        ids = ids,
                                                        i = i))

                            }))
t1 = Sys.time() - t0 # total time taken

## 2nd version -------------
# .correct_size_tree applied only to trees with detected problems 
# (excessive decrease or increase in size, change in POM)

t0=Sys.time()

## subset data - problematic trees
data <- data[order(data$id, data$time),]
dCirc <- diff(data$size)
dCirc_annual <- diff(data$size)/diff(data$time)
dPOM <- diff(data$POM)
change_id <- data$id[-1] != data$id[-nrow(data)]
pioneers <- (data$species %in% pioneer_sp)[-1]

trees_to_correct <- unique(data$id[(dCirc < negative_growth_threshold & !change_id) |
                                      (dCirc_annual > positive_growth_threshold & !change_id & ! pioneers) |
                                      (dCirc > pioneers_treshold & !change_id & pioneers) |
                                      (dPOM != 0 & !change_id)])
res_temp <- do.call(rbind,lapply(trees_to_correct,
                     function(i){
                       tree <- data[which(data$id == i),]
                       #tag pioneer
                       if(unique(tree$species %in% pioneer_sp)){
                         thresh <- pioneers_treshold#tag pioneer
                       }
                       else{
                         thresh <- positive_growth_threshold#tag pioneer
                       }
                       if(isTRUE(ignore_POM)){
                         POMt <- NULL
                       }
                       else{
                         POMt <- tree$POM
                       }
                       # print(tree)

                       return(.correct_size_tree(size = tree$size,
                                                 size_corr = tree$size_corr,
                                                 code_corr = tree$code_corr,
                                                 time = tree$time,
                                                 status = tree$status,
                                                 ignore_POM = ignore_POM,
                                                 POM = POMt,
                                                 default_POM = default_POM,
                                                 positive_growth_threshold = thresh, #tag pioneer
                                                 negative_growth_threshold = negative_growth_threshold,
                                                 ids = ids,
                                                 i = i))

                     }))

# create data frame with all measurements
res2 <- data.frame(size_corr = data$size, code_corr=0)
res2[data$id %in% trees_to_correct2,] <- res_temp

t2 = Sys.time() - t0

print(paste("The new method is", round(as.numeric(t1)/as.numeric(t2)), "times faster."))
if(all(res2$size_corr==res1$size_corr) & all(res2$code_corr==res1$code_corr)) {
  print("The 2 methods give the same corrections with example_census.")
} else print("The 2 methods give different corrections.")