來自字符串變量的虛擬變量

Question

我想從這個數據集創建虛擬變量：

DF<-structure(list(A = c(1, 2, 3, 4, 5), B = c("1,3,2", "2,1,3,6", 
  "3,2,5,1,7", "3,7,4,2,6,5", "4,10,7,3,5,6")), .Names = c("A", "B"), 
              row.names = c(NA, 5L), class = "data.frame")
> DF
  A                  B
1 1              1,3,2
2 2            2,1,3,6
3 3          3,2,5,1,7
4 4        3,7,4,2,6,5
5 5       4,10,7,3,5,6

期望的輸出應該如下所示：

A  1  2  3  4  5  6  7  8  9  10
1  1  1  1  0  0  0  0  0  0  0
2  1  1  1  0  0  1  0  0  0  0
3  1  1  1  0  1  0  1  0  0  0
4  0  1  1  1  1  1  1  0  0  0
5  0  0  1  1  1  1  1  0  0  1

有沒有一種有效的方法來做這樣的事情？ 我可以使用strsplit或ifelse 。 原始數據集非常大，有許多行（> 10k），B列中的值（> 15k）。 來自包dummies功能dummy功能不能正常工作。

我還發現了simmilar案例：將一列拆分成多列 。 但是我的情況下上面鏈接的工作真的很慢（我的戴爾i7-2630QM，8Gb，Win7 64位，R 2.15.3 64位）最多15分鍾。

提前謝謝你的導師。

Answer 1

UPDATE

此處提到的功能現已轉移到CRAN上可用的名為“splitstackshape”的軟件包中。 CRAN上的版本比原始版本快得多。 速度應該與本答案末尾的直接for循環解決方案相似。 有關詳細基准，請參閱@ Ricardo的答案。

安裝它，並使用concat.split.expanded來獲得所需的結果：

library(splitstackshape)
concat.split.expanded(DF, "B", fill = 0, drop = TRUE)
#   A B_01 B_02 B_03 B_04 B_05 B_06 B_07 B_08 B_09 B_10
# 1 1    1    1    1    0    0    0    0    0    0    0
# 2 2    1    1    1    0    0    1    0    0    0    0
# 3 3    1    1    1    0    1    0    1    0    0    0
# 4 4    0    1    1    1    1    1    1    0    0    0
# 5 5    0    0    1    1    1    1    1    0    0    1

---

原帖

不久前，我寫過一個函數，不只是這種分裂，而是其他。 名為concat.split()的函數可以在這里找到。

對於您的示例數據，用法將是：

## Keeping the original column
concat.split(DF, "B", structure="expanded")
#   A            B B_1 B_2 B_3 B_4 B_5 B_6 B_7 B_8 B_9 B_10
# 1 1        1,3,2   1   1   1  NA  NA  NA  NA  NA  NA   NA
# 2 2      2,1,3,6   1   1   1  NA  NA   1  NA  NA  NA   NA
# 3 3    3,2,5,1,7   1   1   1  NA   1  NA   1  NA  NA   NA
# 4 4  3,7,4,2,6,5  NA   1   1   1   1   1   1  NA  NA   NA
# 5 5 4,10,7,3,5,6  NA  NA   1   1   1   1   1  NA  NA    1

## Dropping the original column
concat.split(DF, "B", structure="expanded", drop.col=TRUE)
#   A B_1 B_2 B_3 B_4 B_5 B_6 B_7 B_8 B_9 B_10
# 1 1   1   1   1  NA  NA  NA  NA  NA  NA   NA
# 2 2   1   1   1  NA  NA   1  NA  NA  NA   NA
# 3 3   1   1   1  NA   1  NA   1  NA  NA   NA
# 4 4  NA   1   1   1   1   1   1  NA  NA   NA
# 5 5  NA  NA   1   1   1   1   1  NA  NA    1

將NA重新編碼為0必須手動完成 - 也許我會更新函數以添加一個選項來執行此操作，同時，實現其中一個更快的解決方案:)

