Qual é a base equivalente a rlang :: flatten ()?

Question

Digamos que eu tenha uma lista aninhada

tmp <- list(
  a = 1,
  list(list(x = 1, y = "a"), list(z = 2)),
  mtcars[1:3, ],
  list(mtcars[4:6, ], mtcars[7:10, ])
)

Eu quero replicar o que rlang::flatten()faz.

> rlang::flatten(tmp)
$a [1] 1 [[2]] [[2]]$x
[1] 1

[[2]]$y [1] "a" [[3]] [[3]]$z
[1] 2


[[4]]
               mpg cyl disp  hp drat    wt  qsec vs am gear carb
Mazda RX4     21.0   6  160 110 3.90 2.620 16.46  0  1    4    4
Mazda RX4 Wag 21.0   6  160 110 3.90 2.875 17.02  0  1    4    4
Datsun 710    22.8   4  108  93 3.85 2.320 18.61  1  1    4    1

[[5]]
                   mpg cyl disp  hp drat    wt  qsec vs am gear carb
Hornet 4 Drive    21.4   6  258 110 3.08 3.215 19.44  1  0    3    1
Hornet Sportabout 18.7   8  360 175 3.15 3.440 17.02  0  0    3    2
Valiant           18.1   6  225 105 2.76 3.460 20.22  1  0    3    1

[[6]]
            mpg cyl  disp  hp drat   wt  qsec vs am gear carb
Duster 360 14.3   8 360.0 245 3.21 3.57 15.84  0  0    3    4
Merc 240D  24.4   4 146.7  62 3.69 3.19 20.00  1  0    4    2
Merc 230   22.8   4 140.8  95 3.92 3.15 22.90  1  0    4    2
Merc 280   19.2   6 167.6 123 3.92 3.44 18.30  1  0    4    4

ou seja, quero elevar tudo um nível. Reduce(c, tmp)quase me leva lá, mas não exatamente.

Answer 1

Parece que esta função faz o que eu preciso

flatten <- function(lst) {
  nested <- vapply(lst, function(x) inherits(x[1L], "list"), FALSE)
  res <- c(lst[!nested], unlist(lst[nested], recursive = FALSE))
  if (sum(nested)) Recall(res) else return(res)
}

Answer 2

Não tenho certeza se isso vale para todos os casos, mas uma abordagem mais simples seria usar unlist(tmp, recursive = FALSE).

library(purrr)

tmp <- list(
  a = 1,
  list(list(x = 1, y = "a"), list(z = 2)),
  mtcars[1:3, ],
  list(mtcars[4:6, ], mtcars[7:10, ])
)

unlist(tmp, recursive = FALSE)
#> $a #> [1] 1 #> #> [[2]] #> [[2]]$x
#> [1] 1
#> 
#> [[2]]$y #> [1] "a" #> #> #> [[3]] #> [[3]]$z
#> [1] 2
#> 
#> 
#> $mpg #> [1] 21.0 21.0 22.8 #> #> $cyl
#> [1] 6 6 4
#> 
#> $disp #> [1] 160 160 108 #> #> $hp
#> [1] 110 110  93
#> 
#> $drat #> [1] 3.90 3.90 3.85 #> #> $wt
#> [1] 2.620 2.875 2.320
#> 
#> $qsec #> [1] 16.46 17.02 18.61 #> #> $vs
#> [1] 0 0 1
#> 
#> $am #> [1] 1 1 1 #> #> $gear
#> [1] 4 4 4
#> 
#> $carb
#> [1] 4 4 1
#> 
#> [[15]]
#>                    mpg cyl disp  hp drat    wt  qsec vs am gear carb
#> Hornet 4 Drive    21.4   6  258 110 3.08 3.215 19.44  1  0    3    1
#> Hornet Sportabout 18.7   8  360 175 3.15 3.440 17.02  0  0    3    2
#> Valiant           18.1   6  225 105 2.76 3.460 20.22  1  0    3    1
#> 
#> [[16]]
#>             mpg cyl  disp  hp drat   wt  qsec vs am gear carb
#> Duster 360 14.3   8 360.0 245 3.21 3.57 15.84  0  0    3    4
#> Merc 240D  24.4   4 146.7  62 3.69 3.19 20.00  1  0    4    2
#> Merc 230   22.8   4 140.8  95 3.92 3.15 22.90  1  0    4    2
#> Merc 280   19.2   6 167.6 123 3.92 3.44 18.30  1  0    4    4

identical(unlist(tmp, recursive = FALSE),
          flatten(tmp))
#> [1] TRUE

^{Criado em 03/10/2020 pelo pacote reprex (v0.3.0)}

Abaixo defini sua função como flatten2.

Aqui estão alguns casos extremos para pensar:

1. a entrada é listde profundidade 1 com uma exceção.
   Aqui flatten2está misturando a ordem.
2. a entrada é um listde profundidade 1
   Aqui unlistretorna um vetor, enquanto as duas flattenfunções retornam a lista como está. Precisaríamos de algum tipo de verificação aqui para evitar unlisttrabalhar em listas de profundidade 1.
