R Заменить значения на основе условий (для того же идентификатора) без использования цикла for - PullRequest
Новая
       12

R Заменить значения на основе условий (для того же идентификатора) без использования цикла for

0 голосов
/ 30 мая 2018

У меня есть df, похожий на этот, но гораздо больше (100.000 строк x 100 столбцов) 

df <-data.frame(id=c("1","2","2","3","4","4", "4", "4", "4", "4", "5"), date = c("2015-01-15", "2004-03-01", "2017-03-15", "2000-01-15", "2006-05-08", "2008-05-09", "2014-05-11", "2014-06-11", "2014-07-11", "2014-08-11", "2015-12-19"), A =c (0,1,1,0,1,1,0,0,1,1,1), B=c(1,0,1,0,1,0,0,0,1,1,1), C = c(0,1,0,0,0,1,1,1,1,1,0), D = c(0,0,0,1,1,1,1,0,1,0,1), E = c(1,1,1,0,0,0,0,0,1,1,1), A.1 = c(0,0,0,0,0,0,0,0,0,0,0), B.1 = c(0,0,0,0,0,0,0,0,0,0,0), C.1 = c(0,0,0,0,0,0,0,0,0,0,0), D.1 = c(0,0,0,0,0,0,0,0,0,0,0), E.1 = c(0,0,0,0,0,0,0,0,0,0,0), acumulativediff = c(0, 0, 4762, 0, 0, 732, 2925, 2956, 2986, 3017, 0))

Что мне нужно сделать, это: 

structure(list(id = structure(c(1L, 2L, 2L, 3L, 4L, 4L, 4L, 4L, 4L, 4L,5L), .Label = c("1", "2", "3", "4", "5"), class = "factor"), date = structure(c(9L, 2L, 11L, 1L, 3L, 4L, 5L, 6L, 7L, 8L,10L), .Label = c("2000-01-15", "2004-03-01", "2006-05-08","2008-05-09", "2014-05-11", "2014-06-11", "2014-07-11", "2014-08-11","2015-01-15", "2015-12-19", "2017-03-15"), class = "factor"), A = c(0, 1, 1, 0, 1, 1, 0, 0, 1, 1, 1), B = c(1, 0, 1, 0,1, 0, 0, 0, 1, 1, 1), C = c(0, 1, 0, 0, 0, 1, 1, 1, 1, 1, 0), D = c(0, 0, 0, 1, 1, 1, 1, 0, 1, 0, 1), E = c(1, 1, 1,0, 0, 0, 0, 0, 1, 1, 1), A.1 = c(0, 0, 4762, 0, 0, 732, 2925,0, 0, 3017, 0), B.1 = c(0, 0, 0, 0, 0, 732, 0, 0, 0, 3017,0), C.1 = c(0, 0, 4762, 0, 0, 0, 2925, 2956, 2986, 3017,
0), D.1 = c(0, 0, 0, 0, 0, 732, 2925, 2956, 0, 3017, 0),E.1 = c(0, 0, 4762, 0, 0, 0, 0, 0, 0, 3017, 0), acumulativediff = c(0, 0, 4762, 0, 0, 732, 2925, 2956, 2986, 3017, 0)), .Names = c("id","date", "A", "B", "C", "D", "E", "A.1", "B.1", "C.1", "D.1", "E.1", "acumulativediff"), row.names = c(NA,-11L), class = "data.frame")

Идея состоит в том,заменить 0 из столбцов A.1, B.1, C.1 значениями столбца «acumulativediff», основываясь на двух условиях: 

df[i,1]  == df[i-1,1] & df[i,names] == "1" & df[i-1,names] == "1", df[i,diff]
df[i,1]  == df[i-1,1] & df[i,names] == "0" & df[i-1,names] == "1", df[i,diff]

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

names <- colnames(df[3:7])
names2 <- colnames(df[8:12])
diff <- which(colnames(df)=="acumulativediff")
for (i in 2:nrow(df)){
df[i,names2] <- ifelse (df[i,1]  == df[i-1,1] & df[i,names] == "1" & 
df[i-1,names] == "1", df[i,diff],
      ifelse (df[i,1]  == df[i-1,1] & df[i,names] == "0" & df[i-1,names] == "1", df[i,diff], 0))}

Любая идея или совет, чтобы пропустить цикл для достижения более эффективного кода?

Ответы [ 6 ]

0 голосов
/ 02 июня 2018

В базе R: 