temp <- concat.split(DF, "B", structure="expanded", drop.col=TRUE)
temp[is.na(temp)] <- 0
temp
#   A B_1 B_2 B_3 B_4 B_5 B_6 B_7 B_8 B_9 B_10
# 1 1   1   1   1   0   0   0   0   0   0    0
# 2 2   1   1   1   0   0   1   0   0   0    0
# 3 3   1   1   1   0   1   0   1   0   0    0
# 4 4   0   1   1   1   1   1   1   0   0    0
# 5 5   0   0   1   1   1   1   1   0   0    1

---

更新

concat.split函數中的大部分開銷可能包括從matrix轉換為data.frame ，重命名列等等。 用於進行拆分的實際代碼是GASP for循環，但測試它，你會發現它執行得很好：

b = strsplit(DF$B, ",")
ncol = max(as.numeric(unlist(b)))
temp = lapply(b, as.numeric)
## Set up an empty matrix
m = matrix(0, nrow = nrow(DF), ncol = ncol)      
## Fill it in
for (i in 1:nrow(DF)) {
  m[i, temp[[i]]] = 1
}
## View your result
m 

Answer 2

更新：

在下面添加了基准
Update2：為@ Anada的解決方案添加了bechmarks。 哇它快！ 為更大的數據集增加了基准，@ Anada的解決方案以更大的利潤率提前加速。 “

---

原始答案：如下所示， KnownMax和UnknownMax的性能甚至超過了data.table解決方案。 雖然，我懷疑如果有10e6 +行，那么data.table解決方案將是最快的。 （可以通過簡單地修改本文最底部的參數來對其進行基准測試）

---

解決方案1： KnownMax

如果你知道B中的最大值，那么你有一個很好的雙線：

maximum <- 10
results <- t(sapply(strsplit(DF$B, ","), `%in%`, x=1:maximum)) + 0

#      [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10]
# [1,]    1    1    1    0    0    0    0    0    0     0
# [2,]    1    1    1    0    0    1    0    0    0     0
# [3,]    1    1    1    0    1    0    1    0    0     0
# [4,]    0    1    1    1    1    1    1    0    0     0
# [5,]    0    0    1    1    1    1    1    0    0     1

三行，如果要命名列和行：

dimnames(results) <- list(seq(nrow(results)), seq(ncol(results)))

---

解決方案2： UnknownMax

# if you do not know the maximum ahead of time: 
splat <- strsplit(DF$B, ",")
maximum <- max(as.numeric(unlist(splat)))
t(sapply(splat, `%in%`, x=1:maximum)) + 0

---

解決方案3： DT

根據@ dickoa的請求，這里有一個data.table選項。 “

DT <- data.table(DF)

DT.long <- DT[,  list(vals=as.numeric(unlist(strsplit(B, ",")))), by=A]

cols <- DT.long[, max(vals)]
rows <- DT.long[, max(A)] 

matrix(as.numeric(DT.long[, (1:cols) %in% vals, by=A]$V1), ncol=cols,
       byrow=TRUE, dimnames=list(seq(rows), seq(cols)))

#   1 2 3 4 5 6 7 8 9 10
# 1 1 1 1 0 0 0 0 0 0  0
# 2 1 1 1 0 0 1 0 0 0  0
# 3 1 1 1 0 1 0 1 0 0  0
# 4 0 1 1 1 1 1 1 0 0  0
# 5 0 0 1 1 1 1 1 0 0  1

類似的設置也可以在基礎R完成

===

---

以下是一些數據略大的基准測試：

microbenchmark(KnownMax = eval(KnownMax), UnknownMax = eval(UnknownMax),
    DT.withAssign = eval(DT.withAssign),
    DT.withOutAssign = eval(DT.withOutAssign),
    lapply.Dickoa = eval(lapply.Dickoa), apply.SimonO101 = eval(apply.SimonO101),
    forLoop.Ananda = eval(forLoop.Ananda), times=50L)

