Vfrdtyky

I wrote a code to apply a function to a data frame input:

    set.seed(1234) 

    n = 5000000

    input <- as.matrix(data.frame(c1 = sample(1:10, n, replace = T), c2 = sample(1:10, n, replace = T), c3 = sample(1:10, n, replace = T), c4 = sample(1:10, n, replace = T)))



    system.time(

    test <- input %>% 

      split(1:nrow(input)) %>% 

      map(~ func1(.x, 2, 2, "test_1")) %>% 

      do.call("rbind", .))



## Here is the function used:



    func1 <- function(dataC, PR, DB, MT){



          c1 <- as.vector(dataC[1])

          c2 <- as.vector(dataC[2])



          c3 <- as.vector(dataC[3])

          c4 <- as.vector(dataC[4])



          newc1 <- -999

          newc2 <- -999



          if(MT=="test_1"){



            listC <- expand.grid(x = c((c1 - PR) : (c1 - 1)), y = c((c2 + 1) : (c2 + PR)))

            V1 <- mean(sample(1:10, size = dim(listC)[1], replace = TRUE)) * sqrt(2) * DB



            listC <- expand.grid(x = c((c1 - 1) : (c1 + 1)), y = c((c2 + 1) : (c2 + PR)))

            V2 <- mean(sample(1:10, size = dim(listC)[1], replace = TRUE)) * DB



            listC <- expand.grid(x = c((c1 + 1) : (c1 + PR)), y = c((c2 + 1) : (c2 + PR)))

            V3 <- mean(sample(1:10, size = dim(listC)[1], replace = TRUE)) * sqrt(2) * DB



            listC <- expand.grid(x = c((c1 - PR) : (c1 - 1)), y = c((c2 - 1) : (c2 + 1)))

            V4 <- mean(sample(1:10, size = dim(listC)[1], replace = TRUE)) * DB



            V5 <- 0



            listC <- expand.grid(x = c((c1 + 1) : (c1 + PR)), y = c((c2 - 1) : (c2 + 1)))

            V6 <- mean(sample(1:10, size = dim(listC)[1], replace = TRUE)) * DB



            listC <- expand.grid(x = c((c1 - PR) : (c1 - 1)), y = c((c2 - PR) : (c2 - 1)))

            V7 <- mean(sample(1:10, size = dim(listC)[1], replace = TRUE)) * sqrt(2) * DB



            listC <- expand.grid(x = c((c1 - 1) : (c1 + 1)), y = c((c2 - PR) : (c2 - 1)))

            V8 <- mean(sample(1:10, size = dim(listC)[1], replace = TRUE)) * DB



            listC <- expand.grid(x = c((c1 + 1) : (c1 + PR)), y = c((c2 - PR) : (c2 - 1)))

            V9 <- mean(sample(1:10, size = dim(listC)[1], replace = TRUE)) * sqrt(2) * DB





          } else if(MT=="test_2"){



            listC <- expand.grid(x = c((c1 - PR) : (c1 - 1)), y = c((c2 + 1) : (c2 + PR)))

            V1 <- harmonic.mean(sample(1:10, size = dim(listC)[1], replace = TRUE)) * sqrt(2) * DB



            listC <- expand.grid(x = c((c1 - 1) : (c1 + 1)), y = c((c2 + 1) : (c2 + PR)))

            V2 <- harmonic.mean(sample(1:10, size = dim(listC)[1], replace = TRUE)) * DB



            listC <- expand.grid(x = c((c1 + 1) : (c1 + PR)), y = c((c2 + 1) : (c2 + PR)))

            V3 <- harmonic.mean(sample(1:10, size = dim(listC)[1], replace = TRUE)) * sqrt(2) * DB



            listC <- expand.grid(x = c((c1 - PR) : (c1 - 1)), y = c((c2 - 1) : (c2 + 1)))

            V4 <- harmonic.mean(sample(1:10, size = dim(listC)[1], replace = TRUE)) * DB



            V5 <- 0



            listC <- expand.grid(x = c((c1 + 1) : (c1 + PR)), y = c((c2 - 1) : (c2 + 1)))

            V6 <- harmonic.mean(sample(1:10, size = dim(listC)[1], replace = TRUE)) * DB



            listC <- expand.grid(x = c((c1 - PR) : (c1 - 1)), y = c((c2 - PR) : (c2 - 1)))

            V7 <- harmonic.mean(sample(1:10, size = dim(listC)[1], replace = TRUE)) * sqrt(2) * DB



            listC <- expand.grid(x = c((c1 - 1) : (c1 + 1)), y = c((c2 - PR) : (c2 - 1)))

            V8 <- harmonic.mean(sample(1:10, size = dim(listC)[1], replace = TRUE)) * DB



            listC <- expand.grid(x = c((c1 + 1) : (c1 + PR)), y = c((c2 - PR) : (c2 - 1)))

            V9 <- harmonic.mean(sample(1:10, size = dim(listC)[1], replace = TRUE)) * sqrt(2) * DB



          }



          tot <- sum(c(1/V1, 1/V2, 1/V3, 1/V4, 1/V6, 1/V7, 1/V8, 1/V9), na.rm = TRUE)

          mat_V <- matrix(data = c((1/V1)/tot, (1/V2)/tot, (1/V3)/tot, (1/V4)/tot, V5, 

                                        (1/V6)/tot, (1/V7)/tot, (1/V8)/tot, (1/V9)/tot), nrow = 3, ncol = 3, byrow = TRUE)



          while((newc1 == -999 && newc2 == -999) || (c3 == newc1 && c4 == newc2)){



            if(c3 == newc1 && c4 == newc2){

              mat_V[choiceC[1], choiceC[2]] <- NaN

              ## print(mat_V)

            }



            choiceC <- which(mat_V == max(mat_V, na.rm = TRUE), arr.ind = TRUE)

            ## print(choiceC)

            ## If there are several maximum values

            if(nrow(choiceC) > 1){

              choiceC <- choiceC[sample(1:nrow(choiceC), 1), ]

            }



            if(choiceC[1]==1 & choiceC[2]==1){



              newC <- matrix(c(x = c1 - 1, y = c2 + 1), ncol = 2)



            } else if(choiceC[1]==1 & choiceC[2]==2){



              newC <- matrix(c(x = c1, y = c2 + 1), ncol = 2)



            } else if(choiceC[1]==1 & choiceC[2]==3){



              newC <- matrix(c(x = c1 + 1, y = c2 + 1), ncol = 2)



            } else if(choiceC[1]==2 & choiceC[2]==1){



              newC <- matrix(c(x = c1 - 1, y = c2), ncol = 2)



            } else if(choiceC[1]==2 & choiceC[2]==3){



              newC <- matrix(c(x = c1 + 1, y = c2), ncol = 2)



            } else if(choiceC[1]==3 & choiceC[2]==1){



              newC <- matrix(c(x = c1 - 1, y = c2 - 1), ncol = 2)



            } else if(choiceC[1]==3 & choiceC[2]==2){



              newC <- matrix(c(x = c1, y = c2 - 1), ncol = 2)



            } else if(choiceC[1]==3 & choiceC[2]==3){ 



              newC <- matrix(c(x = c1 + 1, y = c2 - 1), ncol = 2)

            }



            newc1 <- as.vector(newC[,1])

            newc2 <- as.vector(newC[,2])



          }



          return(newC)



        }