df2 <- df
# first we ignore id
df2[-1,8:12] <- df[-nrow(df),3:7] * df[-1,13]
# then we make sure rows of 1st id are 0
df2[which(diff(as.numeric(df$id))==1)+1,8:12] <- 0

#    id       date A B C D E  A.1  B.1  C.1  D.1  E.1 acumulativediff
# 1   1 2015-01-15 0 1 0 0 1    0    0    0    0    0               0
# 2   2 2004-03-01 1 0 1 0 1    0    0    0    0    0               0
# 3   2 2017-03-15 1 1 0 0 1 4762    0 4762    0 4762            4762
# 4   3 2000-01-15 0 0 0 1 0    0    0    0    0    0               0
# 5   4 2006-05-08 1 1 0 1 0    0    0    0    0    0               0
# 6   4 2008-05-09 1 0 1 1 0  732  732    0  732    0             732
# 7   4 2014-05-11 0 0 1 1 0 2925    0 2925 2925    0            2925
# 8   4 2014-06-11 0 0 1 0 0    0    0 2956 2956    0            2956
# 9   4 2014-07-11 1 1 1 1 1    0    0 2986    0    0            2986
# 10  4 2014-08-11 1 1 1 0 1 3017 3017 3017 3017 3017            3017
# 11  5 2015-12-19 1 1 0 1 1    0    0    0    0    0               0

Вот эталонный тест по сравнению с текущим решением @ MKR для данного набора данных и для имитированного набора данных ~ 100 тыс. Строк.В любом случае у меня машина работает примерно в 5 раз быстрее. 

mm <- function(df){
df[-1,8:12] <- df[-nrow(df),3:7] * df[-1,13]
df[which(diff(as.numeric(df$id))==1)+1,8:12] <- 0
df}

mkr <- function(df){df %>% select(-ends_with(".1")) %>%
  mutate_at(vars(A:E), 
funs(l = ifelse(lag(id)==id & lag(., default=0) == "1",acumulativediff,0)))}

microbenchmark::microbenchmark(mm(df),mkr(df),unit="relative")
# Unit: relative
#     expr      min       lq     mean   median       uq      max neval
#   mm(df) 1.000000 1.000000 1.000000 1.000000 1.000000 1.000000   100
#  mkr(df) 7.788748 7.666287 5.265091 6.755467 6.655934 1.291942   100


big <- do.call(rbind,replicate(10000,df,F))
big$id <- data.table::rleid(big$id)

microbenchmark::microbenchmark(mm(big),mkr(big),unit="relative")
# Unit: relative
#     expr      min       lq     mean   median       uq      max neval
#  mm(big) 1.000000 1.000000 1.000000 1.000000 1.000000 1.000000   100
# mkr(big) 7.065627 4.945323 4.429752 4.910065 4.566391 1.765609   100
0 голосов
/ 30 мая 2018

Только что заметил, что вы на самом деле хотите, чтобы операции группировались по ID, в этом случае мой ответ не дает правильного результата.

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

Этодолжен работать так же или аналогично большинству однострочников, но в будущем вы можете оценить удобочитаемость. 

setDT(df)

Suffix <- ".1"
SuffixedNames <- intersect(names(df),paste0(names(df),Suffix))
RawNames <- intersect(names(df),gsub(Suffix,"",SuffixedNames))

for (x in seq_along(RawNames)){

  thisRawName <- RawNames[[x]]
  thisSuffixedName <- SuffixedNames[[x]]

  Raw <- df[[thisRawName]]
  ## Using the shift() function from the data.table package
  Lagged <- shift(Raw, n = 1L, type = "lag", fill = -1L)

  ## Using set() from the data.table package
  set(df, j = thisSuffixedName, value = ifelse((Raw == Lagged & Raw == 1L & Lagged == 1L) | (Raw == 0L & Lagged == 1L),
                                    df[["acumulativediff"]],
                                    0L))
}
0 голосов
/ 30 мая 2018

Это условие df[i,1] == df[i-1,1] можно заменить группировкой по столбцу id.Другой момент заключается в том, что если у вас есть только «0» или «1» в столбцах A, B и т. Д., То условие (df[i,names] == "1" & df[i-1,names] == "1" или df[i,names] == "0" & df[i-1,names] == "1") можно упростить до (df[i-1,names] == "1"), что эквивалентно lag из df[,names].

Я предлагаю решение data.table, в котором лаг определяется функцией shift.Честно говоря, это не пример хорошего кодирования благодаря использованию конструкций eval(parse()), но я надеюсь, что с ними будет проще понять решение. 

library(data.table)

setDT(df)