使用OP data.frame，結果為5 x 10

  Unit: microseconds
             expr      min       lq    median       uq       max neval
         KnownMax  106.556  114.692  122.4915  129.406  6427.521    50
       UnknownMax  114.470  122.561  128.9780  136.384   158.346    50
    DT.withAssign 3000.777 3099.729 3198.8175 3291.284 10415.315    50
 DT.withOutAssign 2637.023 2739.930 2814.0585 2903.904  9376.747    50
    lapply.Dickoa 7031.791 7315.781 7438.6835 7634.647 14314.687    50
  apply.SimonO101  430.350  465.074  487.9505  522.938  7568.442    50
   forLoop.Ananda   81.415   91.027   99.7530  104.588   265.394    50

使用稍微大一點的data.frame（下面），其中結果是1000 x 100， 刪除lapply.Dickoa作為我的編輯可能已經減慢了它，因為它站起來崩潰了。

   Unit: milliseconds
             expr      min       lq   median        uq       max neval
         KnownMax 34.83210 35.59068 36.13330  38.15960  52.27746    50
       UnknownMax 36.41766 37.17553 38.03075  47.71438  55.57009    50
    DT.withAssign 31.95005 32.65798 33.73578  43.71493  50.05831    50
 DT.withOutAssign 31.36063 32.08138 32.80728  35.32660  51.00037    50
  apply.SimonO101 78.61677 91.72505 95.53592 103.36052 163.14346    50
   forLoop.Ananda 13.61827 14.02197 14.18899  14.58777  26.42266    50

甚至更大的設置，其結果是10,000 x 600

Unit: milliseconds
             expr       min        lq    median        uq       max neval
         KnownMax 1583.5902 1631.6214 1658.6168 1724.9557 1902.3923    50
       UnknownMax 1597.1215 1655.9634 1690.7550 1735.5913 1804.2156    50
    DT.withAssign  586.4675  641.7206  660.7330  716.0100 1193.4806    50
 DT.withOutAssign  587.0492  628.3731  666.3148  717.5575  776.2671    50
  apply.SimonO101 1916.6589 1995.2851 2044.9553 2079.6754 2385.1028    50
   forLoop.Ananda  163.4549  172.5627  182.6207  211.9153  315.0706    50

使用以下內容：

library(microbmenchmark)
library(data.table)

KnownMax <- quote(t(sapply(strsplit(DF$B, ","), `%in%`, x=1:maximum)) + 0)
UnknownMax <- quote({    splat <- strsplit(DF$B, ","); maximum <- max(as.numeric(unlist(splat))); t(sapply(splat, `%in%`, x=1:maximum)) + 0})
DT.withAssign <- quote({DT <- data.table(DF); DT.long <- DT[,  list(vals=as.numeric(unlist(strsplit(B, ",")))), by=A]; cols <- DT.long[, max(vals)]; rows <- DT.long[, max(A)] ; matrix(as.numeric(DT.long[, (1:cols) %in% vals, by=A]$V1), ncol=cols, byrow=TRUE, dimnames=list(seq(rows), seq(cols)))})
DT.withOutAssign <- quote({DT.long <- DT[,  list(vals=as.numeric(unlist(strsplit(B, ",")))), by=A]; cols <- DT.long[, max(vals)]; rows <- DT.long[, max(A)] ; matrix(as.numeric(DT.long[, (1:cols) %in% vals, by=A]$V1), ncol=cols, byrow=TRUE, dimnames=list(seq(rows), seq(cols)))})
lapply.Dickoa <- quote({ tmp <- strsplit(DF$B, ","); label <- 1:max(as.numeric(unlist(tmp))); tmp <- lapply(tmp, function(x) as.data.frame(lapply(label, function(y) (x == y)))); unname(t(sapply(tmp, colSums))) })
apply.SimonO101 <- quote({cols <- 1:max( as.numeric( unlist(strsplit(DF$B,","))));  t(apply(DF["B"] , 1 , function(x) ifelse( cols %in% as.numeric( unlist( strsplit(x , ",") ) ) , 1 , 0 ) ) ) })
forLoop.Ananda <- quote({b = strsplit(DF$B, ","); ncol = max(as.numeric(unlist(b))); temp = lapply(b, as.numeric); m = matrix(0, nrow = nrow(DF), ncol = ncol)      ; for (i in 1:nrow(DF)) {  m[i, temp[[i]]] = 1 }; m })

