Jak spłaszczyć listę do listy bez przymusu?
Próbuję osiągnąć funkcjonalność podobną do unlist, z tym wyjątkiem, że typy nie są zmuszane do wektora, ale zamiast tego zwracana jest lista z zachowanymi typami. Na przykład:
flatten(list(NA, list("TRUE", list(FALSE), 0L))
Should return
list(NA, "TRUE", FALSE, 0L)
Zamiast
c(NA, "TRUE", "FALSE", "0")
, które zostaną zwrócone przez unlist(list(list(NA, list("TRUE", list(FALSE), 0L))
.
Jak widać z powyższego przykładu, spłaszczenie powinno być rekurencyjne. Czy w standardowej bibliotece R istnieje funkcja, która to osiąga, lub przynajmniej jakaś inna funkcja, która czy można go łatwo i efektywnie wdrożyć?
UPDATE: nie wiem, czy jest to jasne z powyższego, ale nie-listy nie powinny być spłaszczone, tzn. flatten(list(1:3, list(4, 5)))
powinny zwracać list(c(1, 2, 3), 4, 5)
.
6 answers
Ciekawy nietrywialny problem!
Główna aktualizacja po tym wszystkim, co się stało, przepisałem odpowiedź i usunąłem kilka ślepych zaułków. Określiłem również różne rozwiązania w różnych przypadkach.
Oto pierwsze, dość proste, ale powolne rozwiązanie:
flatten1 <- function(x) {
y <- list()
rapply(x, function(x) y <<- c(y,x))
y
}
rapply
umożliwia przejście listy i zastosowanie funkcji na każdym elemencie liścia. Niestety, działa dokładnie tak jak unlist
z zwracanymi wartościami. Więc ignoruję wynik z rapply
i zamiast tego dołączam wartości zmiennej {[8] } wykonując <<-
.
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
}
Tutaj najpierw dowiaduję się o długości wyniku i wstępnie przydzielam wektor. Następnie uzupełniam wartości. Jak widać, to rozwiązanie jest dużo szybciej.
Oto wersja @ JoshO świetne rozwiązanie oparte na Reduce
, ale rozszerzone tak, że obsługuje dowolną głębokość:
flatten3 <- function(x) {
repeat {
if(!any(vapply(x, is.list, logical(1)))) return(x)
x <- Reduce(c, x)
}
}
Niech rozpocznie się Bitwa!
# 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
...więc obserwujemy, że Reduce
rozwiązanie jest szybsze, gdy głębokość jest niska, a rapply
rozwiązanie jest szybsze, gdy głębokość jest duża!
Jak poprawność idzie, oto kilka testów:
> 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")
Niejasne, jaki wynik jest pożądany, ale pochylam się do wyniku z flatten2
...
Warning: date(): Invalid date.timezone value 'Europe/Kyiv', we selected the timezone 'UTC' for now. in /var/www/agent_stack/data/www/doraprojects.net/template/agent.layouts/content.php on line 54
2011-11-15 20:18:30
Dla list, które mają tylko kilka zagnieżdżeń, możesz użyć Reduce()
i c()
, aby zrobić coś takiego jak poniżej. Każda aplikacja c()
usuwa jeden poziom zagnieżdżenia. (w pełni ogólne rozwiązanie, zobacz edycje poniżej.)
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 dla Zabawy, oto wersja @Tommy 's wersja @ JoshO' S rozwiązanie, które działa Dla już płaskich list. FURTHER EDIT Now @ Tommy ' s solved that problem as well, but in a cleaner way. Zostawię to. wersja na miejscu.
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"
Warning: date(): Invalid date.timezone value 'Europe/Kyiv', we selected the timezone 'UTC' for now. in /var/www/agent_stack/data/www/doraprojects.net/template/agent.layouts/content.php on line 54
2011-11-15 19:12:46
Co ty na to? Opiera się na rozwiązaniu Josha O ' Briena, ale wykonuje rekursję za pomocą pętli while
zamiast za pomocą unlist
z 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
}
Utrzymanie komentowanej linii daje takie wyniki (które Tommy woli, I ja też, jeśli o to chodzi).
> x <- list(1:3, list(1:3, 'foo'))
> dput(flatten4(x))
list(1:3, 1:3, "foo")
Wyjście z mojego systemu, za pomocą testów Tommy ' ego:
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: jeśli chodzi o uzyskanie głębi listy, może coś takiego zadziała; dostaje indeks dla każdego elementu rekurencyjnie.
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))
}
Nie jest super szybki, ale wydaje się, że działa dobrze.
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
Wyobrażałem sobie, że jest używany w ten sposób:
> x[[ d[[5]] ]]
[1] "leaf"
> x[[ d[[6]] ]]
[1] 1
Ale możesz również obliczyć liczbę węzłów na każdej głębokości.
> 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
Warning: date(): Invalid date.timezone value 'Europe/Kyiv', we selected the timezone 'UTC' for now. in /var/www/agent_stack/data/www/doraprojects.net/template/agent.layouts/content.php on line 54
2011-11-16 02:51:56
edytowane w celu usunięcia wady wskazanej w komentarzach. Niestety, to sprawia, że jest jeszcze mniej wydajny. No cóż.
Inne podejście, chociaż nie jestem pewien, czy będzie bardziej skuteczne niż cokolwiek, co zasugerował @Tommy:
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
Warning: date(): Invalid date.timezone value 'Europe/Kyiv', we selected the timezone 'UTC' for now. in /var/www/agent_stack/data/www/doraprojects.net/template/agent.layouts/content.php on line 54
2011-11-15 22:50:13
purrr::flatten
/ align = "left" / Chociaż nie jest rekurencyjny(z założenia).
Więc zastosowanie go dwa razy powinno zadziałać:
library(purrr)
l <- list(NA, list("TRUE", list(FALSE), 0L))
flatten(flatten(l))
Oto próba wersji rekurencyjnej:
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)
Warning: date(): Invalid date.timezone value 'Europe/Kyiv', we selected the timezone 'UTC' for now. in /var/www/agent_stack/data/www/doraprojects.net/template/agent.layouts/content.php on line 54
2016-10-05 08:55:16
hack_list <- function(.list) {
.list[['_hack']] <- function() NULL
.list <- unlist(.list)
.list$`_hack` <- NULL
.list
}
Warning: date(): Invalid date.timezone value 'Europe/Kyiv', we selected the timezone 'UTC' for now. in /var/www/agent_stack/data/www/doraprojects.net/template/agent.layouts/content.php on line 54
2014-01-30 18:52:36