Создание составных/взаимодействующих фиктивных переменных в data.table в R

Question

Все еще изучайте эту потрясающую таблицу данных package.table. Я работаю над следующим data.table:

demo <- data.table(id = c(1, 2, 3, 4, 5, 6), sex = c(1, 2, 1, 2, 2, 2), agef = c(43, 53, 63, 73, 83, 103)) 

demo: 
id sex agef 
1 1 43 
2 2 53 
3 1 63 
4 2 73 
5 2 83 
6 2 103 

Я пытаюсь создать новые столбцы (age_gender полос), как ("F0_34", "F35_44", "F45_54", "F55_59" ..... ... «F95_GT») и («M0_34», «M35_44», «M45_54», «M55_59» ........ «M95_GT») в зависимости от значения пола столбца и возраста, их имена и значение будут быть сгенерированным. Я могу сделать простым способом:

demo <- demo[ ,F0_34:= {ifelse((sex==2) & (agef >= 0) & (agef <= 34), 1, 0)}] 

Но я искал элегантное решение для этого, и я попытался передать age_band в виде списка в lapply функции следующим образом:

i <- list("0_34","35_44","45_54","55_59","60_64","65_69","70_74","75_79","80_84","85_89","90_94","95_GT") 

demo[, paste0("F", i) := lapply(i, function(i)lapply(.SD, function(x){ 
l1 <- unlist(str_split(i, "_")) 
if(l1[2] == "GT") l1[2] <- 1000 
l1 <- as.numeric(l1) 
score <- ifelse((sex==2) & (agef >= l1[1]) & (agef <= l1[2]), 1, 0) 
return(score) 
})), .SDcols = c("sex", "agef"), by = id] 

demo[, paste0("M", i) := lapply(i, function(i)lapply(.SD, function(x){ 
l1 <- unlist(str_split(i, "_")) 
if(l1[2] == "GT") l1[2] <- 1000 
l1 <- as.numeric(l1) 
score <- ifelse((sex==1) & (agef >= l1[1]) & (agef <= l1[2]), 1, 0) 
return(score) 
})), .SDcols = c("sex", "agef"), by = id] 

Я получаю желаемый результат:

id sex agef F0_34 F35_44 F45_54 F55_59 F60_64 F65_69 F70_74 F75_79 F80_84 F85_89 F90_94 F95_GT M0_34 M35_44 M45_54 M55_59 M60_64 M65_69 M70_74 M75_79 M80_84 M85_89 M90_94 M95_GT 
1 1 43  0  0  0  0  0  0  0  0  0  0  0  0  0  1  0  0  0  0  0  0  0  0  0  0 
2 2 53  0  0  1  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0 
3 1 63  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  1  0  0  0  0  0  0  0 
4 2 73  0  0  0  0  0  0  1  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0 
5 2 83  0  0  0  0  0  0  0  0  1  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0 
6 2 103  0  0  0  0  0  0  0  0  0  0  0  1  0  0  0  0  0  0  0  0  0  0  0  0 

, но с некоторыми предупреждениями:

Warning messages: 
1: In `[.data.table`(demographic1, , `:=`(paste0("F", i), ... : 
RHS 1 is length 2 (greater than the size (1) of group 1). The last 1 element(s) will be discarded. 

, который я не могу понять, может кто-то указать, что я делаю неправильно?

Answer 1

Это то, что вы ищете:

age.brackets <- c(0,seq(35,55, by=10), seq(60,95, by=5), Inf) #age ranges 
ranges <- (cut(demo$agef, age.brackets)) 
split(demo, demo$sex) 
spread <- table(demo$agef, ranges) #identify persons in each range 
male.spread <- (demo$sex=='1')*as.matrix(spread) 
female.spread <- (demo$sex=='2')*as.matrix(spread) 

newdt <- data.table(
    cbind(
    demo, 
    matrix(as.vector(male.spread), ncol=ncol(male.spread)), 
    matrix(as.vector(female.spread), ncol=ncol(female.spread)) 
    ) 
) 


    #column names 
names(newdt) <- c(names(demo), 
        levels(cut(demo$agef, age.brackets)), 
        levels(cut(demo$agef, age.brackets)) 
       ) 
female.names <- gsub('.(\\d*),(\\d*|Inf).', 'F\\1_\\2', levels(cut(demo$agef, age.brackets)))   
male.names <- gsub('.(\\d*),(\\d*|Inf).', 'M\\1_\\2', levels(cut(demo$agef, age.brackets))) 
names(newdt) <- c(names(demo), female.names, male.names) 


newdt 

# id sex agef F0_35 F35_45 F45_55 F55_60 F60_65 F65_70 F70_75 F75_80 F80_85 F85_90 
# 1: 1 1 43  0  1  0  0  0  0  0  0  0  0 
# 2: 2 2 53  0  0  0  0  0  0  0  0  0  0 
# 3: 3 1 63  0  0  0  0  1  0  0  0  0  0 
# 4: 4 2 73  0  0  0  0  0  0  0  0  0  0 
# 5: 5 2 83  0  0  0  0  0  0  0  0  0  0 
# 6: 6 2 103  0  0  0  0  0  0  0  0  0  0 
# F90_95 F95_Inf M0_35 M35_45 M45_55 M55_60 M60_65 M65_70 M70_75 M75_80 M80_85 M85_90 
# 1:  0  0  0  0  0  0  0  0  0  0  0  0 
# 2:  0  0  0  0  1  0  0  0  0  0  0  0 
# 3:  0  0  0  0  0  0  0  0  0  0  0  0 
# 4:  0  0  0  0  0  0  0  0  1  0  0  0 
# 5:  0  0  0  0  0  0  0  0  0  0  1  0 
# 6:  0  0  0  0  0  0  0  0  0  0  0  0 
# M90_95 M95_Inf 
# 1:  0  0 
# 2:  0  0 
# 3:  0  0 
# 4:  0  0 
# 5:  0  0 
# 6:  0  1 

Answer 2

Это должно работать и больше data.table -y:

cut_points <- c(0, seq(35, 55, by = 10), seq(60, 95, by = 5),Inf) 
new_names_m <- paste0("M", cut_points[1:12], "_", c(cut_points[2:12], "GT")) 
new_names_f <- paste0("F", cut_points[1:12], "_", c(cut_points[2:12], "GT")) 
demo[sex == 1, ranges := cut(agef, cut_points, include.lowest = TRUE, 
         labels = new_names_m)] 
demo[sex == 2, ranges := cut(agef, cut_points, include.lowest = TRUE, 
         labels = new_names_f)] 
demo[ ,(c(new_names_m, new_names_f)) := 
     lapply(c(new_names_m, new_names_f), function(x) +(ranges == x))] 
demo[ , ranges := NULL] 

> demo 
    id sex agef M0_35 M35_45 M45_55 M55_60 M60_65 M65_70 M70_75 M75_80 M80_85 M85_90 M90_95 M95_GT F0_35 F35_45 F45_55 F55_60 F60_65 
1: 1 1 43  0  1  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0 
2: 2 2 53  0  0  0  0  0  0  0  0  0  0  0  0  0  0  1  0  0 
3: 3 1 63  0  0  0  0  1  0  0  0  0  0  0  0  0  0  0  0  0 
4: 4 2 73  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0 
5: 5 2 83  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0 
6: 6 2 103  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0 
    F65_70 F70_75 F75_80 F80_85 F85_90 F90_95 F95_GT 
1:  0  0  0  0  0  0  0 
2:  0  0  0  0  0  0  0 
3:  0  0  0  0  0  0  0 
4:  0  1  0  0  0  0  0 
5:  0  0  0  1  0  0  0 
6:  0  0  0  0  0  0  1 

В качестве альтернативы, вместо lapply во втором до последнего линии, можно инициализировать манекены до нуля, а затем назначить их в соответствующих положениях:

new_names = c(new_names_f, new_names_m) 
demo[ , (new_names) := 0L] 
is = which(demo$ranges != "") 
js = 3L + match(demo$ranges[is], new_names) 
for (iter in seq_along(is)) set(demo, i = is[iter], j = js[iter], value = 1L)