Манекены переменных из строковой переменной

ОБНОВИТЬ

Функция, упомянутая здесь, теперь перенесена в пакет, ansible в CRAN под названием «splitstackshape». Версия на CRAN значительно быстрее, чем эта оригинальная версия. Скорости должны быть похожи на то, что вы получите с помощью прямого решения for цикла в конце этого ответа. См. Ответ @ Рикардо для подробных тестов.

Установите его и используйте 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") # AB 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 

Обновить:

Добавлены контрольные показатели ниже
Update2: добавлены bechmarks для решения @ Anada. WOW это быстро! Добавлены контрольные показатели для большего набора данных evern, а решение 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 

Используя немного больший объем данных (ниже), где результаты 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 

Еще больший набор, где результаты 10000 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 

Один из способов сделать это с помощью ifelse и strsplit (если я неправильно понял и вы не хотите их использовать?), 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, если он есть, и 0, если это не так. vector мы сопоставляем, представляет собой последовательность, поэтому ее выход готов к сортировке.

Немного поздно в игре, но в другой страtagsи используется тот факт, что matrix может быть проиндексирована другой матрицей с двумя столбцами, определяющей индексы строк и столбцов для обновления. Так

 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 и as.integer , 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

 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) 

а затем для сравнения по данным 10 000 x 600 от @RicardoSaporta

 > 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, так и относительная эффективность цикла for. @ Решение AnandaMahto более эффективно с точки зрения памяти, более того, без особых затрат на производительность

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

Я знаю, что уже есть хороший и довольно эффективный ответ, но мы можем использовать другой подход, чтобы получить те же результаты.

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

Хорошо, это некоторое время подтачивало меня, но я думал, что это будет хорошим использованием Rcpp . Поэтому я написал небольшую функцию, чтобы узнать, могу ли я получить что-то быстрее, чем @ удивительное решение for цикла. Кажется, что это решение работает примерно в два раза быстрее (используя больший dataset образца, отправленный @RicardoSaporta).

Примечание. Я пытался больше узнать, как использовать Rcpp и C ++, чем предоставить полезное решение, но все равно …

Наш .cpp файл …

 #include  #include  #include  using namespace Rcpp; //[[Rcpp::export]] NumericMatrix expandR(CharacterVector x) { int n = x.size(); std::vector< std::vector > out; // list to hold numeric vectors int tmax = 0; for(int i = 0; i < n; ++i) { std::vector vect; // vector to hold split strings std::string str = as(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 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 

И используя больший dataset, предоставляемый @Ricardo) и сравнивая с решением @ Ананды) ....

 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