根据来自不同数据帧的2个键定义数据框中列的值

Question

我有以下数据帧:

a <- seq(0, 5, by = 0.25)
b <-seq(0, 20, by = 1)
df <- data.frame(a, b)

我想根据列a和b以及下面的转换表创建一个新列"值":

a_min <- c(0,2, 0,2)
a_max <- c(2,5,2,5)
b_min <- c(0,0,10,10)
b_max <- c(10,10,30,30)
output <-c(1,2,3,4)

conv <- data.frame(a_min, a_max, b_min, b_max, output)

我尝试使用dplyr :: mutate做到这一点没有太大的成功......

require(dplyr)
mutate(df, value = calcula(conv, a, b))

较长的物体长度不是较短物体长度的倍数

我的期望是获得一个像上面'df'这样的数据框,其附加列值如下:

df$value <- c(rep(1,8), rep(2,2), rep(4,11))

Answer 1

使用二进制非等连接的可能相对简单且非常有效的data.table解决方案

library(data.table) # v1.10.0
setDT(conv)[setDT(df), output, on = .(a_min <= a, a_max >= a, b_min <= b, b_max >= b)]
## [1] 1 1 1 1 1 1 1 1 1 2 2 2 4 4 4 4 4 4 4 4 4 4 4

作为旁注,如果output列只是其中的行索引conv,则可以通过指定行索引来使此连接更加高效which = TRUE

setDT(conv)[setDT(df), on = .(a_min <= a, a_max >= a, b_min <= b, b_max >= b), which = TRUE]
## [1] 1 1 1 1 1 1 1 1 1 2 2 2 4 4 4 4 4 4 4 4 4 4 4

Answer 2

还有一个选择,这次是矩阵.

with(df, with(conv, output[max.col(
    outer(a, a_min, `>=`) + outer(a, a_max, `<=`) +
    outer(b, b_min, `>=`) + outer(b, b_max, `<=`))]))

## [1] 1 1 1 1 1 1 1 1 1 2 2 4 4 4 4 4 4 4 4 4 4

outer比较矢量的每个元素与df来自的一个元素,conv为每个调用产生一个布尔矩阵.从TRUE1开始,如果添加所有四个矩阵,则所需的索引将是具有最多TRUEs 的列,您可以使用该索引max.col.子集output,你得到了你的结果.

使用矩阵的好处是它们很快.使用@ Phann的1000行基准测试:

Unit: microseconds
      expr       min         lq       mean     median         uq       max neval   cld
 alistaire   276.099   320.4565   349.1045   339.8375   357.2705   941.551   100 a    
      akr1   830.934   966.6705  1064.8433  1057.6610  1152.3565  1507.180   100 ab   
      akr2 11431.246 11731.3125 12835.5229 11947.5775 12408.4715 36767.488   100    d 
       Pha 11985.129 12403.1095 13330.1465 12660.4050 13044.9330 29653.842   100    d 
       Ron 71132.626 74300.3540 81136.9408 78034.2275 88952.8765 98950.061   100     e
      Dav1  2506.205  2765.4095  2971.6738  2948.6025  3082.4025  4065.368   100   c  
      Dav2  2104.481  2272.9180  2480.9570  2478.8775  2575.8740  3683.896   100  bc  

在100,000行:

Unit: milliseconds
      expr      min       lq     mean   median       uq       max neval cld
 alistaire 30.00677 36.49348 44.28828 39.43293 54.28207  64.36581   100 a  
      akr1 36.24467 40.04644 48.46986 41.59644 60.15175  77.34415   100 a  
      Dav1 51.74218 57.23488 67.70289 64.11002 68.86208 382.25182   100   c
      Dav2 48.48227 54.82818 60.25256 59.81041 64.92611  91.20212   100  b 

Answer 3

我们可以尝试Map用na.locf

library(zoo)
f1 <- function(u, v, x, y, z) z * NA^!((with(df, a >= u & a <v) & (b >=x & b <y)))
na.locf(do.call(pmax, c(do.call(Map, c(f=f1, unname(conv))), na.rm = TRUE)))
#[1] 1 1 1 1 1 1 1 1 2 2 4 4 4 4 4 4 4 4 4 4 4

