What is the base equivalent of rlang::flatten()?

Viewed 117

Say I have a nested list

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

I want to replicate what rlang::flatten() does.

> 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

i.e. I want to bring everything up one level. Reduce(c, tmp) almost gets me there but not quite.

2 Answers

It would seem as though this function does what I need

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

Not sure if it holds for all cases, but a simpler approach would be to use 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

Created on 2020-10-03 by the reprex package (v0.3.0)

Below I defined your function as flatten2.

Here are some edge cases to think about:

  1. input is a list of depth 1 with one exception
    Here flatten2 is mixing up the ordering.
  2. input is a list of depth 1
    Here unlist returns a vector, whereas the two flatten functions return the list as is. We would need some kind of check here to prevent unlist to work on lists of depth 1.
  3. input is a simple data.frame.
    Here all three functions return a different value: flatten returns each cell as the element of one (long) list. flatten2 returns the data.frame as list, each column being one list element and unlist returns one vector.

In the end it depends on how much you want to mimic the behavior of flatten and what is easier to adapt flatten2 or 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" ...

Created on 2020-10-03 by the reprex package (v0.3.0)


update

After accounting for the edge cases above we could define unlist_once with the help of a base R version of vec_depth here called check_depth. The naming of the list elements still slightly differs.

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

Created on 2020-10-03 by the reprex package (v0.3.0)

Related