# slightly modified @Dickoa's alogrithm to allow for instances were B is only a single number.  
#  Instead of using `sapply(.)`, I used `as.data.frame(lapply(.))` which hopefully the simplification process in sapply is analogous in time to `as.data.frame`

identical(eval(lapply.Dickoa), eval(UnknownMax))
identical(eval(lapply.Dickoa), unname(eval(apply.SimonO101)))
identical(eval(lapply.Dickoa), eval(KnownMax))
identical(unname(as.matrix(eval(DT.withAssign))), eval(KnownMax))
# ALL TRUE

這是用於創建示例數據的內容：

# larger data created as follows
set.seed(1)
maximum <- 600
rows <- 10000
DF <- data.frame(A=seq(rows), B=as.character(c(maximum, replicate(rows-1, paste(sample(maximum, sample(20), FALSE), collapse=",")))), stringsAsFactors=FALSE)
DT <- data.table(DF); 
DT

Answer 3

你可以用一種方法ifelse和strsplit （除非我誤解，你不想使用它們？）是這樣的....

cols <- 1:max( as.numeric( unlist(strsplit(DF$B,","))))
df <- t(apply(DF["B"] , 1 , function(x) ifelse( cols %in% as.numeric( unlist( strsplit(x , ",") ) ) , 1 , 0 ) ) )

colnames(df) <- cols
df
#  1 2 3 4 5 6 7 8 9 10
#1 1 1 1 0 0 0 0 0 0  0
#2 1 1 1 0 0 1 0 0 0  0
#3 1 1 1 0 1 0 1 0 0  0
#4 0 1 1 1 1 1 1 0 0  0
#5 0 0 1 1 1 1 1 0 0  1

我們的想法是，我們在您想要的列中獲取唯一值的向量，找到max並創建向量1:max(value)然后應用於每一行以找出該行的哪些值在所有向量中值。 我們使用ifelse將1 ifelse 1，如果不存在則ifelse 0。 我們匹配的vector是一個序列，因此它的輸出已准備好排序。

Answer 4

游戲稍晚，但不同的策略使用矩陣可以由另一個兩列矩陣索引的事實，該矩陣指定用於更新的行和列索引。 所以

f2 <- function(DF) {
    b <- strsplit(DF$B, ",", fixed=TRUE)
    len <- vapply(b, length, integer(1)) # 'geometry'
    b <- as.integer(unlist(b))

    midx <- matrix(c(rep(seq_len(nrow(DF)), len), b), ncol=2)
    m <- matrix(0L, nrow(DF), max(b))
    m[midx] <- 1L
    m
}

這使用strsplit(..., fixed=TRUE)和vapply來提高效率和類型安全性， as.integer和0L ， 1L因為我們真的想要整數而不是數字返回值。

為了比較，這是@AnandaMahto的原始實現

f0 <- function(DF) {
    b = strsplit(DF$B, ",")
    ncol = max(as.numeric(unlist(b)))
    temp = lapply(b, as.numeric)
    m = matrix(0, nrow = nrow(DF), ncol = ncol)
    for (i in 1:nrow(DF)) {
        m[i, temp[[i]]] = 1
    }
    m
}

這可以通過使用fixed=TRUE並避免b的雙重強制來提高效率，並通過強制轉換為整數並使用seq_len(nrow(DF))來避免0行DF的seq_len(nrow(DF))更加穩健

f1 <- function(DF) {
    b = lapply(strsplit(DF$B, ",", fixed=TRUE), as.integer)
    ncol = max(unlist(b))
    m = matrix(0L, nrow = nrow(DF), ncol = ncol)      
    for (i in seq_len(nrow(DF)))
        m[i, b[[i]]] = 1L
    m
}

for循環是編譯的好選擇，所以

library(compiler)
f1c <- cmpfun(f1)

然后對來自@RicardoSaporta的10,000 x 600數據進行比較

