Como achatar uma lista para uma lista sem coerção?

Eu estou tentando alcançar a funcionalidade semelhante ao unlist, com a exceção de que os tipos não são coagidos para um vetor, mas a lista com tipos preservados é retornada em vez disso. Por exemplo:

flatten(list(NA, list("TRUE", list(FALSE), 0L)) 

deve retornar

 list(NA, "TRUE", FALSE, 0L) 

ao invés de

 c(NA, "TRUE", "FALSE", "0") 

qual seria retornado por unlist(list(list(NA, list("TRUE", list(FALSE), 0L)) .

Como é visto no exemplo acima, o nivelamento deve ser recursivo. Existe uma function na biblioteca padrão R que alcança isso, ou pelo menos alguma outra function que possa ser usada para implementar isso de maneira fácil e eficiente?

UPDATE : Eu não sei se está claro a partir do acima, mas não-listas não devem ser achatadas, ou seja, flatten(list(1:3, list(4, 5))) deve retornar list(c(1, 2, 3), 4, 5) .

Problema não trivial interessante!

MAIOR ATUALIZAÇÃO Com tudo o que aconteceu, reescrevi a resposta e removi alguns becos sem saída. Eu também cronometrei as várias soluções em diferentes casos.

Aqui está a primeira solução bastante simples, mas lenta:

 flatten1 <- function(x) { y <- list() rapply(x, function(x) y <<- c(y,x)) y } 

rapply permite que você percorra uma lista e aplique uma function em cada elemento leaf. Infelizmente, funciona exatamente como unlist com os valores retornados. Então eu ignoro o resultado do rapply e ao invés eu rapply valores à variável y fazendo <<- .

O crescimento desta maneira não é muito eficiente (é quadrático no tempo). Portanto, se houver muitos milhares de elementos, isso será muito lento.

Uma abordagem mais eficiente é a seguinte, com simplificações do @JoshuaUlrich:

 flatten2 <- function(x) { len <- sum(rapply(x, function(x) 1L)) y <- vector('list', len) i <- 0L rapply(x, function(x) { i <<- i+1L; y[[i]] <<- x }) y } 

Aqui eu primeiro descubro o comprimento do resultado e pré-aloco o vetor. Então eu preencho os valores. Como você pode ver, esta solução é muito mais rápida.

Aqui está uma versão de @ JoshO'Brien ótima solução baseada em Reduce , mas estendida para lidar com profundidade arbitrária:

 flatten3 <- function(x) { repeat { if(!any(vapply(x, is.list, logical(1)))) return(x) x <- Reduce(c, x) } } 

Agora deixe a batalha começar!

 # Check correctness on original problem x <- list(NA, list("TRUE", list(FALSE), 0L)) dput( flatten1(x) ) #list(NA, "TRUE", FALSE, 0L) dput( flatten2(x) ) #list(NA, "TRUE", FALSE, 0L) dput( flatten3(x) ) #list(NA_character_, "TRUE", FALSE, 0L) # Time on a huge flat list x <- as.list(1:1e5) #system.time( flatten1(x) ) # Long time system.time( flatten2(x) ) # 0.39 secs system.time( flatten3(x) ) # 0.04 secs # Time on a huge deep list x <-'leaf'; for(i in 1:11) { x <- list(left=x, right=x, value=i) } #system.time( flatten1(x) ) # Long time system.time( flatten2(x) ) # 0.05 secs system.time( flatten3(x) ) # 1.28 secs 

... Então, o que observamos é que a solução Reduce é mais rápida quando a profundidade é baixa, e a solução de rapidez é mais rápida quando a profundidade é grande!

Como correção, aqui estão alguns testes:

 > dput(flatten1( list(1:3, list(1:3, 'foo')) )) list(1L, 2L, 3L, 1L, 2L, 3L, "foo") > dput(flatten2( list(1:3, list(1:3, 'foo')) )) list(1:3, 1:3, "foo") > dput(flatten3( list(1:3, list(1:3, 'foo')) )) list(1L, 2L, 3L, 1:3, "foo") 

Não está claro qual resultado é desejado, mas eu me inclino para o resultado de flatten2 ...

Para listas com apenas alguns aninhamentos profundos, você pode usar Reduce() e c() para fazer algo como o seguinte. Cada aplicativo de c() remove um nível de aninhamento. (Para uma solução totalmente geral, consulte EDITs abaixo.)

 L <- (list(NA, list("TRUE", list(FALSE), 0L))) Reduce(c, Reduce(c, L)) [[1]] [1] NA [[2]] [1] "TRUE" [[3]] [1] FALSE [[4]] [1] 0 # TIMING TEST x <- as.list(1:4e3) system.time(flatten(x)) # Using the improved version # user system elapsed # 0.14 0.00 0.13 system.time(Reduce(c, x)) # user system elapsed # 0.04 0.00 0.03 

EDIT Apenas por diversão, aqui está uma versão da versão do @ Tommy da solução do @ JoshO'Brien que funciona para listas já planas. EDITAR MAIS Agora, a Tommy resolveu esse problema também, mas de uma maneira mais limpa. Vou deixar esta versão no lugar.

 flatten <- function(x) { x <- list(x) repeat { x <- Reduce(c, x) if(!any(vapply(x, is.list, logical(1)))) return(x) } } flatten(list(3, TRUE, 'foo')) # [[1]] # [1] 3 # # [[2]] # [1] TRUE # # [[3]] # [1] "foo" 

Que tal agora? Ele constrói a solução de Josh O’Brien, mas faz a recursion com um loop while usando unlist with recursive=FALSE .

 flatten4 <- function(x) { while(any(vapply(x, is.list, logical(1)))) { # this next line gives behavior like Tommy's answer; # removing it gives behavior like Josh's x <- lapply(x, function(x) if(is.list(x)) x else list(x)) x <- unlist(x, recursive=FALSE) } x } 

Manter a linha comentada dá resultados como esse (que Tommy prefere, e eu também).

 > x <- list(1:3, list(1:3, 'foo')) > dput(flatten4(x)) list(1:3, 1:3, "foo") 

Saída do meu sistema, usando os testes do Tommy:

 dput(flatten4(foo)) #list(NA, "TRUE", FALSE, 0L) # Time on a long x <- as.list(1:1e5) system.time( x2 <- flatten2(x) ) # 0.48 secs system.time( x3 <- flatten3(x) ) # 0.07 secs system.time( x4 <- flatten4(x) ) # 0.07 secs identical(x2, x4) # TRUE identical(x3, x4) # TRUE # Time on a huge deep list x <-'leaf'; for(i in 1:11) { x <- list(left=x, right=x, value=i) } system.time( x2 <- flatten2(x) ) # 0.05 secs system.time( x3 <- flatten3(x) ) # 1.45 secs system.time( x4 <- flatten4(x) ) # 0.03 secs identical(x2, unname(x4)) # TRUE identical(unname(x3), unname(x4)) # TRUE 

EDIT: Como para obter a profundidade de uma lista, talvez algo como isso funcionaria; ele obtém o índice para cada elemento recursivamente.

 depth <- function(x) { foo <- function(x, i=NULL) { if(is.list(x)) { lapply(seq_along(x), function(xi) foo(x[[xi]], c(i,xi))) } else { i } } flatten4(foo(x)) } 

Não é super rápido, mas parece funcionar bem.

 x <- as.list(1:1e5) system.time(d <- depth(x)) # 0.327 s x <-'leaf'; for(i in 1:11) { x <- list(left=x, right=x, value=i) } system.time(d <- depth(x)) # 0.041s 

Eu imaginava que fosse usado dessa maneira:

 > x[[ d[[5]] ]] [1] "leaf" > x[[ d[[6]] ]] [1] 1 

Mas você também pode contar quantos nós estão em cada profundidade também.

 > table(sapply(d, length)) 1 2 3 4 5 6 7 8 9 10 11 1 2 4 8 16 32 64 128 256 512 3072 

Editado para resolver uma falha apontada nos comentários. Infelizmente, isso apenas torna ainda menos eficiente. Ah bem.

Outra abordagem, embora eu não tenha certeza de que será mais eficiente do que qualquer coisa que @ Tommy sugeriu:

 l <- list(NA, list("TRUE", list(FALSE), 0L)) flatten <- function(x){ obj <- rapply(x,identity,how = "unlist") cl <- rapply(x,class,how = "unlist") len <- rapply(x,length,how = "unlist") cl <- rep(cl,times = len) mapply(function(obj,cl){rs <- as(obj,cl); rs}, obj, cl, SIMPLIFY = FALSE, USE.NAMES = FALSE) } > flatten(l) [[1]] [1] NA [[2]] [1] "TRUE" [[3]] [1] FALSE [[4]] [1] 0 

purrr::flatten consegue isso. Embora não seja recursivo (por design).

Então, aplicá-lo duas vezes deve funcionar:

 library(purrr) l <- list(NA, list("TRUE", list(FALSE), 0L)) flatten(flatten(l)) 

Aqui está uma tentativa de uma versão recursiva:

 flatten_recursive <- function(x) { stopifnot(is.list(x)) if (any(vapply(x, is.list, logical(1)))) Recall(purrr::flatten(x)) else x } flatten_recursive(l) 
 hack_list <- function(.list) { .list[['_hack']] <- function() NULL .list <- unlist(.list) .list$`_hack` <- NULL .list } 
Intereting Posts