Выполнение нескольких условий одновременно в R

Question

Я написал код для применения функции к фрейму данных 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)

        }

Код работает для небольших наборов данных, но когда фрейм данных содержит более 1 миллиона строк, он работает очень медленно. Я думаю, что есть много строк кода, повторенных в функции (например, условие if else), которые уменьшают скорость. Есть ли способы сделать все вычисления в функции одновременно? Буду очень признателен за любой совет.

Answer 1

Сначала немного тяжелой любви, но я настоятельно рекомендую вам осветить свои основы, ваш код представляет собой концентрат плохих практик, и вы получите огромный возврат инвестиций, потратив немного времени на изучение векторизации и т. Д. Также рассмотрите возможность публикации это на https://codereview.stackexchange.com/questions/tagged/r в следующий раз, так как это более подходящий вопрос для этого.

Ваше узкое место - это не вложенное ifs , а неадекватное использование expand.grid.

Вы создаете в своих кодах фреймы данных через expand.grid, которые вы неправильно называете listC (это не списки). Затем этот дорогостоящий data.frame используется только для количества строк, которое вы получите с помощью dim(listC)[1], который будет иметь более идиоматический тип nrow(listC).

Это значение (dim(listC)[1]) на практике может быть только PR^2 или 3*PR, поэтому вы можете сначала вычислить их и просто использовать их повторно.

Вложенные ifs можно заменить на вложенные операторы switch, более читаемые и проверяя первый выбор только один раз, мы также более эффективны.

Это позволяет нам увидеть, что вы забыли одно условие в вашем коде. Смотрите ваш улучшенный код ниже.

Если посмотреть на него, когда он станет более аккуратным, мы увидим, что мы могли бы заменить его просто на newC <- c(c1 - 2 + choice[2], c2 + 2 - choice[1]).

Дополнительные наблюдения

• комментируйте свой код, не для нас, для вас (и затем для нас, когда вы решите задать вопрос)
• c2 <- as.vector(dataC[2]) можно заменить на c2 <- dataC[[2]]
• Матрица из 2 столбцов и одной строки может быть построена с помощью t(c(1,2)) вместо matrix(c(x = 1, y = 2), ncol = 2), но если вы собираетесь использовать as.vector в конце, сначала наберите c(1,2)
• код, вероятно, может быть оптимизирован гораздо дальше

модифицированный код

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)
}