问题
I have a dataframe df:
userID Score Task_Alpha Task_Beta Task_Charlie Task_Delta
3108 -8.00 Easy Easy Easy Easy
3207 3.00 Hard Easy Match Match
3350 5.78 Hard Easy Hard Hard
3961 10.00 Easy NA Hard Hard
4021 10.00 Easy Easy NA Hard
1. userID is factor variable
2. Score is numeric
3. All the 'Task_' features are factor variables with possible values 'Hard', 'Easy', 'Match' or NA
I want to count the possible transitions between the Task_ features. For reference, the possible transitions are:
EE transition from Easy -> Easy
EM transition from Easy -> Match
EH transition from Easy -> Hard
ME transition from Match-> Easy
MM transition from Match-> Match
MH transition from Match-> Hard
HE transition from Hard -> Easy
HM transition from Hard -> Match
HH transition from Hard -> Hard
Since there are three possible values (excluding the NA case), the output columns would be as below:
userID EE EM EH MM ME MH HH HE HM
3108 3 0 0 0 0 0 0 0 0
3207 0 1 0 1 0 0 0 1 0
3350 0 0 1 0 0 0 1 1 0
3961 0 0 0 0 0 0 1 0 0
4021 1 0 0 0 0 0 0 0 0
1) In this example each userID can have at most 3 state transitions.
2) Note that for users 3961 and 4021, NA has reduced the possible state transitions.
Any advice on these questions would be greatly appreciated.
The data dput() is :
df <- structure(list(
userID = c(3108L, 3207L, 3350L, 3961L, 4021L),
Score = c(-8, 3, 5.78, 10, 10),
Task_Alpha = structure(c(1L, 2L, 2L, 1L, 1L), .Label = c("Easy", "Hard"), class = "factor"),
Task_Beta = structure(c(1L, 1L, 1L, NA, 1L), .Label = "Easy", class = "factor"),
Task_Charlie = structure(c(1L, 3L, 2L, 2L, NA), .Label = c("Easy", "Hard", "Match"), class = "factor"),
Task_Delta = structure(c(1L, 3L, 2L, 2L, 2L), .Label = c("Easy", "Hard", "Match"), class = "factor")),
class = "data.frame", row.names = c(NA, -5L))
回答1:
One option involving dplyr and tidyr you could be:
df %>%
select(-Score) %>%
pivot_longer(names_to = "variables", values_to = "values", -userID) %>%
select(-variables) %>%
group_by(userID) %>%
filter(!is.na(values) & !is.na(lag(values, default = first(values)))) %>%
mutate(variables = paste(values, lead(values), sep = "-")) %>%
filter(row_number() != n()) %>%
count(variables) %>%
ungroup() %>%
pivot_wider(names_from = "variables", values_from = "n", values_fill = list(n = 0))
userID `Easy-Easy` `Easy-Match` `Hard-Easy` `Match-Match` `Easy-Hard` `Hard-Hard`
<int> <int> <int> <int> <int> <int> <int>
1 3108 3 0 0 0 0 0
2 3207 0 1 1 1 0 0
3 3350 0 0 1 0 1 1
4 3961 0 0 0 0 1 0
5 4021 1 0 0 0 0 0
It, first, transforms the data from wide to long format. Second, it groups by userID, excludes the missing values and the lagged missing values. Third, it concatenates the current and the lead value. Forth, it counts the occurrences of given combinations per userID. Finally, it transforms the data to wide format.
And if you want also the non-present combinations:
x <- c("Easy", "Hard", "Match")
df %>%
select(-Score) %>%
pivot_longer(names_to = "variables", values_to = "values", -userID) %>%
select(-variables) %>%
group_by(userID) %>%
filter(!is.na(values) & !is.na(lag(values, default = first(values)))) %>%
mutate(variables = paste(values, lead(values), sep = "-")) %>%
filter(row_number() != n()) %>%
count(variables) %>%
complete(variables = c(outer(x, x, FUN = paste, sep = "-")), fill = list(n = 0)) %>%
ungroup() %>%
pivot_wider(names_from = "variables", values_from = "n")
回答2:
Another idea via base R can be to paste the values to their previous value (rowwise), convert to factor to get all 9 levels (using expand.grid with only the levels you want - which also takes care of NAs), and finally count the values via table. The last step is to bind the IDs with the results, i.e.
cbind.data.frame(df$userID, t(apply(df[-c(1:2)], 1, function(i) {
i1 <- paste(i[-length(i)], i[-1]);
i1 <- factor(i1, levels = do.call(paste, expand.grid(c('Easy', 'Match', 'Hard'),
c('Easy', 'Match', 'Hard'))));
table(i1) })))
which gives,
df$userID Easy Easy Match Easy Hard Easy Easy Match Match Match Hard Match Easy Hard Match Hard Hard Hard 1 3108 3 0 0 0 0 0 0 0 0 2 3207 0 0 1 1 1 0 0 0 0 3 3350 0 0 1 0 0 0 1 0 1 4 3961 0 0 0 0 0 0 0 0 1 5 4021 1 0 0 0 0 0 0 0 0
回答3:
Another option similar to Sotos' approach but 1) using data.table, 2) not using factor and 3) replacing table with Rfast::rowTabulate:
v <- c('Hard', 'Match', 'Easy')
vv <- do.call(paste, expand.grid(v, v))
DT[, (vv) := {
mat <- mapply(paste, .SD[, -ncol(.SD), with=FALSE], .SD[, -1L])
as.data.table(Rfast::rowTabulate(matrix(match(mat, vv, 0L), nrow=.N)))
}, .SDcols=Task_Alpha:Task_Delta]
output:
userID Score Task_Alpha Task_Beta Task_Charlie Task_Delta Hard Hard Match Hard Easy Hard Hard Match Match Match Easy Match Hard Easy Match Easy Easy Easy
1: 3108 -8.00 Easy Easy Easy Easy 0 0 0 0 0 0 0 0 3
2: 3207 3.00 Hard Easy Match Match 0 0 0 0 1 1 1 0 0
3: 3350 5.78 Hard Easy Hard Hard 1 0 1 0 0 0 1 0 0
4: 3961 10.00 Easy <NA> Hard Hard 1 0 0 0 0 0 0 0 0
5: 4021 10.00 Easy Easy <NA> Hard 0 0 0 0 0 0 0 0 1
data:
library(data.table)
library(Rfast)
DT <- structure(list(
userID = c(3108L, 3207L, 3350L, 3961L, 4021L),
Score = c(-8, 3, 5.78, 10, 10),
Task_Alpha = structure(c(1L, 2L, 2L, 1L, 1L), .Label = c("Easy", "Hard"), class = "factor"),
Task_Beta = structure(c(1L, 1L, 1L, NA, 1L), .Label = "Easy", class = "factor"),
Task_Charlie = structure(c(1L, 3L, 2L, 2L, NA), .Label = c("Easy", "Hard", "Match"), class = "factor"),
Task_Delta = structure(c(1L, 3L, 2L, 2L, 2L), .Label = c("Easy", "Hard", "Match"), class = "factor")),
class = "data.frame", row.names = c(NA, -5L))
setDT(DT)
Would be interesting to know how fast this approach works on actual dataset and if actual dataset is large.
edit: added some timings
library(data.table)
nr <- 1e6
vec <- c('Hard', 'Match', 'Easy', NA)
DT <- data.table(userID=1:nr, Task_Alpha=sample(vec, nr, TRUE), Task_Beta=sample(vec, nr, TRUE),
Task_Charlie=sample(vec, nr, TRUE), Task_Delta=sample(vec, nr, TRUE))
df <- as.data.frame(DT)
DT0 <- copy(DT)
DT1 <- copy(DT)
DT2 <- copy(DT)
mtd0 <- function() {
t(apply(df[-1L], 1, function(i) {
i1 <- paste(i[-length(i)], i[-1L]);
i1 <- factor(i1, levels = do.call(paste, expand.grid(c('Easy', 'Match', 'Hard'),
c('Easy', 'Match', 'Hard'))));
table(i1)
}))
}
mtd1 <- function() {
f_cols <- names(DT0)[ sapply( DT0, is.factor ) ]
DT0[, (f_cols) := lapply(.SD, as.character), .SDcols = f_cols ]
#melt to long format
DT.melt <- melt( DT0, id.vars = "userID", measure.vars = patterns( task = "^Task_"))
#set order of Aplha-Beta-etc...
DT.melt[ grepl( "Alpha", variable ), order := 1 ]
DT.melt[ grepl( "Beta", variable ), order := 2 ]
DT.melt[ grepl( "Charlie", variable ), order := 3 ]
DT.melt[ grepl( "Delta", variable ), order := 4 ]
#order DT.melt
setorder( DT.melt, userID, order )
#fill in codes EE, etc...
DT.melt[, `:=`( code1 = gsub( "(^.).*", "\\1", value ),
code2 = gsub( "(^.).*", "\\1", shift( value, type = "lead" ) ) ),
by = userID ]
#filter only rows without NA
DT.melt <- DT.melt[ complete.cases( DT.melt ) ]
#cast to wide output
dcast( DT.melt, userID ~ paste0( code2, code1 ), fun.aggregate = length )
}
mtd2 <- function() {
v <- c('Hard', 'Match', 'Easy')
vv <- do.call(paste, expand.grid(v, v))
DT2[, (vv) := {
mat <- mapply(paste, .SD[, -ncol(.SD), with=FALSE], .SD[, -1L])
as.data.table(Rfast::rowTabulate(matrix(match(mat, vv, 0L), nrow=.N)))
}, .SDcols=Task_Alpha:Task_Delta]
}
bench::mark(mtd0(), mtd1(), mtd2(), check=FALSE)
timings:
# A tibble: 3 x 13
expression min median `itr/sec` mem_alloc `gc/sec` n_itr n_gc total_time result memory time gc
<bch:expr> <bch:tm> <bch:tm> <dbl> <bch:byt> <dbl> <int> <dbl> <bch:tm> <list> <list> <list> <list>
1 mtd0() 2.19m 2.19m 0.00760 252MB 2.26 1 297 2.19m <int[,9] [1,000,000 x 9]> <df[,3] [171,481 x 3]> <bch:tm> <tibble [1 x 3]>
2 mtd1() 33.16s 33.16s 0.0302 856MB 0.754 1 25 33.16s <df[,10] [843,688 x 10]> <df[,3] [8,454 x 3]> <bch:tm> <tibble [1 x 3]>
3 mtd2() 844.95ms 844.95ms 1.18 298MB 1.18 1 1 844.95ms <df[,14] [1,000,000 x 14]> <df[,3] [8,912 x 3]> <bch:tm> <tibble [1 x 3]>
回答4:
library(data.table)
#set df to data.table
setDT(df)
#convert factor-columns to character
f_cols <- names(df)[ sapply( df, is.factor ) ]
df[, (f_cols) := lapply(.SD, as.character), .SDcols = f_cols ]
#melt to long format
DT.melt <- melt( df, id.vars = "userID", measure.vars = patterns( task = "^Task_"), variable.name = grep("^Task",names(df), value = TRUE) )
#set order of Aplha-Beta-etc...
DT.melt[ grepl( "Alpha", variable ), order := 1 ]
DT.melt[ grepl( "Beta", variable ), order := 2 ]
DT.melt[ grepl( "Charlie", variable ), order := 3 ]
DT.melt[ grepl( "Delta", variable ), order := 4 ]
#order DT.melt
setorder( DT.melt, userID, order )
#fill in codes EE, etc...
DT.melt[, `:=`( code1 = gsub( "(^.).*", "\\1", value ),
code2 = gsub( "(^.).*", "\\1", shift( value, type = "lead" ) ) ),
by = userID ]
#filter only rows without NA
DT.melt <- DT.melt[ complete.cases( DT.melt ) ]
str(DT.melt)
#cast to wide output
dcast( DT.melt, userID ~ paste0( code2, code1 ), fun.aggregate = length )
# userID EE EH EM HE HH MM
# 1: 3108 3 0 0 0 0 0
# 2: 3207 0 0 1 1 0 1
# 3: 3350 0 1 0 1 1 0
# 4: 3961 0 0 0 0 1 0
# 5: 4021 1 0 0 0 0 0
来源：https://stackoverflow.com/questions/58745713/how-to-count-the-factors-in-ordered-sequence