R/spec_combine.R

In tibblify: Rectangle Nested Lists

#' Combine multiple specifications
#'
#' Combine specifications created by [tspec_df()], [tspec_row()], or
#' [tspec_object()]. The resulting specification includes all fields from the
#' input specifications.
#'
#' If a field is specified in multiple input specifications, the field
#' specifications will be combined to produce a single field specification,
#' using the most specific specification for each argument. See the examples for
#' details.
#'
#' @param ... (`tspec`) Specifications to combine.
#'
#' @returns A tibblify specification.
#' @export
#'
#' @examples
#' # union of fields
#' tspec_combine(
#'   tspec_df(tib_int("a")),
#'   tspec_df(tib_chr("b"))
#' )
#'
#' # unspecified + x -> x
#' tspec_combine(
#'   tspec_df(tib_unspecified("a")),
#'   tspec_df(tib_int("a"))
#' )
#'
#' # scalar + vector -> vector
#' tspec_combine(
#'   tspec_df(tib_chr("a")),
#'   tspec_df(tib_chr_vec("a"))
#' )
#'
#' # scalar/vector + variant -> variant
#' tspec_combine(
#'   tspec_df(tib_chr("a")),
#'   tspec_df(tib_chr_vec("a")),
#'   tspec_df(tib_variant("a"))
#' )
tspec_combine <- function(...) {
  spec_list <- .check_tspec_combine_dots(...)
  type <- .check_tspec_combine_type(spec_list)
  fields <- .tspec_combine_field_list(spec_list, .call = rlang::current_env())

  if (type == "row") {
    return(tspec_row(!!!fields))
  } else if (type == "object") {
    return(tspec_object(!!!fields))
  } else if (type == "df") {
    # TODO input_form, vector_allows_empty_list
    names_to <- .tib_combine_names_col(spec_list, rlang::current_env())

    return(tspec_df(!!!fields, .names_to = names_to))
  }

  cli::cli_abort("Unknown spec type", .internal = TRUE)
}

# helpers ----------------------------------------------------------------------

#' Format location names and types
#'
#' @param locs (`integer`) Locations of the elements.
#' @param types (`character`) Types of those elements.
#' @returns (`character`) Dot-prefixed location names and types.
#' @keywords internal
.loc_name_helper <- function(locs, types) {
  types <- types[locs]
  nms <- paste0("`..", locs, "`")
  paste0(nms, " <", types, ">")
}

# checks -----------------------------------------------------------------------

#' Check dots arguments for tspec combine
#'
#' @param ... Specifications to combine.
#' @inheritParams .shared-params
#' @returns (`list`) A list of specifications.
#' @keywords internal
.check_tspec_combine_dots <- function(..., .call = caller_env()) {
  spec_list <- rlang::list2(...)
  bad_idx <- purrr::detect_index(spec_list, ~ !.is_tspec(.x))
  if (bad_idx != 0) {
    cls1 <- class(spec_list[[bad_idx]])[[1]]
    cli::cli_abort(
      c(
        "Every element of {.arg ...} must be a tibblify spec.",
        x = "Element {bad_idx} has class {.cls {cls1}}."
      ),
      call = .call
    )
  }
  spec_list
}

#' Check spec types for compatibility
#'
#' @inheritParams .shared-params
#' @returns (`character(1)`) The type of the specifications.
#' @keywords internal
.check_tspec_combine_type <- function(spec_list, .call = caller_env()) {
  types <- .compat_map_chr(spec_list, "type")
  type_locs <- vctrs::vec_unique_loc(types)
  if (length(type_locs) > 1) {
    type_infos <- .loc_name_helper(type_locs, types)
    cli::cli_abort("Can't combine specs {type_infos}", call = .call)
  }
  types[[type_locs]]
}

# fields -----------------------------------------------------------------------

