Как сгладить список в список без принуждения?

Question

Я пытаюсь добиться функциональности, аналогичной unlist, за исключением того, что типы не приводятся к вектору, а вместо этого возвращается список с сохраненными типами. Например:

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

должен вернуть

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

вместо

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

, который будет возвращен unlist(list(list(NA, list("TRUE", list(FALSE), 0L)).

Как видно из приведенного выше примера, выравнивание должно быть рекурсивным. Есть ли в стандартной библиотеке R функция, которая достигает этого, или, по крайней мере, какая-то другая функция, которую можно использовать для простой и эффективной реализации этого?

ОБНОВЛЕНИЕ : Я не знаю, ясно ли это из вышесказанного, но не-списки не должны быть сплющены, т.е. flatten(list(1:3, list(4, 5))) должен возвращать list(c(1, 2, 3), 4, 5).

Answer 1

Интересная нетривиальная задача!

ОСНОВНОЕ ОБНОВЛЕНИЕ Со всем, что случилось, я переписал ответ и удалил некоторые тупики. Я также рассчитал различные решения для разных случаев.

Вот первое, довольно простое, но медленное решение:

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

rapply позволяет просматривать список и применять функцию к каждому элементу листа. К сожалению, он работает точно как unlist с возвращенными значениями. Поэтому я игнорирую результат из rapply и вместо этого добавляю значения к переменной y, выполняя <<-.

Рост y таким способом не очень эффективен (он квадратичен во времени). Так что, если будет много тысяч элементов, это будет очень медленно.

Более эффективный подход следующий, с упрощениями из @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
}

Здесь я сначала выясняю длину результата и предварительно выделяю вектор. Затем я заполняю значения. Как вы можете видеть, это решение на 1023 * намного быстрее.

Вот версия отличного решения @ JoshO'Brien, основанного на Reduce, но расширенного, так что он обрабатывает произвольную глубину:

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

Теперь пусть битва начнется!

# 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

... Итак, мы наблюдаем, что решение Reduce быстрее при небольшой глубине, а решение rapply быстрее при большой глубине!

Что касается правильности, вот несколько тестов:

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

Непонятно, какой результат желателен, но я склоняюсь к результату из flatten2 ...

Answer 2

Для списков, которые имеют только несколько вложений, вы можете использовать Reduce() и c(), чтобы сделать что-то вроде следующего.Каждое приложение c() удаляет один уровень вложенности. (Полное общее решение см. В разделе РЕДАКТИРОВАТЬ ниже.)

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 

РЕДАКТИРОВАТЬ Просто для удовольствия, вот версия @ Tommy's версии решения @ JoshO'Brienчто действительно работает для уже плоских списков. ДАЛЬНЕЙШЕЕ РЕДАКТИРОВАНИЕ Теперь @ Томми тоже решил эту проблему, но более чистым способом.Я оставлю эту версию на месте.

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"

Answer 3

Как насчет этого? Он основан на решении Джоша О'Брайена, но выполняет рекурсию с циклом while вместо использования unlist с 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
}

Сохранение закомментированной строки дает такие результаты (что Томми предпочитает, и я тоже, если на то пошло).

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

Вывод из моей системы с использованием тестов Томми:

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

РЕДАКТИРОВАТЬ: Что касается получения глубины списка, может быть, что-то вроде этого будет работать; он получает индекс для каждого элемента рекурсивно.

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

Это не супер быстро, но, кажется, работает нормально.

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

Я представлял, как его используют таким образом:

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

Но вы также можете подсчитать количество узлов на каждой глубине.

> 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 

Answer 4

Отредактировано для устранения недостатка, указанного в комментариях.К сожалению, это просто делает его еще менее эффективным.Ах, хорошо.

Другой подход, хотя я не уверен, что он будет более эффективным, чем то, что предложил @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

Answer 5

purrr::flatten достигает этого.Хотя он не является рекурсивным (по замыслу).

Таким образом, применение его дважды должно работать:

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

Вот попытка рекурсивной версии:

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)

Answer 6

hack_list <- function(.list) {
  .list[['_hack']] <- function() NULL
  .list <- unlist(.list)
  .list$`_hack` <- NULL
  .list
}