Related
I created this data frame:
Count <- c(1:10)
Give <- c(0,0,5,0,0,5,0,5,0,5)
X <- c(rep(0,10))
Y <- c(rep(0,10))
Z <- c(rep(0,10))
X_Target <- 5
Y_Target <- 10
Z_Target <- 5
Basically I have 3 vectors (X,Y,Z) and a target for each one of them.
I want to have a new calculation for X,Y and Z that based on the vector Give.
Once the number on Give is bigger than 0 then it's need to be added to Vector X until it equel to X_Target. Then - the calcultion need to move to the next vector (Y) and do the same, and then to next vector...
The output should be like the following:
Count Give X Y Z
1 0 0 0 0
2 0 0 0 0
3 5 5 0 0
4 0 5 0 0
5 0 5 0 0
6 5 5 5 0
7 0 5 5 0
8 5 5 10 0
9 0 5 10 0
10 5 5 10 5
In this example I have only 3 vectors but please keep in mind that I'll have at least 60 vectors so I need it to be automatic as it can.
Hope I manage to explain myself :)
Thnanks!
It's ugly, but it gives the desired result.
tab1 = data.frame(
Count = c(1:10),
Give = c(0,0,5,0,0,5,0,5,0,5),
X = c(rep(0,10)),
Y = c(rep(0,10)),
Z = c(rep(0,10))
)
targets <- c(5,10,5)
tab2 <- tab1
start <- 2
for(col in 3:ncol(tab2)) {
target <- targets[col-2]
for(row in start:nrow(tab2)) {
if(tab2[row, 2] > 0 & tab2[row, col] < target) {
tab2[row, col] <- pmin(tab2[row - 1, col] + tab2[row, col - 1], target)
} else {
tab2[row, col] <- tab2[row - 1, col]
}
}
start <- which(tab2[, 2] > 0 & tab2[, col] == target)[2]
}
> tab2
Count Give X Y Z
1 1 0 0 0 0
2 2 0 0 0 0
3 3 5 5 0 0
4 4 0 5 0 0
5 5 0 5 0 0
6 6 5 5 5 0
7 7 0 5 5 0
8 8 5 5 10 0
9 9 0 5 10 0
10 10 5 5 10 5
Turn it into a data frame :
tab1 = data.frame(
Count = c(1:10),
Give =c(0,0,5,0,0,5,0,5,0,5),
X = c(rep(0,10)),
Y = c(rep(0,10)),
Z = c(rep(0,10))
)
# create a list of targets for looping
targets = c(X_Target, Y_Target, Z_Target)
Without using data.table you can just put the whole thing in a loop. It will work, but be much slower.
# loop through each column
for(col in seq(1,length(targets))){
print(col)
# loop through each row
for(row in seq(1, dim(tab1[2+col])[1])){
# condition
while(tab1[row,(2+col)] < targets[col] & tab1[row,2]>0){
tab1[row,(2+col)] = tab1[row,(2+col)] +tab1[row,2]
}
}
}
Here is something else to try, using tidyverse.
Put your data into long form, and include targets with a join.
In a loop through Count, find the first row for a given Count that is below target. For current and following rows that have matching names (X, Y, or Z), add Give amount.
In the end, put result back into wide form.
library(tidyverse)
df <- data.frame(Count, Give, X, Y, Z) %>%
pivot_longer(cols = X:Z) %>%
left_join(data.frame(X_Target, Y_Target, Z_Target) %>%
pivot_longer(cols = everything(),
names_to = c("name", ".value"),
names_pattern = "(\\w+)_(\\w+)"))
for (i in seq_along(Count)) {
below_target <- min(which(df$Count == i & df$value < df$Target))
name_rows <- which(df$name == df[below_target, "name", drop = T])
rows_to_change <- name_rows[name_rows >= below_target]
df[rows_to_change, "value"] <- df[rows_to_change, "value"] + df[below_target, "Give", drop = T]
}
df %>%
pivot_wider(id_cols = Count)
Output
Count X Y Z
<int> <dbl> <dbl> <dbl>
1 1 0 0 0
2 2 0 0 0
3 3 5 0 0
4 4 5 0 0
5 5 5 0 0
6 6 5 5 0
7 7 5 5 0
8 8 5 10 0
9 9 5 10 0
10 10 5 10 5
My approach was to make use of the cumulative sums of the Give and then track if that exceeds the targeted values for the columns. Then do some cleaning up.
targets <- c(X_Target, Y_Target, Z_Target)
targets_0 <- c(0, targets)
csum_give <- cumsum(Give)
# from cumsum give take off sum of previous targets
result <- sapply(1:length(targets),
function(x) csum_give - sum(targets_0[1:x]))
# Set max value to target max of column
sapply(1:length(targets),
function(x) result[result[, x] > targets[x], x] <<- targets[x])
# set min value to zero
result[which(result < 0)] <- 0
result
# [,1] [,2] [,3]
# [1,] 0 0 0
# [2,] 0 0 0
# [3,] 5 0 0
# [4,] 5 0 0
# [5,] 5 0 0
# [6,] 5 5 0
# [7,] 5 5 0
# [8,] 5 10 0
# [9,] 5 10 0
# [10,] 5 10 5
Say I have this vector:
a <- round(runif(100, 0, 1), digits = 0)
I want to find the first element in the vector that contains the number 1. After that element is found, skip 3 elements (even if they include 1s), then find the next element that contains 1 and repeat finding 1s and skipping 3 elements after finding 1s.
My desired output is the row numbers for the first element that contains 1, followed by the rest of the row numbers that contain 1, after accounting for the skipped elements.
I don't think you can do this without resorting to some kind of loop. Here's one way to do it. 1st we get a vector of positions of all the ones. Then we repeatedly find the first element of this vector that is 3 or less from the previous and remove it from the list. Repeat until you've removed all the ones that are too close to their predessesor.
x = which(a==1)
repeat {
to.remove = which(diff(x) <= 3)[1] + 1
if (is.na(to.remove)) break
x = x[-to.remove]
}
If you are dealing with very large vectors, there may be more efficient ways to do this, and perhaps consider RCpp if speed is an issue.
You could use Reduce with accumulate = TRUE or purrr::accumulate, though you'll need to iterate over a list with separate elements for the result and the skip count, e.g.
library(tidyverse)
set.seed(47)
df_ones <- data_frame(a = rbinom(100, 1, .5), # make sample data
is_one = a, # initialize result and count
count = NA) %>%
split(seq(nrow(.))) %>% # split into list of one-row data frames
accumulate( # for each sequential pair of elements, return and pass on a list of...
~list(a = .y$a, # the original value for checking,
is_one = if(.x$count <= 3) 0 else .y$is_one, # the result, changing 1 to 0 where required, and
# the count since a 1, resetting when a 1 is kept
count = if(.x$count > 3 & .y$is_one) {
1
} else {
.x$count + 1
}),
.init = list(a = NA, is_one = 0, count = 4) # set initial .x value
) %>%
bind_rows() %>% # collapse resulting list to data frame
slice(-1) # remove row for initializing value
df_ones
#> # A tibble: 100 x 3
#> a is_one count
#> <int> <dbl> <dbl>
#> 1 1 1 1
#> 2 0 0 2
#> 3 1 0 3
#> 4 1 0 4
#> 5 1 1 1
#> 6 1 0 2
#> 7 0 0 3
#> 8 0 0 4
#> 9 1 1 1
#> 10 1 0 2
#> # ... with 90 more rows
To extract the indices,
df_ones %>%
pull(is_one) %>% # extract result as vector
as.logical() %>% # coerce to Boolean
which() # get indices of TRUE values
#> [1] 1 5 9 14 22 29 35 40 44 48 52 56 61 66 71 75 79 84 88 93 97
Perhaps a while loop?
set.seed(123)
a <- round(runif(100,0,1), digits =0)
n <- length(a)
ind_less_n <- 1
i <- 1
index_save <- numeric(n)
while(ind_less_n){
if(a[i] == 1){
index_save[i] <- 1
i <- i + 4
} else {
i <- i + 1
}
if(i > n) ind_less_n <- 0
}
head(cbind(a, index_save), 20)
a index_save
[1,] 0 0
[2,] 1 1
[3,] 0 0
[4,] 1 0
[5,] 1 0
[6,] 0 0
[7,] 1 1
[8,] 1 0
[9,] 1 0
[10,] 0 0
[11,] 1 1
[12,] 0 0
[13,] 1 0
[14,] 1 0
[15,] 0 0
[16,] 1 1
[17,] 0 0
[18,] 0 0
[19,] 0 0
[20,] 1 1
You can extract the row numbers with which(index_save == 1)
I'm trying to find a way to create a matrix which counts values from each row of a data frame. I'd like it to recognise the values in each row of the data frame, and count how many times that value has occurred in all rows above the row the value occurs in (not the whole data frame).
The same value will never occur more than once in a single row of the data frame.
For example:
# df:
a b c
1 2 3
3 4 5
3 2 6
7 8 9
8 3 6
matrix result:
0 0 0 (none of the df values have occurred as there are no rows above)
1 0 0 (3 has occurred once above, the others have not occurred)
2 1 0 (3 has occurred twice above, 2 has occurred once above, 6 has not occurred)
0 0 0 (none of the df values have occurred in rows above)
1 3 1 (8 has occurred once, 3 has occurred 3 times, 6 has occurred once)
Here's one way:
# convert to a vector
x = as.vector(t(as.matrix(df)))
# get counts of each unique element (in the right place)
# and add them up
res = rowSums(sapply(unique(x), function(z) {
r = integer(length(x))
r[x == z] = 0:(sum(x == z) - 1)
return(r)
}))
# convert to matrix
res = matrix(res, ncol = ncol(df), byrow = T)
res
# [,1] [,2] [,3]
# [1,] 0 0 0
# [2,] 1 0 0
# [3,] 2 1 0
# [4,] 0 0 0
# [5,] 1 3 1
Using this data:
df = read.table(text = "
a b c
1 2 3
3 4 5
3 2 6
7 8 9
8 3 6", header = T)
Another...for fun
out<-matrix(1,nrow = nrow(df),ncol = ncol(df))
for(i in 1:nrow(df)){
out[i,]<-sapply(1:ncol(df),function(z) sum(unlist(df[0:(i-1),]) %in% df[i,z]))
}
out
[,1] [,2] [,3]
[1,] 0 0 0
[2,] 1 0 0
[3,] 2 1 0
[4,] 0 0 0
[5,] 1 3 1
Three other approaches:
1) with base R:
temp <- stack(df)[c(outer(c(0,5,10), 1:5, '+')),]
temp$val2 <- with(temp, ave(values, values, FUN = seq_along)) - 1
df2 <- unstack(temp, val2 ~ ind)
which gives:
> df2
a b c
1 0 0 0
2 1 0 0
3 2 1 0
4 0 0 0
5 1 3 1
2) with data.table:
library(data.table)
melt(setDT(df)[, r := .I],
id = 'r')[order(r), val2 := rowid(value) - 1
][, dcast(.SD, rowid(variable) ~ variable, value.var = 'val2')
][, variable := NULL][]
which gives the same result.
3) with the tidyverse:
library(dplyr)
library(tidyr)
df %>%
mutate(r = row_number()) %>%
gather(k, v, -4) %>%
arrange(r) %>%
group_by(v) %>%
mutate(v2 = row_number() - 1) %>%
ungroup() %>%
select(r, k, v2) %>%
spread(k, v2)
which, off course, also gives the same result.
Here is another solution:
df = read.table(text = "a b c
1 2 3
3 4 5
3 2 6
7 8 9
8 3 6", header = T)
elements = sort(unique(unlist(df)))
frequency = sapply(elements, # for each element
function(element) {apply(df == element, 1, sum)}) # Sum the number of occurances per row
# [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9]
# [1,] 1 1 1 0 0 0 0 0 0
# [2,] 0 0 1 1 1 0 0 0 0
# [3,] 0 1 1 0 0 1 0 0 0
# [4,] 0 0 0 0 0 0 1 1 1
# [5,] 0 0 1 0 0 1 0 1 0
results = df
for(i in 1:nrow(df)){
for(j in 1:ncol(df))
results[i,j] = sum(frequency[1:i-1, # Sum the prevoius rows occurances
which(df[i,j] == elements)]) # Of the same element
}
# a b c
# 1 0 0 0
# 2 1 0 0
# 3 2 1 0
# 4 0 0 0
# 5 1 3 1
I know we're not supposed to comment with "thanks", but thank you to all. I've marked Brian's response as the most useful because I'm pretty new to R and his was the example I could follow all the way through without needing to look anything up. I'll have fun finding out about all the other ways and new (to me) functions / approaches you've kindly shared though.
I have a set of data on which respondents were given a series of questions, each with five response options (e.g., 1:5). Given those five options, I have a scoring key for each question, where some responses are worth full points (e.g., 2), others half points (1), and others no points (0). So, the data frame is n (people) x k (questions), and the scoring key is a k (questions) x m (responses) matrix.
What I am trying to do is to programmatically create a new dataset of the rescored items. Trivial dataset:
x <- sample(c(1:5), 50, replace = TRUE)
y <- sample(c(1:5), 50, replace = TRUE)
z <- sample(c(1:5), 50, replace = TRUE)
dat <- data.frame(cbind(x,y,z)) # 3 items, 50 observations (5 options per item)
head(dat)
x y z
1 3 1 2
2 2 1 3
3 5 3 4
4 1 4 5
5 1 3 4
6 4 5 4
# Each option is scored 0, 1, or 2:
key <- matrix(sample(c(0,0,1,1,2), size = 15, replace = TRUE), ncol=5)
key
[,1] [,2] [,3] [,4] [,5]
[1,] 0 0 0 1 2
[2,] 2 1 1 1 2
[3,] 2 2 1 1 2
Some other options, firstly using Map:
data.frame(Map( function(x,y) key[y,x], dat, seq_along(dat) ))
# x y z
#1 0 2 2
#2 0 2 1
#3 2 1 1
#4 0 1 2
#5 0 1 1
#6 1 2 1
Secondly using matrix indexing on key:
newdat <- dat
newdat[] <- key[cbind( as.vector(col(dat)), unlist(dat) )]
newdat
# x y z
#1 0 2 2
#2 0 2 1
#3 2 1 1
#4 0 1 2
#5 0 1 1
#6 1 2 1
Things would be even simpler if you specified key as a list:
key <- list(x=c(0,0,0,1,2),y=c(2,1,1,1,2),z=c(2,2,1,1,2))
data.frame(Map("[",key,dat))
# x y z
#1 0 2 2
#2 0 2 1
#3 2 1 1
#4 0 1 2
#5 0 1 1
#6 1 2 1
For posterity, I was discussing this issue with a friend, who suggested another approach. The benefits of this is that it still uses mapvalues() to do the rescoring, but does not require a for loop, instead uses "from" in sapply to do the indexing.
library(plyr)
scored <- sapply(1:ncol(raw), function(x, dat, key){
mapvalues(dat[,x], from = 1:ncol(key), to = key[x,])
}, dat = dat, key = key)
My current working approach is to use 1) mapvalues, which lives within package:plyr to do the heavy lifting: it takes a vector of data to modify, and two additional parameters "from", which is the original data (here 1:5), and "to", or what we want to convert the data to; and, 2) A for loop with index notation, in which we cycle through the available questions, extract the vector pertaining to each using the current loop value, and use it to select the proper row from our scoring key.
library(plyr)
newdat <- matrix(data=NA, nrow=nrow(dat), ncol=ncol(dat))
for (i in 1:3) {
newdat[,i] <- mapvalues(dat[,i], from = c(1,2,3,4,5),
to = c(key[i,1], key[i,2], key[i,3], key[i,4], key[i,5]))
}
head(newdat)
[,1] [,2] [,3]
[1,] 0 2 2
[2,] 0 2 1
[3,] 2 1 1
[4,] 0 1 2
[5,] 0 1 1
[6,] 1 2 1
I am pretty happy with this solution, but if anyone has any better approaches, I would love to see them!
I would like to create dummy variables form this dataset:
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
Desired output shoud look like this:
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
Is there a efficient way to do such thing? I can use strsplit or ifelse. Original dataset is very large with many rows (>10k) and values in column B (>15k). Function dummy from package dummies don't work as I want to.
I also found simmilar case: Splitting one column into multiple columns. But the anwsers from the link above work really slow in my case (up to 15 minutes on my Dell i7-2630QM, 8Gb, Win7 64 bit, R 2.15.3 64bit).
Thank you in advance for your anwsers.
UPDATE
The function mentioned here has now been moved to a package available on CRAN called "splitstackshape". The version on CRAN is considerably faster than this original version. The speeds should be similar to what you would get with the direct for loop solution at the end of this answer. See #Ricardo's answer for detailed benchmarks.
Install it, and use concat.split.expanded to get the desired result:
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
Original post
A while ago, I had written a function to do not just this sort of splitting, but others. The function, named concat.split(), can be found here.
The usage, for your example data, would be:
## 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
Recoding NA to 0 has to be done manually--perhaps I'll update the function to add an option to do so, and at the same time, implement one of these faster solutions :)
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
Update
Most of the overhead in the concat.split function probably comes in things like converting from a matrix to a data.frame, renaming the columns, and so on. The actual code used to do the splitting is a GASP for loop, but test it out, and you'll find that it performs pretty well:
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
Update:
Added benchmarks below
Update2: added bechmarks for #Anada's solution. WOW it's fast!!
Added benchmarks for an evern larger data set and #Anada's solution speeds ahead by a larger margin. '
Original Answer:
As you can see below, KnownMax and UnknownMax are outperforming even the data.table solution. Although, I suspect that if there were 10e6+ rows, then the data.table solution would be fastest. (feel free to benchmark it by simply modifying the parameters at the very bottom of this post)
Solution 1: KnownMax
If you know the maximum value in B, then you have a nice, two-liner:
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
Three lines, if you want to name the columns and rows:
dimnames(results) <- list(seq(nrow(results)), seq(ncol(results)))
Solution 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
Solution 3: DT
As per #dickoa's request, here is an option with 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
Similar setup can be done in base R as well
===
Here are some benchmarks with slightly larger data:
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)
Using the OP data.frame, where the result is 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
Using the slightly larger data.frame (below) where the results is 1000 x 100
removing lapply.Dickoa as my edit might have slowed it down and as it stood it crashed.
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
Even larger set where the results is 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
Using the following:
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
this is what was used to create the sample data:
# 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
One way you could do this with ifelse and strsplit (unless I misunderstood and you don't want to use them?) is like this....
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
The idea is that we get a vector of the unique values in your desired column, find the max value and create a vector 1:max(value) then apply across each row to find out which values for that row are in the vector of all values. We use ifelse to put a 1 if it's there and 0 if it's not. The vector we match in is a sequence so its output is ready sorted.
A little late to the game, but a different strategy uses the fact that a matrix can be indexed by another two-column matrix specifying row and and column indexes for update. So
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
}
This uses strsplit(..., fixed=TRUE) and vapply for efficiency and type safety, and as.integer and 0L, 1L because we really want integer and not numeric return values.
For comparison, here's the original implementation from #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
}
This can be improved for efficiency by using fixed=TRUE and avoiding the double coercion of b, and made more robust by coercing to integer and using seq_len(nrow(DF)) to avoid the corner case of 0-row 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
}
The for loop is a good candidate for compilation, so
library(compiler)
f1c <- cmpfun(f1)
and then for comparison on the 10,000 x 600 data from #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
Both the 2-fold increase from f0 to f1 and relative efficiency of the for loop were relatively surprising to me. #AnandaMahto's solution is more memory efficient, made more so without too much performance cost with
ncol = max(vapply(b, max, integer(1)))
I know there's already a good and quite efficient answer but we can use another approach too to get the same results.
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
We can benchmark it now to compare with #SimonO101 solution (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
As we can see there's not a big difference.
Suggested edit (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))))
Ok, this has been bugging me for a while, but I thought it would be a good use of Rcpp. So I wrote a little function too see if I can get something faster than #Ananda's amazing for loop solution. This solution seems to run approximately twice as fast (using the larger sample dataset posted by #RicardoSaporta).
Note: I was attempting this more to teach myself how to use Rcpp and C++ than to provide a useful solution, but all the same...
Our .cpp file...
#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;
}
Using the nominal example from the OP we can then just do...
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
And using the larger dataset provided by #Ricardo) and comparing with #Ananda's solution)....
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
Not a particularly fast solution, however, it could be useful for those preferring tidyverse possibilities:
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
To have more compact column names:
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