Localizar de manera eficiente las columnas constantes de grupos en un data.frame

Question

¿Cómo puedo extraer eficientemente columnas constantes sabio de un marco de datos? He incluido una implementación de plyr a continuación para precisar lo que estoy tratando de hacer, pero es lento. ¿Cómo puedo hacerlo de la manera más eficiente posible? (Idealmente sin dividir el marco de datos en absoluto).

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) 

En mi caso de uso real (en el interior de ggplot2) puede haber un número arbitrario de columnas constantes y no constantes. El tamaño de los datos en el ejemplo es sobre el orden correcto de magnitud.

Answer 1

Inspirado por @ respuesta de Joran, aquí está estrategia similar que es un poco más rápido (1 s vs 1,5 s en mi máquina)

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) 

Tiene los mismos defectos, sin embargo, en que no va a detectar columnas que se tienen los mismos valores para los grupos adyacentes (por ejemplo df$f <- 1)

Con un poco más pensamiento, más las ideas de David @:

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 

Y eso le da el resultado correcto .

Answer 2

(edit: mejor respuesta)

¿Qué pasa algo parecido

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

Ésta parece ser una buena mejora. Compare lo siguiente.

> 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 

Answer 3

(Editado para abordar posiblemente la cuestión de los grupos consecutivos con el mismo valor)

estoy tentativamente enviar esta respuesta, pero no me he convencido por completo que identificará correctamente dentro de columnas constantes de grupo en todos los casos. Pero es definitivamente más rápido (y, probablemente, se puede mejorar):

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) 
} 

Mi idea básica era utilizar rle, obviamente.

Answer 4

No estoy seguro de si esto es exactamente lo que está buscando, pero identifica las columnas a y 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 

Answer 5

¿Qué tan rápido falla is.unsorted(x) para no constante x? Lamentablemente, no tengo acceso a R en este momento. También parece que ese no es tu cuello de botella.

Answer 6

un poco más lento de lo Hadley sugirió anteriormente, pero creo que debe manejar el caso de grupos adyacentes iguales

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)) 
} 

La intuición es que si una columna es de GroupWise constante, entonces las roturas en los valores de las columnas (ordenados por el valor del grupo) será un subconjunto de las interrupciones en el valor del grupo.

Ahora, lo comparan con la de Hadley (con pequeñas modificaciones para asegurar n se define)

# 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