将字符串列拆分为几个虚拟变量
Posted
技术标签:
【中文标题】将字符串列拆分为几个虚拟变量【英文标题】：Split a string column into several dummy variables 【发布时间】：2013-04-01 02:40:18 【问题描述】：作为 R 中 data.table 包的相对缺乏经验的用户，我一直在尝试将一个文本列处理成大量的指标列（虚拟变量），每列中的 1 表示特定的子-string 在字符串列中找到。比如我要处理这个：
ID String
1 a$b
2 b$c
3 c
进入这个：
ID String a b c
1 a$b 1 1 0
2 b$c 0 1 1
3 c 0 0 1
我已经弄清楚如何进行处理，但是运行时间比我想要的要长，而且我怀疑我的代码效率低下。下面是我的带有虚拟数据的代码的可复制版本。请注意，在实际数据中，要搜索的子字符串有 2000 多个，每个子字符串大约 30 个字符长，可能多达几百万行。如果需要，我可以并行化并在问题上投入大量资源，但我想尽可能优化代码。我曾尝试运行 Rprof，但没有发现（对我而言）明显的改进。
set.seed(10)
elements_list <- c(outer(letters, letters, FUN = paste, sep = ""))
random_string <- function(min_length, max_length, separator)
selection <- paste(sample(elements_list, ceiling(runif(1, min_length, max_length))), collapse = separator)
return(selection)
dt <- data.table(id = c(1:1000), messy_string = "")
dt[ , messy_string := random_string(2, 5, "$"), by = id]
create_indicators <- function(search_list, searched_string)
y <- rep(0, length(search_list))
for(j in 1:length(search_list))
x <- regexpr(search_list[j], searched_string)
x <- x[1]
y[j] <- ifelse(x > 0, 1, 0)
return(y)
timer <- proc.time()
indicators <- matrix(0, nrow = nrow(dt), ncol = length(elements_list))
for(n in 1:nrow(dt))
indicators[n, ] <- dt[n, create_indicators(elements_list, messy_string)]
indicators <- data.table(indicators)
setnames(indicators, elements_list)
dt <- cbind(dt, indicators)
proc.time() - timer
user system elapsed
13.17 0.08 13.29
编辑
感谢您的出色回应——所有这些都比我的方法要好得多。下面是一些速度测试的结果，对每个函数稍作修改，在我自己的代码中使用 0L 和 1L，将结果按方法存储在单独的表中，并标准化排序。这些是单次速度测试的经过时间（而不是多次测试的中位数），但较大的运行每次都需要很长时间。
Number of rows in dt 2K 10K 50K 250K 1M
OP 28.6 149.2 717.0
eddi 5.1 24.6 144.8 1950.3
RS 1.8 6.7 29.7 171.9 702.5
Original GT 1.4 7.4 57.5 809.4
Modified GT 0.7 3.9 18.1 115.2 473.9
GT4 0.1 0.4 2.26 16.9 86.9
很明显，GeekTrader 方法的修改版本是最好的。我对每个步骤的作用仍然有些模糊，但我可以在闲暇时复习。尽管有点超出了最初的问题，但如果有人想解释 GeekTrader 和 Ricardo Saporta 的方法在哪些方面做得更有效，我以及将来访问此页面的任何人都将不胜感激。我特别有兴趣了解为什么有些方法比其他方法扩展得更好。
*****编辑#2*****
我尝试使用此评论编辑 GeekTrader 的答案，但这似乎不起作用。我对 GT3 函数做了两个非常小的修改，a) 对列进行排序，这会增加少量时间，b) 将 0 和 1 替换为 0L 和 1L，这会加快速度。调用生成的函数 GT4。上表已编辑以添加不同表大小的 GT4 时间。显然是一英里的赢家，而且它具有直观的额外优势。
【问题讨论】：
更新了版本 3，速度更快，内存效率更高 这是一个很棒的问题，答案很棒。在您的基准测试中，是Modified GT GT3？如果是这样，当我通过将 0 和 1 更改为 0L 和 1L 来实现 GT4 时，我无法获得 10 倍的速度。
【参考方案1】：
更新：版本 3
找到更快的方法。此功能还具有很高的内存效率。
之前函数运行缓慢的主要原因是 lapply 循环内发生的复制/分配以及结果的 rbinding。
在下面的版本中，我们预先分配了适当大小的矩阵，然后在适当的坐标处改变值，这与其他循环版本相比速度非常快。
funcGT3 <- function()
#Get list of column names in result
resCol <- unique(dt[, unlist(strsplit(messy_string, split="\\$"))])
#Get dimension of result
nresCol <- length(resCol)
nresRow <- nrow(dt)
#Create empty matrix with dimensions same as desired result
mat <- matrix(rep(0, nresRow * nresCol), nrow = nresRow, dimnames = list(as.character(1:nresRow), resCol))
#split each messy_string by $
ll <- strsplit(dt[,messy_string], split="\\$")
#Get coordinates of mat which we need to set to 1
coords <- do.call(rbind, lapply(1:length(ll), function(i) cbind(rep(i, length(ll[[i]])), ll[[i]] )))
#Set mat to 1 at appropriate coordinates
mat[coords] <- 1
#Bind the mat to original data.table
return(cbind(dt, mat))
result <- funcGT3() #result for 1000 rows in dt
result
ID messy_string zn tc sv db yx st ze qs wq oe cv ut is kh kk im le qg rq po wd kc un ft ye if zl zt wy et rg iu
1: 1 zn$tc$sv$db$yx 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
2: 2 st$ze$qs$wq 0 0 0 0 0 1 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
3: 3 oe$cv$ut$is 0 0 0 0 0 0 0 0 0 1 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
4: 4 kh$kk$im$le$qg 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0
5: 5 rq$po$wd$kc 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 0 0 0 0 0 0 0 0 0 0
---
996: 996 rp$cr$tb$sa 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
997: 997 cz$wy$rj$he 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0
998: 998 cl$rr$bm 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
999: 999 sx$hq$zy$zd 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
1000: 1000 bw$cw$pw$rq 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0
Ricardo 建议的第 2 版基准测试（这是针对 250K 行数据）：
Unit: seconds
expr min lq median uq max neval
GT2 104.68672 104.68672 104.68672 104.68672 104.68672 1
GT3 15.15321 15.15321 15.15321 15.15321 15.15321 1
版本 1 以下是建议答案的第 1 版
set.seed(10)
elements_list <- c(outer(letters, letters, FUN = paste, sep = ""))
random_string <- function(min_length, max_length, separator)
selection <- paste(sample(elements_list, ceiling(runif(1, min_length, max_length))), collapse = separator)
return(selection)
dt <- data.table(ID = c(1:1000), messy_string = "")
dt[ , messy_string := random_string(2, 5, "$"), by = ID]
myFunc <- function()
ll <- strsplit(dt[,messy_string], split="\\$")
COLS <- do.call(rbind,
lapply(1:length(ll),
function(i)
data.frame(
ID= rep(i, length(ll[[i]])),
COL = ll[[i]],
VAL= rep(1, length(ll[[i]]))
)
)
)
res <- as.data.table(tapply(COLS$VAL, list(COLS$ID, COLS$COL), FUN = length ))
dt <- cbind(dt, res)
for (j in names(dt))
set(dt,which(is.na(dt[[j]])),j,0)
return(dt)
create_indicators <- function(search_list, searched_string)
y <- rep(0, length(search_list))
for(j in 1:length(search_list))
x <- regexpr(search_list[j], searched_string)
x <- x[1]
y[j] <- ifelse(x > 0, 1, 0)
return(y)
OPFunc <- function()
indicators <- matrix(0, nrow = nrow(dt), ncol = length(elements_list))
for(n in 1:nrow(dt))
indicators[n, ] <- dt[n, create_indicators(elements_list, messy_string)]
indicators <- data.table(indicators)
setnames(indicators, elements_list)
dt <- cbind(dt, indicators)
return(dt)
library(plyr)
plyrFunc <- function()
indicators = do.call(rbind.fill, sapply(1:dim(dt)[1], function(i)
dt[i,
data.frame(t(as.matrix(table(strsplit(messy_string,
split = "\\$")))))
]))
dt = cbind(dt, indicators)
#dt[is.na(dt)] = 0 #THIS DOESN'T WORK. USING FOLLOWING INSTEAD
for (j in names(dt))
set(dt,which(is.na(dt[[j]])),j,0)
return(dt)
基准
system.time(res <- myFunc())
## user system elapsed
## 1.01 0.00 1.01
system.time(res2 <- OPFunc())
## user system elapsed
## 21.58 0.00 21.61
system.time(res3 <- plyrFunc())
## user system elapsed
## 1.81 0.00 1.81
版本 2：Ricardo 建议
我在这里发布这个而不是在我的答案中，因为该框架确实是 @GeekTrader 的 -Rick_
myFunc.modified <- function()
ll <- strsplit(dt[,messy_string], split="\\$")
## MODIFICATIONS:
# using `rbindlist` instead of `do.call(rbind.. )`
COLS <- rbindlist( lapply(1:length(ll),
function(i)
data.frame(
ID= rep(i, length(ll[[i]])),
COL = ll[[i]],
VAL= rep(1, length(ll[[i]])),
# MODICIATION: Not coercing to factors
stringsAsFactors = FALSE
)
)
)
# MODIFICATION: Preserve as matrix, the output of tapply
res2 <- tapply(COLS$VAL, list(COLS$ID, COLS$COL), FUN = length )
# FLATTEN into a data.table
resdt <- data.table(r=c(res2))
# FIND & REPLACE NA's of single column
resdt[is.na(r), r:=0L]
# cbind with dt, a matrix, with the same attributes as `res2`
cbind(dt,
matrix(resdt[[1]], ncol=ncol(res2), byrow=FALSE, dimnames=dimnames(res2)))
### Benchmarks:
orig = quote(dt <- copy(masterDT); myFunc())
modified = quote(dt <- copy(masterDT); myFunc.modified())
microbenchmark(Modified = eval(modified), Orig = eval(orig), times=20L)
# Unit: milliseconds
# expr min lq median uq max
# 1 Modified 895.025 971.0117 1011.216 1189.599 2476.972
# 2 Orig 1953.638 2009.1838 2106.412 2230.326 2356.802
【讨论】：
使用其中一个基准库在这里可能更有用，因为单次运行只能提供这么多信息。不错的解决方案！ +1 速度翻倍！！不过奇怪的是，缺少一列...？ 这是另一个 2 倍的改进：在您的代码中，在lapply 中，设置 stringAsFactors=FALSE 并使用 rbindlist(lapply(..)) 而不是 do.call(rbind, lapply(..))。从字面上看，一半的时间！
在我看来，这种方法在行数方面的扩展性也很差，即使速度提高了 2 倍，它也会比 RS 用于大型表的方法慢。我现在正在运行 100,000 行的时间测试（仍然小于“真实”数据），我会发布结果。
@geektrader，我希望你不介意，我在你的答案末尾附加了一个稍微修改过的函数。【参考方案2】：
# split the `messy_string` and create a long table, keeping track of the id
DT2 <- setkey(DT[, list(val=unlist(strsplit(messy_string, "\\$"))), by=list(ID, messy_string)], "val")
# add the columns, initialize to 0
DT2[, c(elements_list) := 0L]
# warning expected, re:adding large ammount of columns
# iterate over each value in element_list, assigning 1's ass appropriate
for (el in elements_list)
DT2[el, c(el) := 1L]
# sum by ID
DT2[, lapply(.SD, sum), by=list(ID, messy_string), .SDcols=elements_list]
请注意，我们携带messy_string 列，因为它比留下它然后joining ID 将其取回更便宜。
如果您在最终输出中不需要它，只需将其删除即可。
基准测试：
创建样本数据：
# sample data, using OP's exmple
set.seed(10)
N <- 1e6 # number of rows
elements_list <- c(outer(letters, letters, FUN = paste, sep = ""))
messy_string_vec <- random_string_fast(N, 2, 5, "$") # Create the messy strings in a single shot.
masterDT <- data.table(ID = c(1:N), messy_string = messy_string_vec, key="ID") # create the data.table
附注 一次创建所有随机字符串并将结果分配为单列要快得多 而不是调用函数 N 次并一一分配。
# Faster way to create the `messy_string` 's
random_string_fast <- function(N, min_length, max_length, separator)
ints <- seq(from=min_length, to=max_length)
replicate(N, paste(sample(elements_list, sample(ints)), collapse=separator))
比较四种方法：
这个答案——“DT.RS” @eddi 的回答——“Plyr.eddi” @GeekTrader 的回答——DT.GT GeekTrader 的回答稍作修改——DT.GT_Mod这里是设置：
library(data.table); library(plyr); library(microbenchmark)
# data.table method - RS
usingDT.RS <- quote(DT <- copy(masterDT);
DT2 <- setkey(DT[, list(val=unlist(strsplit(messy_string, "\\$"))), by=list(ID, messy_string)], "val"); DT2[, c(elements_list) := 0L]
for (el in elements_list) DT2[el, c(el) := 1L]; DT2[, lapply(.SD, sum), by=list(ID, messy_string), .SDcols=elements_list])
# data.table method - GeekTrader
usingDT.GT <- quote(dt <- copy(masterDT); myFunc())
# data.table method - GeekTrader, modified by RS
usingDT.GT_Mod <- quote(dt <- copy(masterDT); myFunc.modified())
# ply method from below
usingPlyr.eddi <- quote(dt <- copy(masterDT); indicators = do.call(rbind.fill, sapply(1:dim(dt)[1], function(i) dt[i, data.frame(t(as.matrix(table(strsplit(messy_string, split = "\\$"))))) ]));
dt = cbind(dt, indicators); dt[is.na(dt)] = 0; dt )
以下是基准测试结果：
microbenchmark( usingDT.RS=eval(usingDT.RS), usingDT.GT=eval(usingDT.GT), usingDT.GT_Mod=eval(usingDT.GT_Mod), usingPlyr.eddi=eval(usingPlyr.eddi), times=5L)
On smaller data:
N = 600
Unit: milliseconds
expr min lq median uq max
1 usingDT.GT 1189.7549 1198.1481 1200.6731 1202.0972 1203.3683
2 usingDT.GT_Mod 581.7003 591.5219 625.7251 630.8144 650.6701
3 usingDT.RS 2586.0074 2602.7917 2637.5281 2819.9589 3517.4654
4 usingPlyr.eddi 2072.4093 2127.4891 2225.5588 2242.8481 2349.6086
N = 1,000
Unit: seconds
expr min lq median uq max
1 usingDT.GT 1.941012 2.053190 2.196100 2.472543 3.096096
2 usingDT.RS 3.107938 3.344764 3.903529 4.010292 4.724700
3 usingPlyr 3.297803 3.435105 3.625319 3.812862 4.118307
N = 2,500
Unit: seconds
expr min lq median uq max
1 usingDT.GT 4.711010 5.210061 5.291999 5.307689 7.118794
2 usingDT.GT_Mod 2.037558 2.092953 2.608662 2.638984 3.616596
3 usingDT.RS 5.253509 5.334890 6.474915 6.740323 7.275444
4 usingPlyr.eddi 7.842623 8.612201 9.142636 9.420615 11.102888
N = 5,000
expr min lq median uq max
1 usingDT.GT 8.900226 9.058337 9.233387 9.622531 10.839409
2 usingDT.GT_Mod 4.112934 4.293426 4.460745 4.584133 6.128176
3 usingDT.RS 8.076821 8.097081 8.404799 8.800878 9.580892
4 usingPlyr.eddi 13.260828 14.297614 14.523016 14.657193 16.698229
# dropping the slower two from the tests:
microbenchmark( usingDT.RS=eval(usingDT.RS), usingDT.GT=eval(usingDT.GT), usingDT.GT_Mod=eval(usingDT.GT_Mod), times=6L)
N = 10,000
Unit: seconds
expr min lq median uq max
1 usingDT.GT_Mod 8.426744 8.739659 8.750604 9.118382 9.848153
2 usingDT.RS 15.260702 15.564495 15.742855 16.024293 16.249556
N = 25,000
... (still running)
-----------------
基准测试中使用的函数：
# original random string function
random_string <- function(min_length, max_length, separator)
selection <- paste(sample(elements_list, ceiling(runif(1, min_length, max_length))), collapse = separator)
return(selection)
# GeekTrader's function
myFunc <- function()
ll <- strsplit(dt[,messy_string], split="\\$")
COLS <- do.call(rbind,
lapply(1:length(ll),
function(i)
data.frame(
ID= rep(i, length(ll[[i]])),
COL = ll[[i]],
VAL= rep(1, length(ll[[i]]))
)
)
)
res <- as.data.table(tapply(COLS$VAL, list(COLS$ID, COLS$COL), FUN = length ))
dt <- cbind(dt, res)
for (j in names(dt))
set(dt,which(is.na(dt[[j]])),j,0)
return(dt)
# Improvements to @GeekTrader's `myFunc` -RS '
myFunc.modified <- function()
ll <- strsplit(dt[,messy_string], split="\\$")
## MODIFICATIONS:
# using `rbindlist` instead of `do.call(rbind.. )`
COLS <- rbindlist( lapply(1:length(ll),
function(i)
data.frame(
ID= rep(i, length(ll[[i]])),
COL = ll[[i]],
VAL= rep(1, length(ll[[i]])),
# MODICIATION: Not coercing to factors
stringsAsFactors = FALSE
)
)
)
# MODIFICATION: Preserve as matrix, the output of tapply
res2 <- tapply(COLS$VAL, list(COLS$ID, COLS$COL), FUN = length )
# FLATTEN into a data.table
resdt <- data.table(r=c(res2))
# FIND & REPLACE NA's of single column
resdt[is.na(r), r:=0L]
# cbind with dt, a matrix, with the same attributes as `res2`
cbind(dt,
matrix(resdt[[1]], ncol=ncol(res2), byrow=FALSE, dimnames=dimnames(res2)))
### Benchmarks comparing the two versions of GeekTrader's function:
orig = quote(dt <- copy(masterDT); myFunc())
modified = quote(dt <- copy(masterDT); myFunc.modified())
microbenchmark(Modified = eval(modified), Orig = eval(orig), times=20L)
# Unit: milliseconds
# expr min lq median uq max
# 1 Modified 895.025 971.0117 1011.216 1189.599 2476.972
# 2 Orig 1953.638 2009.1838 2106.412 2230.326 2356.802
【讨论】：
您可以使用 OP 的示例数据添加解决方案吗？这将使基准比较更容易:) @geektrader，等一下。data.table 解决方案很酷，但为什么新示例带有新变量 findMe？在您的基准测试中应该是 elements_list，在我的 PC 上，它比使用 NA 替换的 plyr 解决方案快大约 3 倍，比没有 NA 替换的 plyr 快大约 20%。
另外，如果您将公式中的 0 和 1 指定为整数，即 0L 和 1L，您的 data.table 解决方案会稍微快一些
感谢 eddi，是的，我也把 0L 放在这里了。我没有充分阅读OP的问题。我认为你是对的，strsplitting 可能是获得最佳速度的方法。现在运行一些基准测试。【参考方案3】：
这是一种较新的方法，使用来自splitstackshape 包的cSplit_e()。
library(splitstackshape)
cSplit_e(dt, split.col = "String", sep = "$", type = "character",
mode = "binary", fixed = TRUE, fill = 0)
# ID String String_a String_b String_c
#1 1 a$b 1 1 0
#2 2 b$c 0 1 1
#3 3 c 0 0 1
【讨论】：
【参考方案4】：这是一个使用 rbind.fill 的快约 10 倍的版本。
library(plyr)
indicators = do.call(rbind.fill, sapply(1:dim(dt)[1], function(i)
dt[i,
data.frame(t(as.matrix(table(strsplit(messy_string,
split = "\\$")))))
]))
dt = cbind(dt, indicators)
# dt[is.na(dt)] = 0
# faster NA replace (thanks geektrader)
for (j in names(dt))
set(dt, which(is.na(dt[[j]])), j, 0L)
【讨论】：
您好，很好的解决方案。不幸的是，似乎有些东西可能有点不准确。请看一下输出。 ??如果这就是您所说的，则列的顺序会有所不同 这看起来很有希望，在我的机器上，最后一步的时间足迹可以忽略不计；即使包括它，我也得到了 10 倍的加速改进。我确实需要按特定顺序排列的列，但我可以在最后重新排序（我认为这应该很快，但还没有尝试过）。但是，在我看来，此解决方案可能无法随行数扩展。我目前正在运行一个大型测试，看看有多少收益随着更多的行而消散。 它在我的测试中随行数线性缩放。 @eddi，非常好的 plyr 解决方案！ :)【参考方案5】：这是一种使用rapply 和table 的方法。
我敢肯定会有比在此处使用 table 稍快的方法，但它仍然比来自@ricardo;s answer的myfunc.Modified 稍快
# a copy with enough column pointers available
dtr <- alloc.col(copy(dt) ,1000L)
rapplyFun <- function()
ll <- strsplit(dtr[, messy_string], '\\$')
Vals <- rapply(ll, classes = 'character', f= table, how = 'replace')
Names <- unique(rapply(Vals, names))
dtr[, (Names) := 0L]
for(ii in seq_along(Vals))
for(jj in names(Vals[[ii]]))
set(dtr, i = ii, j = jj, value =Vals[[ii]][jj])
microbenchmark(myFunc.modified(), rapplyFun(),times=5)
Unit: milliseconds
# expr min lq median uq max neval
# myFunc.modified() 395.1719 396.8706 399.3218 400.6353 401.1700 5
# rapplyFun() 308.9103 309.5763 309.9368 310.2971 310.3463 5
【讨论】：
【参考方案6】：这是另一种解决方案，它构造一个稀疏矩阵对象，而不是你所拥有的。这节省了大量时间和内存。
它产生有序的结果，即使转换为data.table，它也比使用0L 和1L 的GT3 更快，并且没有重新排序（这可能是因为我使用不同的方法来达到所需的坐标 - 我没有'无需通过 GT3 算法），但是如果您不转换并将其保留为稀疏矩阵，则它比 GT3 快 10-20 倍（并且内存占用要小得多）。
library(Matrix)
strings = strsplit(dt$messy_string, split = "$", fixed = TRUE)
element.map = data.table(el = elements_list, n = seq_along(elements_list), key = "el")
tmp = data.table(n = seq_along(strings), each = unlist(lapply(strings, length)))
rows = tmp[, rep(n, each = each), by = n][, V1]
cols = element.map[J(unlist(strings))][,n]
dt.sparse = sparseMatrix(rows, cols, x = 1,
dims = c(max(rows), length(elements_list)))
# optional, should be avoided until absolutely necessary
dt = cbind(dt, as.data.table(as.matrix(dt.sparse)))
setnames(dt, c('id', 'messy_string', elements_list))
想法是拆分为字符串，然后使用data.table 作为映射对象，将每个子字符串映射到其正确的列位置。从那里开始，只需正确计算行并填写矩阵即可。
【讨论】：
以上是关于将字符串列拆分为几个虚拟变量的主要内容，如果未能解决你的问题，请参考以下文章