The code works for small datasets but when the data frame contains more than 1 million rows, it is very slow. I think that there are many lines of code repeated in the function (e.g., condition if else) which decrease the speed. Are there ways to do all calculations in the function at once? I would really appreciate for any advice.

First a bit of tough love but I strongly encourage you to cover your bases, your code is a concentrate of bad practices and you'll get a huge ROI by spending a bit of time studying vectorisation etc... Consider also posting this on https://codereview.stackexchange.com/questions/tagged/r next time as it is a more appropriate question for there.

Your bottleneck is not the nested ifs but the inadequate use of expand.grid.

You create in your codes data frames through expand.grid, that you improperly call listC (they're not lists). Then this costly data.frame is only used for its number of rows, which you get with dim(listC)[1] which would be more idiomatic typed nrow(listC).

This value (dim(listC)[1]) can only be PR^2 or 3*PR in practice, so you could compute those first and just reuse them.

The nested ifs can be replaced with nested switch statements, more readable, and
by testing the first choice only once we're also more efficient.

It allows us to see that you forgot one condition in your code. See your improved code below.

When looking at it once it's more tidy, we see that we could actually replace it by simply newC <- c(c1 - 2 + choice[2], c2 + 2 - choice[1]).

Additional observations

• comment your code, not for us, for you (and then for us when you decide to post a question)


• 
  c2 <- as.vector(dataC[2]) can be replaced by c2 <- dataC[[2]]
  


• A matrix of 2 columns and one row can be built by t(c(1,2)) instead of matrix(c(x = 1, y = 2), ncol = 2), but if you're going to use as.vector on it in the end, do c(1,2) in the first place


• the code could probably be optimized much further

modified code

func1 <- function(dataC, PR, DB, MT){



  c1 <- dataC[[1]]

  c2 <- dataC[[2]]

  c3 <- dataC[[3]]

  c4 <- dataC[[4]]



  fun  <- if(MT=="test_1") mean else if(MT=="test_2") harmonic.mean

  fun2 <- function(size,mult)

    fun(sample(1:10, size = size, replace = TRUE)) * mult



  pr_sq <- PR^2

  pr_3 <- 3*PR

  sqrt_2_DB <- sqrt(2) * DB

  V1 <- fun2(pr_sq, sqrt_2_DB)

  V2 <- fun2(pr_3, DB)

  V3 <- fun2(pr_sq, sqrt_2_DB)

  V4 <- fun2(pr_3, DB)

  V5 <- 0

  V6 <- fun2(pr_3,  DB)

  V7 <- fun2(pr_sq, sqrt_2_DB)

  V8 <- fun2(pr_3,  DB)

  V9 <- fun2(pr_sq, sqrt_2_DB)



  inv <- 1/c(V1, V2, V3, V4, V6, V7, V8, V9)

  tot <- sum(inv, na.rm = TRUE)

  mat_V <- matrix(data = c(inv[1:4], V5, inv[5:8]) / tot, 

                  nrow = 3, ncol = 3, byrow = TRUE)



  newC <- NULL

  while(is.null(newC) || identical(c(c3,c4), newC)){



    if(identical(c(c3,c4), newC)){

      mat_V[choiceC[1], choiceC[2]] <- NaN

      ## print(mat_V)

    }



    choiceC <- which(mat_V == max(mat_V, na.rm = TRUE), arr.ind = TRUE)

    ## print(choiceC)

    ## If there are several maximum values

    if(nrow(choiceC) > 1){

      choiceC <- choiceC[sample(1:nrow(choiceC), 1), ]

    }



    newC <- c(c1 - 2 + choiceC[2], c2 + 2 - choiceC[1])



    # using switch it would have been

    # newC <- switch(choiceC[1],

    #        `1` = switch(choiceC[2],

    #                     `1` = c(x = c1 - 1, y = c2 + 1),

    #                     `2` = c(x = c1, y = c2 + 1),

    #                     `3` = c(x = c1 + 1, y = c2 + 1)),

    #        `2` = switch(choiceC[2],

    #                     `1` = c(x = c1 - 1, y = c2),

    #                     `2` = c(x = c1, y = c2), # you were missing this one

    #                     `3` = c(x = c1 + 1, y = c2)),

    #        `3` = switch(choiceC[2],

    #                     `1` = c(x = c1 - 1, y = c2 - 1),

    #                     `2` = c(x = c1, y = c2 - 1),

    #                     `3` = c(x = c1 + 1, y = c2 - 1)))

  }

  t(newC)

}