或者另一种方式编写的Map溶液是通过的"a"和"b"的列作为参数,然后执行逻辑评估与提取"输出"值和"CONV"的列unlist的list输出

unlist(Map(function(x, y) 
     with(conv, output[x >= a_min & a_max > x & y >= b_min & b_max > y]), 
                          df$a, df$b))
#[1] 1 1 1 1 1 1 1 1 2 2 4 4 4 4 4 4 4 4 4 4

注意:第二个解决方案应该更慢,因为我们循环遍历数据集的行,而第一个解决方案循环通过'conv'行(我们假设不应该是很多行)

Answer 4

另一种方法apply:

df$value <- unlist(apply(df, 1, function(x){
    ifelse(length(OUT <- output[which(x[1] >= a_min & x[1] <= a_max & x[2] >= b_min & x[2] <= b_max)]) > 0, OUT, 0)
}))

编辑:

因为到目前为止有几个答案,我检查了处理数据所需的时间.我创建了一个更大的例子(类似于给定的随机数):

set.seed(23563)
a <- runif(1000, 0, 5)
b <- runif(1000, 0, 20)
df <- data.frame(a, b)


require(microbenchmark)
library(zoo)
require(data.table)

microbenchmark(
  akr1 = { #akrun 1
    f1 <- function(u, v, x, y, z) z * NA^!((with(df, a >= u & a <v) & (b >=x & b <y)))
    na.locf(do.call(pmax, c(do.call(Map, c(f=f1, unname(conv))), na.rm = TRUE)))
  },
  akr2 = { #akrun 2
    unlist(Map(function(x, y) 
      with(conv, output[x >= a_min & a_max > x & y >= b_min & b_max > y]), 
      df$a, df$b))
  },
  Pha = { #Phann
    df$value <- unlist(apply(df, 1, function(x){
      ifelse(length(OUT <- output[which(x[1] >= a_min & x[1] <= a_max & x[2] >= b_min & x[2] <= b_max)]) > 0, OUT, 0)
    }))
  }, 
  Ron = { #Ronak Shah
    unlist(mapply(function(x, y) 
      conv$output[x >= conv$a_min & conv$a_max > x & y >= conv$b_min & conv$b_max > y], 
      df$a, df$b))
  },
  Dav1 ={ #David Arenburg 1
    setDT(conv)[setDT(df), on = .(a_min <= a, a_max >= a, b_min <= b, b_max >= b)]$output
  },
  Dav2 = { #David Arenburg 2
    setDT(conv)[setDT(df), on = .(a_min <= a, a_max >= a, b_min <= b, b_max >= b), which = TRUE]
  },
  times = 100L
)

有1000个随机数:

# Unit: milliseconds
# expr        min         lq       mean     median         uq       max neval
# akr1   4.267206   4.749576   6.259695   5.351494   6.843077  54.39187   100
# akr2  33.437853  39.912785  49.932875  47.416888  57.070369  91.55602   100
# Pha   30.433779  36.939692  48.205592  46.393800  55.800204  83.91640   100
# Ron  174.765021 199.648315 227.493117 223.314661 240.579057 370.26929   100
# Dav1   6.944759   7.814469  10.685460   8.536694  11.974102  44.47915   100
# Dav2   6.106978   6.706424   8.961821   8.161707  10.376085  28.91255   100

有10000个随机数(相同的种子),我得到:

# Unit: milliseconds
# expr        min         lq       mean     median         uq        max neval
# akr1   23.48180   24.03962   26.16747   24.46897   26.19565   41.83238   100
# akr2  357.38290  398.69965  434.92052  409.15385  440.98210  829.85113   100
# Pha   320.39285  347.66632  376.98118  361.76852  383.08231  681.28500   100
# Ron  1661.50669 1788.06228 1873.70929 1837.28187 1912.04123 2499.23235   100
# Dav1   20.91486   21.60953   23.12278   21.94707   22.42773   44.71900   100
# Dav2   19.69506   20.22077   21.63715   20.55793   21.27578   38.96819   100