#' Combine fields from a list of specs
#'
#' @inheritParams .shared-params
#' @returns (`list`) A list of combined fields generated by [.tib_combine()].
#' @keywords internal
.tspec_combine_field_list <- function(spec_list, .call) {
  fields_list <- purrr::map(spec_list, "fields")
  empty_idx <- lengths(fields_list) == 0
  nms_list <- purrr::map(fields_list, function(x) names(x))
  nms <- vctrs::vec_unique(.vec_flatten(nms_list, character()))
  fields_list_t <- purrr::list_transpose(
    fields_list[!empty_idx],
    template = nms
  )

  out <- purrr::imap(fields_list_t, ~ .tib_combine(.x, .y, .call))
  if (any(empty_idx)) {
    for (i in seq_along(out)) {
      out[[i]]$required <- FALSE
    }
  }

  out
}

#' Combine a list of tib fields
#'
#' @inheritParams .shared-params
#' @returns (`tib_collector`) A combined tibblify field collector.
#' @keywords internal
.tib_combine <- function(tib_list, name, .call) {
  required <- .tib_combine_required(tib_list)

  # `required` needs to be calculated before removing empty
  tib_list <- tib_list[lengths(tib_list) > 0]
  type <- .tib_combine_type(tib_list, .call)
  key <- .tib_combine_key(tib_list, name, .call)

  switch(
    type,
    unspecified = tib_unspecified(key, .required = required),
    row = ,
    df = .tib_combine_df(tib_list, type, key, required, .call),
    .tib_combine_specified(tib_list, type, key, required, .call)
  )
}

#' Combine dataframe tib fields
#'
#' @param type (`character(1)`) The target tib type ("row" or "df").
#' @param key (`character(1)`) The key of the field.
#' @param required (`logical(1)`) Whether the field is required.
#' @inheritParams .shared-params
#' @returns (`tib_row` or `tib_df`) A tibblify dataframe field collector.
#' @keywords internal
.tib_combine_df <- function(tib_list, type, key, required, .call) {
  fields <- .tspec_combine_field_list(tib_list, .call)

  if (type == "row") {
    tib_row(key, !!!fields, .required = required)
  } else {
    names_col <- .tib_combine_names_col(tib_list, .call)
    tib_df(key, !!!fields, .required = required, .names_to = names_col)
  }
}

#' Combine various specified tib field types
#'
#' @param type (`character(1)`) The target tib type ("variant", "scalar", or
#'   "vector").
#' @inheritParams .tib_combine_df
#' @inheritParams .shared-params
#' @returns (`tib_variant`, `tib_scalar`, or `tib_vector`) A tibblify field
#'   collector.
#' @keywords internal
.tib_combine_specified <- function(tib_list, type, key, required, .call) {
  ptype <- .tib_combine_ptype(tib_list, .call)
  fill <- .tib_combine_fill(tib_list, type, ptype, .call)
  transform <- .tib_combine_transform(tib_list, .call)
  switch(
    type,
    variant = tib_variant(
      key,
      .required = required,
      .fill = fill,
      .transform = transform
    ),
    scalar = tib_scalar(
      key,
      ptype,
      .required = required,
      .fill = fill,
      .transform = transform
    ),
    vector = .tib_combine_vector(
      tib_list,
      key,
      ptype,
      required,
      fill,
      transform,
      .call
    ),
    cli::cli_abort("Unknown tib type", .internal = TRUE, call = .call)
  )
}

#' Combine vector tib fields
#'
#' @param ptype (`vector(0)`) The target ptype.
#' @param fill (`vector`) The fill value.
#' @param transform (`function` or `NULL`) The transform function.
#' @inheritParams .tib_combine_df
#' @inheritParams .shared-params
#' @returns (`tib_vector`) A tibblify vector field collector.
#' @keywords internal
.tib_combine_vector <- function(
  tib_list,
  key,
  ptype,
  required,
  fill,
  transform,
  .call
) {
  tib_vector(
    key,
    ptype,
    .required = required,
    .fill = fill,
    .transform = transform,
    .input_form = .tib_combine_input_form(tib_list, .call)
  )
}

