Эффективно размещать постоянные столбцы в группе в data.frame - PullRequest
Новая
       7

Эффективно размещать постоянные столбцы в группе в data.frame

7 голосов
/ 27 декабря 2011

Как эффективно извлечь столбцы констант по группам из фрейма данных?Я включил реализацию plyr ниже, чтобы точно определить, что я пытаюсь сделать, но это медленно.Как я могу сделать это максимально эффективно?(В идеале без разделения кадра данных вообще).

base <- data.frame(group = 1:1000, a = sample(1000), b = sample(1000))
df <- data.frame(
  base[rep(seq_len(nrow(base)), length = 1e6), ], 
  c = runif(1e6), 
  d = runif(1e6)
)


is.constant <- function(x) length(unique(x)) == 1
constant_cols <- function(x) head(Filter(is.constant, x), 1)
system.time(constant <- ddply(df, "group", constant_cols))
#   user  system elapsed 
# 20.531   1.670  22.378 
stopifnot(identical(names(constant), c("group", "a", "b")))
stopifnot(nrow(constant) == 1000)

В моем реальном случае использования (глубоко внутри ggplot2) может быть произвольное количество постоянных и непостоянных столбцов.Размер данных в примере примерно соответствует порядку величины.

Ответы [ 6 ]

4 голосов
/ 28 декабря 2011

Я не уверен, что это именно то, что вы ищете, но он определяет столбцы a и b. 

require(data.table)
is.constant <- function(x) identical(var(x), 0)
dtOne <- data.table(df)
system.time({dtTwo <- dtOne[, lapply(.SD, is.constant), by=group]
result <- apply(X=dtTwo[, list(a, b, c, d)], 2, all)
result <- result[result == TRUE] })
stopifnot(identical(names(result), c("a", "b"))) 
result
4 голосов
/ 27 декабря 2011

(отредактировано для возможного решения проблемы последовательных групп с одинаковым значением)

Я предварительно отправляю этот ответ, но я не до конца убедил себя, что он будет правильно определять столбцы с константами группы во всех случаях. Но это определенно быстрее (и, вероятно, может быть улучшено): 

constant_cols1 <- function(df,grp){
    df <- df[order(df[,grp]),]

    #Adjust values based on max diff in data
    rle_group <- rle(df[,grp])
    vec <- rep(rep(c(0,ceiling(diff(range(df)))),
               length.out = length(rle_group$lengths)),
               times = rle_group$lengths)
    m <- matrix(vec,nrow = length(vec),ncol = ncol(df)-1)
    df_new <- df
    df_new[,-1] <- df[,-1] + m

    rles <- lapply(df_new,FUN = rle)
    nms <- names(rles)
    tmp <- sapply(rles[nms != grp],
                  FUN = function(x){identical(x$lengths,rles[[grp]]$lengths)})
    return(tmp)
}

Моя основная идея заключалась в том, чтобы использовать rle, очевидно.

3 голосов
/ 28 декабря 2011

Немного медленнее, чем то, что предлагал Хэдли выше, но я думаю, что он должен обрабатывать случай равных смежных групп 

findBreaks <- function(x) cumsum(rle(x)$lengths)

constantGroups <- function(d, groupColIndex=1) {
  d <- d[order(d[, groupColIndex]), ]
  breaks <- lapply(d, findBreaks)
  groupBreaks <- breaks[[groupColIndex]]
  numBreaks <- length(groupBreaks)
  isSubset <- function(x) length(x) <= numBreaks && length(setdiff(x, groupBreaks)) == 0
  unlist(lapply(breaks[-groupColIndex], isSubset))
}

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

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

# df defined as in the question

n <- nrow(df)
changed <- function(x) c(TRUE, x[-1] != x[-n])

constant_cols2 <- function(df,grp){
  df <- df[order(df[,grp]),]
  changes <- lapply(df, changed)
  vapply(changes[-1], identical, changes[[1]], FUN.VALUE = logical(1))
}

> system.time(constant_cols2(df, 1))
   user  system elapsed 
  1.779   0.075   1.869 
> system.time(constantGroups(df))
   user  system elapsed 
  2.503   0.126   2.614 
> df$f <- 1
> constant_cols2(df, 1)
    a     b     c     d     f 
 TRUE  TRUE FALSE FALSE FALSE 
> constantGroups(df)
    a     b     c     d     f 
 TRUE  TRUE FALSE FALSE  TRUE
3 голосов
/ 27 декабря 2011

Вдохновленный ответом @ Joran, вот похожая стратегия, которая немного быстрее (1 с против 1,5 с на моей машине) 

changed <- function(x) c(TRUE, x[-1] != x[-n])

constant_cols2 <- function(df,grp){
  df <- df[order(df[,grp]),]
  n <- nrow(df)
  changes <- lapply(df, changed)

  vapply(changes[-1], identical, changes[[1]], FUN.VALUE = logical(1))
}
system.time(cols <- constant_cols2(df, "group")) # about 1 s

system.time(constant <- df[changed(df$group), cols])
#   user  system elapsed 
#  1.057   0.230   1.314 

stopifnot(identical(names(constant), c("group", "a", "b")))
stopifnot(nrow(constant) == 1000)

Он имеет те же недостатки, но не обнаруживает столбцы с одинаковыми значениями для смежных групп (например, df$f <- 1)

С еще большим размышлением и идеями Дэвида: 

constant_cols3 <- function(df, grp) {
  # If col == TRUE and group == FALSE, not constant
  matching_breaks <- function(group, col) {
    !any(col & !group)
  }

  n <- nrow(df)
  changed <- function(x) c(TRUE, x[-1] != x[-n])

  df <- df[order(df[,grp]),]
  changes <- lapply(df, changed)
  vapply(changes[-1], matching_breaks, group = changes[[1]], 
    FUN.VALUE = logical(1))
}

system.time(x <- constant_cols3(df, "group"))
#   user  system elapsed 
#  1.086   0.221   1.413

И это дает правильный результат.

3 голосов
/ 27 декабря 2011

(правка: лучший ответ)

Как насчет чего-то вроде

is.constant<-function(x) length(which(x==x[1])) == length(x)

Кажется, это хорошее улучшение.Сравните следующее. 

> a<-rnorm(5000000)

> system.time(is.constant(a))
   user  system elapsed 
  0.039   0.010   0.048 
> 
> system.time(is.constantOld(a))
   user  system elapsed 
  1.049   0.084   1.125
1 голос
/ 28 декабря 2011

Насколько быстро is.unsorted(x) терпит неудачу для непостоянного х?К сожалению, у меня нет доступа к R в данный момент.Также кажется, что это не ваше узкое место, хотя.

...