> library(microbenchmark)
> microbenchmark(f0(DF), f1(DF), f1c(DF), f2(DF))
Unit: milliseconds
    expr       min        lq    median        uq      max neval
  f0(DF) 170.51388 180.25997 182.45772 188.23811 717.7511   100
  f1(DF)  91.53578  97.14909  97.97195 100.24236 447.5900   100
 f1c(DF)  79.39194  84.45712  85.71022  87.85763 411.8340   100
  f2(DF)  76.45496  81.70307  82.50752 110.83620 398.6093   100

從f0到f1的2倍增加和for循環的相對效率對我來說都相對令人驚訝。 @ AnandaMahto的解決方案是更高效的內存，在沒有太多性能成本的情況下做得更好

ncol = max(vapply(b, max, integer(1)))

Answer 5

我知道已經有一個很好且非常有效的答案，但我們也可以使用另一種方法來獲得相同的結果。

tmp <- strsplit(DF$B, ",")
label <- 1:max(as.numeric(unlist(tmp)))
tmp <- lapply(tmp, function(x)
              sapply(label, function(y) (x == y)))

t(sapply(tmp, colSums))

##      [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10]
## [1,]    1    1    1    0    0    0    0    0    0     0
## [2,]    1    1    1    0    0    1    0    0    0     0
## [3,]    1    1    1    0    1    0    1    0    0     0
## [4,]    0    1    1    1    1    1    1    0    0     0
## [5,]    0    0    1    1    1    1    1    0    0     1

我們現在可以將它與@ SimonO101解決方案（fun2）進行比較

require(rbenchmark)

fun1 <- function(DF) {
    tmp <- strsplit(DF$B, ",")
    label <- 1:max(as.numeric(unlist(tmp)))
    tmp <- lapply(tmp, function(x)
                  sapply(label, function(y) (x == y)))
    t(sapply(tmp, colSums))

}


fun2 <- function(DF) {
    cols <- 1:max( as.numeric( unlist(strsplit(DF$B,","))))
    df <- t(apply(DF["B"] , 1 , function(x) ifelse( cols %in% as.numeric( unlist( strsplit(x , ",") ) ) , 1 , 0 ) ) )

    colnames(df) <- cols
    df
}


all.equal(fun1(DF),
          fun2(DF),
          check.attributes = FALSE)

## [1] TRUE


benchmark(fun1(DF),
          fun2(DF),
          order = "elapsed",
          columns = c("test", "elapsed", "relative"),
          replications = 5000)


##       test elapsed relative
## 1 fun1(DF)   1.870    1.000
## 2 fun2(DF)   2.018    1.079

我們可以看到，沒有太大的區別。

---

建議編輯（RS）：

# from: 
tmp <- lapply(tmp, function(x)
           sapply(label, function(y) (x == y)))

#  to: 
tmp <- lapply(tmp, function(x)
          as.data.frame(lapply(label, function(y) (x == y))))

Answer 6

好吧，這已經困擾了我一段時間，但我認為這將是一個很好的使用Rcpp 。 所以我寫了一個小函數，看看我是否能比@Ananda的驚人for循環解決方案更快地得到一些東西。 該解決方案似乎運行速度大約快兩倍（使用@RicardoSaporta發布的更大的樣本數據集）。

注意：我試圖更多地教自己如何使用Rcpp和C ++而不是提供有用的解決方案，但都是一樣的...

我們的.cpp文件......

#include <Rcpp.h>
#include <string>
#include <sstream>

using namespace Rcpp;

//[[Rcpp::export]]

NumericMatrix expandR(CharacterVector x) {
    int n = x.size();
    std::vector< std::vector<int> > out;    // list to hold numeric vectors
    int tmax = 0;
    for(int i = 0; i < n; ++i) {
      std::vector<int> vect;                // vector to hold split strings
      std::string str = as<std::string>(x[i]);
      std::stringstream ss(str);
      int j = 0;
      while (ss >> j) {
      vect.push_back(j);  // add integer to result vector
        if (ss.peek() == ',') //split by ',' delim
          ss.ignore();
      }
     int it = *std::max_element(vect.begin(), vect.end());
      if( it > tmax )
        tmax = it;  //current max value
      out.push_back(vect);
    }
// Now we construct the matrix. tmax gives us number of columns, n is number of rows;
    NumericMatrix mat(n,tmax);
    for( int i = 0; i < n; ++i) {
      NumericMatrix::Row zzrow = mat( i , _ );
      std::vector<int> vec = out[i];
      for( int j = 0; j < vec.size(); ++j ) {
        zzrow[ (vec[j]-1) ] = 1; //don't forget R vs. C++ indexing
        }
    }
    return mat;
}

