R 在多个列中搜索字符串以设置指示符变量
我第一次使用R和RStudio来处理一个非常大的数据集，有1500万个案例，有很多列数据。为了便于分析，我需要逐行搜索一系列列，以查看是否有任何特定于匹配的字符串（大约有200个要匹配的字符串）位于另一个数据帧中 数据如下所示R 在多个列中搜索字符串以设置指示符变量,r,R,我第一次使用R和RStudio来处理一个非常大的数据集，有1500万个案例，有很多列数据。为了便于分析，我需要逐行搜索一系列列，以查看是否有任何特定于匹配的字符串（大约有200个要匹配的字符串）位于另一个数据帧中 数据如下所示 Dx1 Dx2 Dx3 etc... 001 234 456 231 001 444 245 777 001 我们需要的是 Dx1 Dx2 Dx3 Var001
Dx1 Dx2 Dx3 etc...
001 234 456
231 001 444
245 777 001
Dx1 Dx2 Dx3 Var001 Var234 Var456 Var231 etc..
001 234 456 True True True False
231 001 444 True False False True
245 777 001 True False False False
将base R与Lappy结合使用的另一个想法是：
将base R与Lappy结合使用的另一个想法是：
在BaseR中，我们只需几行代码就可以实现一个可重用的函数，但需要了解使用哪些函数以及如何使用这些函数 我将调用函数包，就像在单词包中一样
bag <- function(..., prefix=".", levels=NULL, `NA`=NULL) {
# Go from multiple columns to list of vectors
bags <- mapply(c, ..., SIMPLIFY = FALSE, USE.NAMES = FALSE)
# Find unique levels
if(is.null(levels)) {
levels <- sort(Reduce(union, bags))
# names persist through outer
names(levels) <- paste0(prefix, levels)
}
# Calculate out[level,bag] = level %in% bag
out <- outer(levels, bags, Vectorize(`%in%`))
# Output a data structure
structure(+t(out), class='bag', levels=levels)
}
#' @export
makepredictcall.bag <- function(var, call){
# Stolen from splines package
if (as.character(call)[1L] != "bag")
return(call)
args <- c("prefix", "levels")
at <- attributes(var)[args]
xxx <- call
xxx[args] <- NULL
xxx[names(at)] <- at
xxx
}
在BaseR中，我们只需几行代码就可以实现一个可重用的函数，但需要了解使用哪些函数以及如何使用这些函数 我将调用函数包，就像在单词包中一样
bag <- function(..., prefix=".", levels=NULL, `NA`=NULL) {
# Go from multiple columns to list of vectors
bags <- mapply(c, ..., SIMPLIFY = FALSE, USE.NAMES = FALSE)
# Find unique levels
if(is.null(levels)) {
levels <- sort(Reduce(union, bags))
# names persist through outer
names(levels) <- paste0(prefix, levels)
}
# Calculate out[level,bag] = level %in% bag
out <- outer(levels, bags, Vectorize(`%in%`))
# Output a data structure
structure(+t(out), class='bag', levels=levels)
}
#' @export
makepredictcall.bag <- function(var, call){
# Stolen from splines package
if (as.character(call)[1L] != "bag")
return(call)
args <- c("prefix", "levels")
at <- attributes(var)[args]
xxx <- call
xxx[args] <- NULL
xxx[names(at)] <- at
xxx
}
请注意，对于data.frames，行操作往往非常慢。如果您的列都是数字或三位数字符，则最好使用矩阵。此外，如果这是成立的，您可以考虑转置矩阵，然后运行更有效的列级操作。如果您的列都是数字或三位数字符，则最好使用矩阵。此外，如果这是成立的，您可以考虑转置矩阵，然后运行更有效的列级操作。不是纯基R，因为您使用RESHAPE2：：但似乎有效。您还遗漏了从基准测试中找到唯一值的片段，我将其添加到下面的基准测试中。不是纯基R，因为您使用的是Reforma2:：melt。但似乎有效。您还遗漏了从基准测试中找到唯一值的片段，我已将其添加到下面的基准测试中。
bag <- function(..., prefix=".", levels=NULL, `NA`=NULL) {
# Go from multiple columns to list of vectors
bags <- mapply(c, ..., SIMPLIFY = FALSE, USE.NAMES = FALSE)
# Find unique levels
if(is.null(levels)) {
levels <- sort(Reduce(union, bags))
# names persist through outer
names(levels) <- paste0(prefix, levels)
}
# Calculate out[level,bag] = level %in% bag
out <- outer(levels, bags, Vectorize(`%in%`))
# Output a data structure
structure(+t(out), class='bag', levels=levels)
}
with(df1, bag(Dx1, Dx2, Dx3, prefix="Var"))
#> Var001 Var231 Var234 Var245 Var444 Var456 Var777
#> [1,] 1 0 1 0 0 1 0
#> [2,] 1 1 0 0 1 0 0
#> [3,] 1 0 0 1 0 0 1
#> attr(,"class")
#> [1] "bag"
#> attr(,"levels")
#> Var001 Var231 Var234 Var245 Var444 Var456 Var777
#> "001" "231" "234" "245" "444" "456" "777"
#' @export
makepredictcall.bag <- function(var, call){
# Stolen from splines package
if (as.character(call)[1L] != "bag")
return(call)
args <- c("prefix", "levels")
at <- attributes(var)[args]
xxx <- call
xxx[args] <- NULL
xxx[names(at)] <- at
xxx
}
df2 <- as.data.frame(lapply(df1, sample, 20, TRUE), stringsAsFactors = FALSE)
df3 <- as.data.frame(lapply(df1, sample, 20, TRUE), stringsAsFactors = FALSE)
Y <- 1:nrow(df2)
m <- lm(Y~bag(Dx1, Dx2, Dx3), df2)
summary(m)
#>
#> Call:
#> lm(formula = Y ~ bag(Dx1, Dx2, Dx3), data = df2)
#>
#> Residuals:
#> Min 1Q Median 3Q Max
#> -8.1110 -3.6765 0.1948 3.1899 8.7961
#>
#> Coefficients:
#> Estimate Std. Error t value Pr(>|t|)
#> (Intercept) 16.6709 10.3948 1.604 0.135
#> bag(Dx1, Dx2, Dx3).001 -3.7385 5.6141 -0.666 0.518
#> bag(Dx1, Dx2, Dx3).231 -3.7286 4.1728 -0.894 0.389
#> bag(Dx1, Dx2, Dx3).234 3.1786 4.6528 0.683 0.507
#> bag(Dx1, Dx2, Dx3).245 -7.2493 4.4900 -1.615 0.132
#> bag(Dx1, Dx2, Dx3).444 -2.2936 4.3033 -0.533 0.604
#> bag(Dx1, Dx2, Dx3).456 2.9979 4.3826 0.684 0.507
#> bag(Dx1, Dx2, Dx3).777 -0.8608 4.5353 -0.190 0.853
#>
#> Residual standard error: 5.971 on 12 degrees of freedom
#> Multiple R-squared: 0.3566, Adjusted R-squared: -0.01874
#> F-statistic: 0.9501 on 7 and 12 DF, p-value: 0.5056
predict(m, df3)
#> 1 2 3 4 5 6 7
#> 8.681003 16.111016 4.822329 15.079445 19.108899 10.306611 13.817465
#> 8 9 10 11 12 13 14
#> 16.111016 9.788011 12.382454 9.778103 3.389569 12.382454 9.203882
#> 15 16 17 18 19 20
#> 13.817465 9.788011 12.071654 6.267249 13.827373 15.069537
microbenchmark::microbenchmark(mtab = mtabulate(as.data.frame(t(df1)))!=0,
lapply = lapply(as.character(unique(melt(df1, id.vars = NULL)$value)),
function(x) rowSums(df1==x) > 0),
bag = do.call(bag, df1))
#> Unit: microseconds
#> expr min lq mean median uq max neval
#> mtab 439.320 452.107 519.9429 462.9035 511.8710 1960.582 100
#> lapply 276.914 295.976 337.6020 300.7870 315.0135 2268.210 100
#> bag 121.996 130.305 146.6677 139.6990 145.3275 294.711 100