R/repair_attributes.R

In constructive: Display Idiomatic Code to Construct Most R Objects

repair_attributes <- function(x, code, ..., pipe = NULL) {
  UseMethod("repair_attributes")
}

#' Repair attributes after idiomatic construction
#'
#' Exported for custom constructor design. In the general case an object might have more attributes than given by the idiomatic
#' construction. `.cstr_repair_attributes()` sets some of those attributes and ignores
#' others.
#'
#' @param x The object to construct
#' @param code The code constructing the object before attribute repair
#' @param ... Forwarded to `.construct_apply()` when relevant
#' @param ignore The attributes that shouldn't be repaired, i.e. we expect them
#'   to be set by the constructor already in `code`
#' @param idiomatic_class The class of the objects that the constructor produces,
#'   if `x` is of class `idiomatic_class` there is no need to repair the class.
#' @param remove Attributes that should be removed, should rarely be useful.
#' @param flag_s4 Boolean. Whether to use `asS4()` on the code of S4 objects,
#'   set to `FALSE` when a constructor that produces S4 objects was used.
#' @param repair_names Boolean. Whether to repair the `names` attribute. Generally it is
#'   generated by the constructor but it is needed for some corner cases
#'
#' @return A character vector
#' @export
.cstr_repair_attributes <- function(
    x, code, ...,
    ignore = NULL,
    idiomatic_class = NULL,
    remove = NULL,
    flag_s4 = TRUE,
    repair_names = FALSE) {
  # fetch non idiomatic args and class
  attrs <- attributes(x)
  attrs[ignore] <- NULL
  # names are normally already provided through constructors, but need to be
  # repaired for some corner cases
  if (!repair_names) attrs$names <- NULL
  # The `noquote` class is added at the end of the class vector so method `.noquote`
  # wouldn't be triggered
  if (
    !identical(attrs$class, idiomatic_class) &&
    tail(class(x), 1) == "noquote" &&
    list(...)$opts$no_quote$constructor %||% "no_quote" == "noquote"
    ) {
    right <- identical(tail(names(class(x)), 1), "right")
    args <- list(code)
    args$right <- if (right) "TRUE"
    code <- .cstr_apply(args, "noquote", recurse = FALSE)
    attrs$class <- setdiff(attrs$class, "noquote")
    if (!length(attrs$class)) attrs$class <- NULL
  }
  if (identical(attrs$class, idiomatic_class)) {
    attrs$class <- NULL
  } else if (is.null(attrs$class)) {
    # to be able to remove the idiomatic class explicitly, mainly (only ?) useful for classless formulas
    attrs["class"] <- list(NULL)
  }
  if (length(remove)) attrs <- c(attrs, setNames(replicate(length(remove), NULL), remove))
  if (length(attrs)) {
    # See ?structure, when those arguments are provided to structure() differently named attributes are created
    special_structure_args <- c(".Data", ".Dim", ".Dimnames", ".Names", ".Tsp", ".Label")
    special_attr_nms <- intersect(names(attrs), special_structure_args)
    special_attrs <- attrs[special_attr_nms]
    attrs[special_attr_nms] <- NULL
    # append structure() code to repair object
    if (length(attrs)) {
      if ("row.names" %in% names(attrs) && identical(attrs$row.names, seq_along(attrs$row.names))) {
        attrs$row.names <- c(NA, -length(attrs$row.names))
      }
      attrs_code <- .cstr_apply(attrs, fun = "structure", ...)
      code <- .cstr_pipe(code, attrs_code, ...)
    }
    for (attr_nm in special_attr_nms) {
      attr_code <- .cstr_apply(
        list(attr_nm, special_attrs[[attr_nm]]),
        "(`attr<-`)",
        ...
      )
      code <- .cstr_pipe(code, attr_code, ...)
    }
  }
  if (isS4(x) && flag_s4) {
    code <- .cstr_pipe(code, "asS4()", pipe, ...)
  }
  code
}