2
\$\begingroup\$

I have a very slow function with multiple for loops to read in the following text with the line's data type (Followball or DRT), as well as a time, target position, and cursor position for the Followball lines:

FollowBall,1173,897.3,894.7
FollowBall,1205,897.1,893.9
FollowBall,1236,896.9,893.6
FollowBall,1267,896.7,893.3
FollowBall,1298,896.5,893.2
DRT,1314,583794, 0, 0, -1, 0, 0, 0, miss
FollowBall,1330,896.3,893.1
FollowBall,1361,896.0,893.1
FollowBall,1392,895.8,893.0
FollowBall,1423,895.6,892.9

I read in these files for part a and b with filenames like RemoteChoice_001a_ST.txt,RemoteChoice_001b_ST.txt. There are 40-ish files. In this file there are DRT lines with mode (a factor with 4 levels) at the 4th position and load (a factor with 2 levels) at the 5th position on the line. Right now I'm making a data.frame like the one below and comparing all of the Followball lines to see if they're in the time windows:

   mode load     beg_time     end_time
1     0    0 1.470616e+12 1.470616e+12
2     0    1 1.470616e+12 1.470616e+12
3     2    1 1.470616e+12 1.470616e+12
4     1    1 1.470616e+12 1.470617e+12
5     1    0 1.470617e+12 1.470618e+12
6     2    0 1.470618e+12 1.470618e+12
7     2    1 1.470618e+12 1.470618e+12
8     3    0 1.470618e+12 1.470619e+12
9     3    1 1.470619e+12 1.470619e+12
10    0    1 1.470619e+12 1.470619e+12
11    0    0 1.470619e+12 1.470619e+12

This function currently takes 30 minutes to run:

   ExtractSteering<- function(topdir) {
  total = Sys.time()
  dirs <- list.dirs(path = topdir, full.names = TRUE) #get directories
  files <- list.files(path=dirs, pattern="*.txt", full.names=T, recursive=F) #get files
  subids1 <- regmatches(files, regexpr("0\\d*.", files)) #get subject ids
  subids <- substr(subids1, 2,3) #get just the id number
  day <- substr(subids1, 4,4) #get conditions

  for (j in 1:length(files)) { #For every file, open it and read the lines
    linesall <- readLines(files[j]) #save all the lines to a vector
    time_df <- data.frame() #make an empty data.frame to be filled by time windows
    drtmatch <- regexpr("^D.*", linesall) #Get all DRT lines
    drts <- regmatches(linesall, drtmatch) #Save all DRT lines
    drtdat <- cSplit(data.frame(drts),"drts",",") #Make a data.frame with lines
    windows <- dplyr::select(drtdat, time = drts_02, mode = drts_04, load = drts_05) #label columns
    for (i in seq_along(windows$mode)) { #for the 902 lines of windows mode
      if (windows$mode[i] != lag(windows$mode, default = 4)[i] | #see if mode changes
          windows$load[i] != lag(windows$load, default = 4)[i]) { #see if load changes
        rows <- c(windows$mode[i],windows$load[i],windows$time[i]) #save out the change point with a time
        time_df <- rbind(time_df, rows) #fill the empty data.frame with the mode, load, and timestamp
      }
    }
    colName <- c("mode","load","time") #name the columns
    time_windows <- time_df %>% #get a beginning time and end time on the same row
      setNames(colName) %>% #column names
      mutate(beg_time = time, end_time = lead(time, default = 100000000000)) %>% #same row
      select(-time) #get rid of old time
    matches <- regexpr("^Follow.*$", linesall) #Get all Followball lines
    follows <- regmatches(linesall, matches) #save Followball lines
    dat <- cSplit(data.frame(follows),"follows", ",") #make data.frame
    dat <- dplyr::select(dat, time = follows_2, ballpos = follows_3, cursorpos = follows_4) %>%
      mutate(deviation = abs(ballpos - cursorpos)) %>% #labels, create deviation
      filter(deviation < 100) %>% #get rid of big deviations
      arrange(time) #arrange by timestamp
    dat$time <- as.numeric(as.character(dat$time)) #make sure time is numeric
    dat <- dat[seq(10, nrow(dat), 10), ] #sample every 10 because it takes so damn long
    df_part <- data.frame() #empty data.frame
    tic <- Sys.time() #Figure out why it's taking so long
    for(row in seq_along(time_windows$mode)) { #go back into mode
      for(i in seq_along(dat$time)) { #go back into time
        if(dat$time[i] > time_windows$beg_time[row] & dat$time[i] < time_windows$end_time[row]) { #check if the time is in the window
          rows <- c(time_windows$mode[row], time_windows$load[row],dat$deviation[i]) #make a row with mode, load, and deviation
          df_part <- rbind(df_part, rows) #add to empty dataframe
        }
      }
      print(Sys.time() - tic) #Figure out why it's taking so long
    }
    df_full <-  df_part %>% #Rename stuff
      `colnames<-`(c("mode", "load", "deviation")) #%>%

    infile <- df_full #Don't save over things
    infile$subid <- as.factor(subids[j]) #Add subid from file name
    infile$day <- as.factor(day[j]) #Add day from file name

    if(!exists("drt.data")) {
      drt.data <- infile #Create ouput data.frame
    }
    else {
      drt.data <- rbind(drt.data,infile) #Append to output dataframe
    }
    cat("Finished Processing Participant: ", subids[j],day[j],"Total time:", Sys.time() - total) #get feedback
  }
    return(drt.data) #Return full data.frame
}