bin_names <- LETTERS[1:5]
# [1] "A" "B" "C" "D" "E"
bin_names.1 <- paste0(bin_names, ".1")
# [1] "A.1" "B.1" "C.1" "D.1" "E.1"

# slicing table in parts with "by" parameter and compute columns "A.1", "B.1" etc. in for loop
for (i in seq_along(bin_names)) df[, eval(bin_names.1[i]) := shift(as.numeric(eval(parse(text = bin_names[i]))))*acumulativediff, by = .(id)]
df[]
#     id       date A B C D E  A.1  B.1  C.1  D.1  E.1 acumulativediff
#  1:  1 2015-01-15 0 1 0 0 1   NA   NA   NA   NA   NA               0
#  2:  2 2004-03-01 1 0 1 0 1   NA   NA   NA   NA   NA               0
#  3:  2 2017-03-15 1 1 0 0 1 4762    0 4762    0 4762            4762
#  4:  3 2000-01-15 0 0 0 1 0   NA   NA   NA   NA   NA               0
#  5:  4 2006-05-08 1 1 0 1 0   NA   NA   NA   NA   NA               0
#  6:  4 2008-05-09 1 0 1 1 0  732  732    0  732    0             732
#  7:  4 2014-05-11 0 0 1 1 0 2925    0 2925 2925    0            2925
#  8:  4 2014-06-11 0 0 1 0 0    0    0 2956 2956    0            2956
#  9:  4 2014-07-11 1 1 1 1 1    0    0 2986    0    0            2986
# 10:  4 2014-08-11 1 1 1 0 1 3017 3017 3017 3017 3017            3017
# 11:  5 2015-12-19 1 1 0 1 1   NA   NA   NA   NA   NA               0

Если вам не нравятся NA sв вашей таблице вы можете сделать немного больше работы, чтобы исправить это. 

fillna <- function(x, fill = 0) {x[is.na(x)] <- fill; return(x)}
for (nm in bin_names.1) df[, eval(nm) := fillna(eval(parse(text = nm)))]
df[]
#     id       date A B C D E  A.1  B.1  C.1  D.1  E.1 acumulativediff
#  1:  1 2015-01-15 0 1 0 0 1    0    0    0    0    0               0
#  2:  2 2004-03-01 1 0 1 0 1    0    0    0    0    0               0
#  3:  2 2017-03-15 1 1 0 0 1 4762    0 4762    0 4762            4762
#  4:  3 2000-01-15 0 0 0 1 0    0    0    0    0    0               0
#  5:  4 2006-05-08 1 1 0 1 0    0    0    0    0    0               0
#  6:  4 2008-05-09 1 0 1 1 0  732  732    0  732    0             732
#  7:  4 2014-05-11 0 0 1 1 0 2925    0 2925 2925    0            2925
#  8:  4 2014-06-11 0 0 1 0 0    0    0 2956 2956    0            2956
#  9:  4 2014-07-11 1 1 1 1 1    0    0 2986    0    0            2986
# 10:  4 2014-08-11 1 1 1 0 1 3017 3017 3017 3017 3017            3017
# 11:  5 2015-12-19 1 1 0 1 1    0    0    0    0    0               0

Другой вариант - использовать shift с параметром fill = 0, чтобы сразу получить нули.

shift(as.numeric(eval(parse(text = bin_names[i]))), fill = 0)*acumulativediff

0 голосов
/ 30 мая 2018

Вы также можете попробовать это.group_by заменяет части использованного подхода ifelse, используемого в другом ответе.Здесь case_when используется для проверки, если lag() == 1, что достаточно для ИМО. 

df %>% 
 select(-ends_with(".1")) %>% 
 group_by(id) %>% 
 mutate_at(.vars = vars(A:E), funs("1"=case_when(lag(.) == 1 ~ acumulativediff, TRUE ~ 0))) %>% 
 ungroup()
# A tibble: 11 x 13
   id    date           A     B     C     D     E acumulativediff  A_1  B_1  C_1  D_1  E_1
   <fct> <fct>      <dbl> <dbl> <dbl> <dbl> <dbl>           <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
 1 1     2015-01-15     0     1     0     0     1               0     0     0     0     0     0
 2 2     2004-03-01     1     0     1     0     1               0     0     0     0     0     0
 3 2     2017-03-15     1     1     0     0     1            4762  4762     0  4762     0  4762
 4 3     2000-01-15     0     0     0     1     0               0     0     0     0     0     0
 5 4     2006-05-08     1     1     0     1     0               0     0     0     0     0     0
 6 4     2008-05-09     1     0     1     1     0             732   732   732     0   732     0
 7 4     2014-05-11     0     0     1     1     0            2925  2925     0  2925  2925     0
 8 4     2014-06-11     0     0     1     0     0            2956     0     0  2956  2956     0
 9 4     2014-07-11     1     1     1     1     1            2986     0     0  2986     0     0