3. entrada é simples data.frame.
   Aqui, todas as três funções retornam um valor diferente: flattenretorna cada célula como o elemento de um (longo) list. flatten2retorna o data.frameas list, cada coluna sendo um elemento da lista e unlistretorna um vector.

No final, depende de quanto você deseja imitar o comportamento flattene o que é mais fácil de se adaptar flatten2ou unlist(recursive = FALSE).

library(purrr)

flatten2 <- function(lst) {
  nested <- vapply(lst, function(x) inherits(x[1L], "list"), FALSE)
  res <- c(lst[!nested], unlist(lst[nested], recursive = FALSE))
  if (sum(nested)) Recall(res) else return(res)
}

tmp2 <- list(a = 1, b = list(y = 10, x = 20), c = 3)
tmp3 <- list(a = 1, b = 1, c = 3)

tmp2 %>% flatten %>% str
#> List of 4
#>  $ a: num 1
#>  $ y: num 10 #> $ x: num 20
#>  $ c: num 3 tmp2 %>% flatten2 %>% str #> List of 4 #> $ a  : num 1
#>  $ c : num 3 #> $ b.y: num 10
#>  $ b.x: num 20 tmp2 %>% unlist(recursive = FALSE) %>% str #> List of 4 #> $ a  : num 1
#>  $ b.y: num 10 #> $ b.x: num 20
#>  $ c : num 3 tmp3 %>% flatten %>% str #> List of 3 #> $ a: num 1
#>  $ b: num 1 #> $ c: num 3
tmp3 %>% flatten2 %>% str
#> List of 3
#>  $ a: num 1 #> $ b: num 1
#>  $ c: num 3 tmp3 %>% unlist(recursive = FALSE) %>% str #> Named num [1:3] 1 1 3 #> - attr(*, "names")= chr [1:3] "a" "b" "c" mtcars %>% head(2) %>% flatten %>% str #> List of 22 #> $ : num 21
#>  $ : num 21 #> $ : num 6
#>  $ : num 6 #> $ : num 160
#>  $ : num 160 #> $ : num 110
#>  $ : num 110 #> $ : num 3.9
#>  $ : num 3.9 #> $ : num 2.62
#>  $ : num 2.88 #> $ : num 16.5
#>  $ : num 17 #> $ : num 0
#>  $ : num 0 #> $ : num 1
#>  $ : num 1 #> $ : num 4
#>  $ : num 4 #> $ : num 4
#>  $ : num 4 mtcars %>% head(2) %>% flatten2 %>% str #> List of 11 #> $ mpg : num [1:2] 21 21
#>  $ cyl : num [1:2] 6 6 #> $ disp: num [1:2] 160 160
#>  $ hp : num [1:2] 110 110 #> $ drat: num [1:2] 3.9 3.9
#>  $ wt : num [1:2] 2.62 2.88 #> $ qsec: num [1:2] 16.5 17
#>  $ vs : num [1:2] 0 0 #> $ am  : num [1:2] 1 1
#>  $ gear: num [1:2] 4 4 #> $ carb: num [1:2] 4 4
mtcars %>% head(2) %>% unlist(recursive = FALSE) %>% str
#>  Named num [1:22] 21 21 6 6 160 160 110 110 3.9 3.9 ...
#>  - attr(*, "names")= chr [1:22] "mpg1" "mpg2" "cyl1" "cyl2" ...

^{Criado em 03/10/2020 pelo pacote reprex (v0.3.0)}

---

update

Depois de considerar os casos extremos acima, poderíamos definir unlist_oncecom a ajuda de uma versão base de R vec_depthaqui chamada check_depth. A nomenclatura dos elementos da lista ainda é um pouco diferente.

library(purrr)

tmp <- list(
  a = 1,
  list(list(x = 1, y = "a"), list(z = 2)),
  mtcars[1:3, ],
  list(mtcars[4:6, ], mtcars[7:10, ])
)

tmp2 <- list(a = 1, b = list(y = 10, x = 20), c = 3)
tmp3 <- list(a = 1, b = 1, c = 3)
tmp4 <- head(mtcars, 2)

check_depth <- function (x) 
{
  if (is_null(x)) {
    0L
  }
  else if (is.atomic(x)) {
    1L
  }
  else if (is.list(x)) {
    depths <- as.integer(unlist(lapply(x, check_depth)))
    1L + max(depths, 0L)
  }
  else {
    stop("`x` must be a vector")
  }
}

unlist_once <- function(x) {
  
  if (is.data.frame(x)) {
    return(lapply(unname(unlist(x)), function(x) c(x)))
  } else if (check_depth(x) <= 2L) {
    return(x)
  } else {
    unlist(x, recursive = FALSE)
    }
}

identical(flatten(tmp), unlist_once(tmp))
#> [1] TRUE
# in the case of tmp2 the list names are slightly different
identical(flatten(tmp2), unlist_once(tmp2)) 
#> [1] FALSE
identical(flatten(tmp3), unlist_once(tmp3))
#> [1] TRUE
identical(flatten(tmp4), unlist_once(tmp4))
#> [1] TRUE

^{Criado em 03/10/2020 pelo pacote reprex (v0.3.0)}