Here is my current sessionInfo():

R version 3.3.2 (2016-10-31)
Platform: x86_64-apple-darwin13.4.0 (64-bit)
Running under: macOS Sierra 10.12.6

locale:
[1] en_US.UTF-8/en_US.UTF-8/en_US.UTF-8/C/en_US.UTF-8/en_US.UTF-8

attached base packages:
[1] tcltk     stats     graphics  grDevices utils     datasets  methods   base     

other attached packages:
 [1] lme4_1.1-13           Matrix_1.2-10         papaja_0.1.0.9492     bindrcpp_0.2         
 [5] dplyr_0.7.2           purrr_0.2.3           readr_1.1.1           tidyr_0.6.3          
 [9] tibble_1.3.3          tidyverse_1.1.1       splitstackshape_1.4.2 data.table_1.10.4    
[13] ggplot2_2.2.1         plyr_1.8.4            multcomp_1.4-6        TH.data_1.0-8        
[17] MASS_7.3-47           survival_2.41-3       mvtnorm_1.0-6         car_2.1-5            
[21] forcats_0.2.0         stringr_1.2.0      

head() of output:

  mode load deviation subid day
1    0    0 0.7341692    01   a
2    0    0 0.6613210    01   a
3    0    0 0.9878947    01   a
4    0    0 0.8304713    01   a
5    0    0 0.9878947    01   a
6    0    0 1.0841968    01   a

Is there any other information I can add to receive help with this problem?

\$\endgroup\$
2
\$\begingroup\$

If you want to make your code run faster, it is important to know (a) which parts are slow and (b) which parts can be easily improved and how. Regarding (a), I suspect the loops across the rows, (e.g., for (i in seq_along(windows$mode))) make your code slow. Regarding (b), those loops should probably be avoided, maybe using a dplyr::filter() call.

Try to identify the slow parts of your code yourself, for example, using the profvis package (see also Adavanced R):

library(profvis)
profvis({
    ExtractSteering()
})

Of course, you should run ExtractSteering() on only one (or a few) TXT files to reduce computation time.

If the for loops indeed are the slow parts, I would propose that you give more details about those few lines at best with a running MWE so that we can help you---if necessary---to improve that part.

Moreover, wouldn't it be easier, safer, and faster to replace readLines(files[j]) with, for example, readr::read_csv(files[j])?

\$\endgroup\$
  • \$\begingroup\$ Good advice about profiling. I bet it will show the culprit is the repeated use of the x <- rbind(x, ...) construct inside for loops. \$\endgroup\$ – flodel Aug 22 '17 at 22:51
  • \$\begingroup\$ Thanks for the advice. I'll be looking through these potential problems and maybe posting the updated function. \$\endgroup\$ – Spencer Castro Aug 24 '17 at 12:58

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.