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

Я пытаюсь реализовать функциональность, подобную 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, которая достигает этого, или, по крайней мере, какая-то другая функция, которую можно легко и эффективно реализовать?

UPDATE: я не знаю, ясно ли из приведенного выше, но не-списки не должны быть сплющены, т.е. flatten(list(1:3, list(4, 5))) должен возвращать list(c(1, 2, 3), 4, 5).

ОТВЕТЫ

Ответ 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
}

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

Здесь версия отличного решения @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...

Ответ 2

Для списков, содержащих только несколько вложений, вы можете использовать Reduce() и c(), чтобы сделать что-то вроде следующего. Каждое приложение c() удаляет один уровень вложенности. (Полностью общее решение см. в разделе EDIT ниже.)

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 Просто для удовольствия, здесь версия @Tommy версии @JoshO'Brien, которая работает для уже плоских списков. ДАЛЬНЕЙШЕЕ ИЗОБРАЖЕНИЕ Теперь @Tommy также решила эту проблему, но более чистым способом. Я оставлю эту версию на месте.

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"

Ответ 3

Как насчет этого? Он строит решение Джоша О'Брайена, но рекурсия с циклом while вместо этого использует unlist с recursive=FALSE.

flatten4 <- function(x) {
  while(any(vapply(x, is.list, logical(1)))) { 
    # this next line gives behavior like Tommy 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")

Выход из моей системы, используя тесты 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: Что касается получения глубины списка, возможно, что-то вроде этого будет работать; он получает индекс для каждого элемента рекурсивно.

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

Ответ 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

Ответ 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)

Ответ 6

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