Цикл сравнения - PullRequest
Новая
       6

Цикл сравнения

1 голос
/ 29 мая 2020

У меня есть вложенный список 

combine <- list(c('A', 'B', 'C'), c('D', 'H', 'G', 'J'), c('A', 'E'))

и df 

df <- data.frame(appln_id = c(1, 1, 2, 2, 4, 4, 4, 3, 3, 3, 3, 5, 9, 9), 
                 prior_year = c(1997,1997,1997,1997,1997,1997,1997,1998,1998,1998,1998,2000,2000,2000),
                 IPC = c('B','E','E','B','H','J','D','H','J','D','E','A','E','B'))

Я хочу агрегировать IPC в соответствии с appln_id (например: for appln_id=1: c('B','E'), for appln_id=2: c('E','B'), for appln_id=4: c('H','J','D'), и т. Д. c.). Затем для каждого значения prior_year я хочу сравнить наборы IPC с элементами списка combine.

Для набора IPC, который не является подмножеством какого-либо элемента combine, Я хочу сохранить его данные в df в другом фрейме данных с именем new следующим образом: 

new <- data.frame(appln_id = c(1, 1, 3, 3, 3, 3), 
                  prior_year = c(1997,1997,1998,1998,1998,1998),
                  IPC = c('B','E','H','J','D','E'))

и добавить этот IPC набор в combine следующим образом: 

combine <- list(c('A', 'B', 'C'), c('D', 'H', 'G', 'J'), c('A', 'E'), c('B', 'E'), c('D','E','J','H'))

Это мой код: 

new <- data.frame(appln_id=integer(),prio_year=integer(), IPC=character()) 
new_combine=list()
prio_year <- unique(df$prio_year)
appln_id <- unique(df$appln_id)
for (i in prio_year){
  for (j in appln_id){
    x <- sort((df[(df$prio_year==i) & (df$appln_id==j),3])[[1]])
    for (k in combine){
      if (all(x %in% k) == FALSE){
        new <- rbind(new, df[df$appln_id==j,])
        new_combine[[length(new_combine)+1]] <- x
      }
    }
  }
  combine <- c(combine,unique(new_combine))
}

Однако выполнение моего кода занимает слишком много времени. Может ли кто-нибудь другой способ сделать это быстрее? Спасибо.

1 Ответ

3 голосов
/ 29 мая 2020

Вот то, что всего лишь 1 oop. Впрочем, заранее я изменил $IPC с factor на character, поскольку объединение разных уровней факторов может немного раздражать. (Если вы используете R-4.0 или $IPC уже character, тогда нет необходимости делать этот шаг.) 

df$usable <- TRUE
df$grps <- interaction(df$appln_id, df$prior_year)
newlist <- list()
for (grp in levels(df$grps)) {
  rows <- df$grps == grp & df$usable
  if (!length(rows)) next
  thisIPC <- df$IPC[rows]
  matches <- sapply(combine, function(comb) all(thisIPC %in% comb))
  if (any(matches)) {
    # repeat
  } else {
    # new!
    combine <- c(combine, list(thisIPC))
    newlist <- c(newlist, list(df[rows,]))
    df$usable[rows] <- FALSE
  }
}
df <- df[df$usable,]
new <- do.call(rbind, newlist)
df$usable <- df$grps <- 
  new$usable <- new$grps <- NULL

df
#    appln_id prior_year IPC
# 3         2       1997   E
# 4         2       1997   B
# 5         4       1997   H
# 6         4       1997   J
# 7         4       1997   D
# 12        5       2000   A
# 13        9       2000   E
# 14        9       2000   B
new
#    appln_id prior_year IPC
# 1         1       1997   B
# 2         1       1997   E
# 8         3       1998   H
# 9         3       1998   J
# 10        3       1998   D
# 11        3       1998   E
str(combine)
# List of 5
#  $ : chr [1:3] "A" "B" "C"
#  $ : chr [1:4] "D" "H" "G" "J"
#  $ : chr [1:2] "A" "E"
#  $ : chr [1:2] "B" "E"
#  $ : chr [1:4] "H" "J" "D" "E"

Примечания:

  • Я создаю переменная $grps для упрощения группировки по одному-l oop; как только этот l oop будет готов, не стесняйтесь его удалять. Использование factor, а затем levels гарантирует, что я перебираю еще одну существующую комбинацию, не более того.

  • Я могу пойти на большее количество крайностей, чем необходимо, но итеративно растущие кадры плохо в длинном - термин для производительности: каждый раз, когда вы «добавляете строки», весь кадр полностью копируется в память, поэтому с каждым добавлением вы дублируете память, занимаемую кадром. Конечно, память очищается, но это «известная вещь», что это заметно асимптотически тормозит. (См. Главу 2, Растущие объекты , в R Inferno .) Это применимо (в несколько меньшей степени) и к итеративному удалению строк.

    Потому что из этого я фактически не меняю содержимое фрейма до самого конца. Чтобы учесть это, я также добавляю столбец $usable, чтобы указать, следует ли его удалить в конце. (В том маловероятном случае, если вы запустите этот код дважды в одном кадре, я также использую $enable при захвате $IPC, это может быть просто излишне защитным.)

    Опубликовать -l oop, я удаляю соответствующие строки из df один раз и выполняю конкатенацию одной строки (rbind) в newlist, который представляет собой список с фреймами (или ничего , если ничего не произошло).

...