使用OP中的標稱示例，我們可以做...

require(Rcpp)

##  source the function so it is available to use in R
sourceCpp("C:/path/to/file.cpp")

#  Call it like any other R function
expandR(DF$B)
     [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10]
[1,]    1    1    1    0    0    0    0    0    0     0
[2,]    1    1    1    0    0    1    0    0    0     0
[3,]    1    1    1    0    1    0    1    0    0     0
[4,]    0    1    1    1    1    1    1    0    0     0
[5,]    0    0    1    1    1    1    1    0    0     1

並使用@Ricardo提供的更大的數據集）並與@ Ananda的解決方案進行比較）....

require(Rcpp)
require(data.table)
set.seed(1)
maximum <- 600
rows <- 10000
DF <- data.frame(A=seq(rows), B=as.character(c(maximum, replicate(rows-1, paste(sample(maximum, sample(20), FALSE), collapse=",")))), stringsAsFactors=FALSE)
DT <- data.table(DF); 
DT

##  source in our c code
sourceCpp("C:/Users/sohanlon/Desktop/expandR2.cpp")

forLoop.Ananda  <- quote({b = strsplit(DF$B, ","); ncol = max(as.numeric(unlist(b))); temp = lapply(b, as.numeric); m = matrix(0, nrow = nrow(DF), ncol = ncol)      ; for (i in 1:nrow(DF)) {  m[i, temp[[i]]] = 1 }; m })
rcpp.Simon      <- quote({mm = expandR( DT$B )})

require(microbenchmark)
microbenchmark( eval(forLoop.Ananda) , eval(rcpp.Simon) , times = 5L )
Unit: milliseconds
                 expr      min       lq   median       uq      max neval
 eval(forLoop.Ananda) 173.3024 178.6445 181.5881 218.9619 227.9490     5
     eval(rcpp.Simon) 115.8309 116.3876 116.8125 119.1971 125.6504     5

Answer 7

然而，這不是一個特別快速的解決方案，它可能對那些喜歡tidyverse可能性的人有用：

DF %>%
 mutate(B = str_split(B, fixed(","))) %>%
 unnest() %>%
 transmute(A,
           var = as.numeric(B),
           val = 1) %>%
 complete(var = seq(min(var), max(var), 1), nesting(A)) %>%
 spread(var, val, fill = 0)

      A   `1`   `2`   `3`   `4`   `5`   `6`   `7`   `8`   `9`  `10`
  <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
1     1     1     1     1     0     0     0     0     0     0     0
2     2     1     1     1     0     0     1     0     0     0     0
3     3     1     1     1     0     1     0     1     0     0     0
4     4     0     1     1     1     1     1     1     0     0     0
5     5     0     0     1     1     1     1     1     0     0     1

要擁有更緊湊的列名稱：

DF %>%
 mutate(B = str_split(B, fixed(","))) %>%
 unnest() %>%
 transmute(A,
           var = as.numeric(B),
           val = 1) %>%
 complete(var = seq(min(var), max(var), 1), nesting(A)) %>%
 spread(var, val, fill = 0) %>%
 rename_at(2:length(.), ~ paste0("Col", 1:length(.)))

      A  Col1  Col2  Col3  Col4  Col5  Col6  Col7  Col8  Col9 Col10
  <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
1     1     1     1     1     0     0     0     0     0     0     0
2     2     1     1     1     0     0     1     0     0     0     0
3     3     1     1     1     0     1     0     1     0     0     0
4     4     0     1     1     1     1     1     1     0     0     0
5     5     0     0     1     1     1     1     1     0     0     1