Base fallback for cast-common

[lionel-]

From #1111 (comment):

library(rlang)
library(purrr)

# Obtain ptypes with `x[0]` and concatenate them to find the common ptype
base_ptype_common <- function(...) {
  # Would first check for common class and throw incompatible type
  # error otherwise
  ptypes <- map(list2(...), `[`, 0L)
  exec("c", !!!ptypes)
}

# Concatenate inputs with ptype in first location. This causes a
# coercion of the inputs to a common type. Slice the result and return
# list of coerced vectors of the same sizes as the inputs.
base_cast_common <- function(..., .ptype = NULL) {
  dots <- list2(...)

  if (is.null(.ptype)) {
    .ptype <- base_ptype_common(!!!dots)
  }
  common <- exec("c", .ptype, !!!dots)

  sizes <- lengths(dots)
  locs <- reduce(sizes, .init = list(0), function(output, input) {
    n <- last(last(output))
    c(output, list(seq(n + 1, n + input)))
  })
  locs <- locs[-1]

  map(locs, function(loc) common[loc])
}
last <- function(x) {
  x[[length(x)]]
}

Works well with units:

(x <- units::set_units(1:2, "m/s"))
#> Units: [m/s]
#> [1] 1 2
(y <- units::set_units(3, "km/s"))
#> 3 [km/s]

base_ptype_common(x, y)
#>  [m/s]

base_cast_common(x, y)
#> [[1]]
#> Units: [m/s]
#> [1] 1 2
#>
#> [[2]]
#> 3000 [m/s]

For sf this is a bit funny though, because [ isn't type-stable. The result is downcasted to a more specific class if possible. The common type of different sfc subclasses is normally an abstract sfc_GEOMETRY, :

sfc_x <- sf::st_sfc(sf::st_point())
sfc_y <- sf::st_sfc(sf::st_multipoint(), sf::st_multipoint())

base_ptype_common(sfc_x, sfc_y)
#> Geometry set for 0 features
#> bbox:           xmin: NA ymin: NA xmax: NA ymax: NA
#> CRS:            NA

class(base_ptype_common(sfc_x, sfc_y))
#> [1] "sfc_GEOMETRY" "sfc"

However the inputs are being coerced back and forth and end up unchanged:

base_cast_common(sfc_x, sfc_y)
#> [[1]]
#> Geometry set for 1 feature  (with 1 geometry empty)
#> geometry type:  POINT
#> dimension:      XY
#> bbox:           xmin: NA ymin: NA xmax: NA ymax: NA
#> CRS:            NA
#> POINT EMPTY
#>
#> [[2]]
#> Geometry set for 2 features  (with 2 geometries empty)
#> geometry type:  MULTIPOINT
#> dimension:      XY
#> bbox:           xmin: NA ymin: NA xmax: NA ymax: NA
#> CRS:            NA
#> MULTIPOINT EMPTY
#> MULTIPOINT EMPTY

[lionel-]

Posting this here as it's remotely connected: tidyverse/dplyr#5296 (comment)

[lionel-]

Another example where the fallback sentinel for base::c() gets in the way tidyverse/purrr#770

[lionel-]

That's an interesting approach but we don't want to push the fallback mechanisms too far.