# args -------------------------------------------------------------------------

#' Combine types from a list of tibs
#'
#' @inheritParams .shared-params
#' @returns (`character(1)`) The combined tib type.
#' @keywords internal
.tib_combine_type <- function(tib_list, .call) {
  types <- .compat_map_chr(tib_list, "type")
  locs <- vctrs::vec_unique_loc(types)
  types <- types[locs]
  unspecified_idx <- types == "unspecified"
  types <- types[!unspecified_idx]
  locs <- locs[!unspecified_idx]

  if (length(types) == 0) {
    return("unspecified")
  }

  if (length(types) == 1) {
    return(types)
  }

  if (all(types %in% c("scalar", "vector"))) {
    return("vector")
  }

  if (all(types %in% c("scalar", "vector", "variant"))) {
    return("variant")
  }

  # TODO error message should include path...
  type_infos <- .loc_name_helper(locs, types)
  cli::cli_abort("Can't combine tibs {type_infos}", call = .call)
}

#' Combine keys from a list of tibs
#'
#' @param name (`character(1)`) The name of the field.
#' @inheritParams .shared-params
#' @returns (`character(1)`) The combined key.
#' @keywords internal
.tib_combine_key <- function(tib_list, name, .call) {
  key_list <- purrr::map(tib_list, "key")
  key_locs <- vctrs::vec_unique_loc(key_list)

  if (length(key_locs) > 1) {
    # TODO error message should mention spec path (or at least name)
    keys <- key_list[key_locs]
    cli::cli_abort("Cannot combine tibs of different keys {keys}", call = .call)
  }

  key_list[[1]]
}

#' Combine required status from a list of tibs
#'
#' @inheritParams .shared-params
#' @returns (`logical(1)`) The combined required status.
#' @keywords internal
.tib_combine_required <- function(tib_list) {
  null_idx <- purrr::detect_index(tib_list, function(x) is.null(x))
  if (null_idx != 0) {
    return(FALSE)
  }

  # faster alternative to `all(map_lgl())`
  false_idx <- purrr::detect_index(tib_list, ~ !.x[["required"]])
  false_idx == 0
}

#' Combine ptypes from a list of tibs
#'
#' @inheritParams .shared-params
#' @returns (`vector(0)`) The combined ptype.
#' @keywords internal
.tib_combine_ptype <- function(tib_list, .call) {
  ptype_list <- lapply(tib_list, `[[`, "ptype")
  # TODO better error message
  rlang::try_fetch(
    vctrs::vec_ptype_common(!!!ptype_list, .call = .call),
    vctrs_error_incompatible_type = function(cnd) {
      x_arg <- cnd$x_arg
      y_arg <- cnd$y_arg
      x_type <- vctrs::vec_ptype_full(cnd$x)
      y_type <- vctrs::vec_ptype_full(cnd$y)

      cli::cli_abort(
        "Can't combine tibs with ptype {x_arg} <{x_type}> and {y_arg} <{y_type}>.",
        call = .call
      )
    }
  )
}