10 4     2014-08-11     1     1     1     0     1            3017  3017  3017  3017  3017  3017
11 5     2015-12-19     1     1     0     1     1               0     0     0     0     0     0
0 голосов
/ 30 мая 2018

Я предлагаю проигнорировать A.1, B.1 etc столбцы.Просто создайте эти столбцы заново, используя dplyr::mutate_at и правила, указанные в OP.dplyr::lag с default = 0 поможет избежать NA в результате.

library(dplyr)

df %>% select(-ends_with(".1")) %>%
  mutate_at(vars(A:E), 
       funs(l = ifelse(lag(id)==id & lag(., default=0) == "1",acumulativediff,0)))


#    id       date A B C D E acumulativediff  A_l  B_l  C_l  D_l  E_l
# 1   1 2015-01-15 0 1 0 0 1               0    0    0    0    0    0
# 2   2 2004-03-01 1 0 1 0 1               0    0    0    0    0    0
# 3   2 2017-03-15 1 1 0 0 1            4762 4762    0 4762    0 4762
# 4   3 2000-01-15 0 0 0 1 0               0    0    0    0    0    0
# 5   4 2006-05-08 1 1 0 1 0               0    0    0    0    0    0
# 6   4 2008-05-09 1 0 1 1 0             732  732  732    0  732    0
# 7   4 2014-05-11 0 0 1 1 0            2925 2925    0 2925 2925    0
# 8   4 2014-06-11 0 0 1 0 0            2956    0    0 2956 2956    0
# 9   4 2014-07-11 1 1 1 1 1            2986    0    0 2986    0    0
# 10  4 2014-08-11 1 1 1 0 1            3017 3017 3017 3017 3017 3017
# 11  5 2015-12-19 1 1 0 1 1               0    0    0    0    0    0
0 голосов
/ 30 мая 2018

Это у вас работает? 

df <-data.frame(id=c("1","2","2","3","4","4", "4", "4", "4", "4", "5"), 
                date = c("2015-01-15", "2004-03-01", "2017-03-15", "2000-01-15", "2006-05-08", 
                         "2008-05-09", "2014-05-11", "2014-06-11", "2014-07-11", "2014-08-11", "2015-12-19"), 
                A =c (0,1,1,0,1,1,0,0,1,1,1), B=c(1,0,1,0,1,0,0,0,1,1,1), C = c(0,1,0,0,0,1,1,1,1,1,0), 
                D = c(0,0,0,1,1,1,1,0,1,0,1), E = c(1,1,1,0,0,0,0,0,1,1,1), A.1 = c(0,0,0,0,0,0,0,0,0,0,0), 
                B.1 = c(0,0,0,0,0,0,0,0,0,0,0), C.1 = c(0,0,0,0,0,0,0,0,0,0,0), D.1 = c(0,0,0,0,0,0,0,0,0,0,0), 
                E.1 = c(0,0,0,0,0,0,0,0,0,0,0), acumulativediff = c(0, 0, 4762, 0, 0, 732, 2925, 2956, 2986, 3017, 0),
                stringsAsFactors = FALSE)
df2 <- df
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                0), D.1 = c(0, 0, 0, 0, 0, 732, 2925, 2956, 0, 3017, 0),E.1 = c(0, 0, 4762, 0, 0, 0, 0, 0, 0, 3017, 0), acumulativediff = c(0, 0, 4762, 0, 0, 732, 2925, 2956, 2986, 3017, 0)), .Names = c("id","date", "A", "B", "C", "D", "E", "A.1", "B.1", "C.1", "D.1", "E.1", "acumulativediff"), row.names = c(NA,-11L), class = "data.frame") 
names <- colnames(df[3:7])
names2 <- colnames(df[8:12])
diff <- which(colnames(df)=="acumulativediff")

df2[,names2] <- ifelse(df[,1] == dplyr::lag(df[,1]) & df[,names] == "1" & 
                         dplyr::lag(df[,names]) == "1",
                       df[,diff],
                       ifelse (df[,1]  == dplyr::lag(df[,1]) & df[,names] == "0" & 
                                 dplyr::lag(df[,names]) == "1", df[,diff], 0))
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.

Нет похожих вопросов

...