#' Combine fill values from a list of tibs
#'
#' @param type (`character(1)`) The target tib type (scalar, vector, etc.).
#' @param ptype (`vector(0)`) The target ptype.
#' @inheritParams .shared-params
#' @returns (`vector`) The combined fill value.
#' @keywords internal
.tib_combine_fill <- function(tib_list, type, ptype, .call) {
  types <- .compat_map_chr(tib_list, "type")
  unspecified_locs <- which(types == "unspecified")

  fill_list <- lapply(tib_list, `[[`, "fill")

  if (type == "scalar") {
    fill_locs <- vctrs::vec_unique_loc(fill_list)
    fill_locs <- fill_locs[!fill_locs %in% unspecified_locs]
    fill_list <- fill_list[fill_locs]

    fill_list_cast <- lapply(fill_list, vctrs::vec_cast, ptype)
    fill_locs2 <- vctrs::vec_unique_loc(fill_list_cast)
    fill_list_cast <- fill_list_cast[fill_locs2]
    fill_locs <- fill_locs[fill_locs2]

    if (length(fill_locs2) > 1) {
      # TODO better error message
      values <- .compat_map_chr(fill_list_cast, as_label)
      value_infos <- .loc_name_helper(fill_locs2, values)
      cli::cli_abort("Can't combine fill {value_infos}", call = .call)
    }

    return(vctrs::vec_cast(fill_list_cast[[1]], ptype))
  }

  scalar_idx <- types == "scalar"
  scalar_fill <- vctrs::vec_c(!!!fill_list[scalar_idx], .ptype = ptype)
  scalar_na_idx <- vctrs::vec_detect_missing(scalar_fill)
  scalar_replace_idx <- scalar_idx[scalar_na_idx]
  fill_list[scalar_replace_idx] <- list(NULL)

  fill_locs <- vctrs::vec_unique_loc(fill_list)
  fill_values <- fill_list[fill_locs]
  if (length(fill_locs) > 1) {
    # TODO better error message
    cli::cli_abort("Cannot combine fill {fill_values}", call = .call)
  }

  fill_value <- fill_values[[1]]

  if (is.null(fill_value)) {
    fill_value
  } else {
    vctrs::vec_cast(fill_value, ptype)
  }
}

#' Combine transform functions from a list of tibs
#'
#' @inheritParams .shared-params
#' @returns (`function` or `NULL`) The combined transform function.
#' @keywords internal
.tib_combine_transform <- function(tib_list, .call) {
  transform_list <- purrr::map(tib_list, "transform")
  transform_locs <- vctrs::vec_unique_loc(transform_list)

  if (length(transform_locs) > 1) {
    # TODO better error message
    cli::cli_abort("Cannot combine different transforms", call = .call)
  }

  transform_list[[transform_locs]]
}

#' Combine input forms from a list of tibs
#'
#' @inheritParams .shared-params
#' @returns (`character(1)`) The combined input form.
#' @keywords internal
.tib_combine_input_form <- function(tib_list, .call) {
  types <- .compat_map_chr(tib_list, "type")
  if (any(types != "vector")) {
    tib_list <- tib_list[types == "vector"]
  }

  input_forms <- .compat_map_chr(tib_list, "input_form")
  input_form_locs <- vctrs::vec_unique_loc(input_forms)

  if (length(input_form_locs) > 1) {
    input_form_infos <- .loc_name_helper(input_form_locs, input_forms)
    cli::cli_abort(
      "Cannot combine input forms {input_form_infos}",
      call = .call
    )
  }

  input_form <- input_forms[[input_form_locs]]
  if (any(types == "scalar") && input_form != "vector") {
    cli::cli_abort(
      "Cannot combine input form {.val {input_form}} with {.code tib_scalar()}.",
      call = .call
    )
  }

  input_form
}

#' Combine names_col value from a list of tibs
#'
#' @inheritParams .shared-params
#' @returns (`character(1)` or `NULL`) The combined names column.
#' @keywords internal
.tib_combine_names_col <- function(tib_list, .call) {
  names_col <- .compat_map_chr(tib_list, "names_col", .default = NA)
  names_col_locs <- vctrs::vec_unique_loc(names_col)
  na_locs <- which(vctrs::vec_detect_missing(names_col))

  names_col_locs <- names_col_locs[!names_col_locs %in% na_locs]

  if (rlang::is_empty(names_col_locs)) {
    return(NULL)
  }

  if (length(names_col_locs) > 1) {
    # TODO better error message
    cli::cli_abort("Cannot combine different {.arg names_col}", call = .call)
  }

  names_col[[names_col_locs]]
}