R/cascading-theme.R

In paleolimbot/ggr6: An Implementaation of the Grammar of Graphics in R6

#' Cascading Themes
#'
#' Strong graphics packages are built on good defaults that are
#' highly customizable. The [CascadingTheme] class makes it
#' possible to define a list of defaults that specify inheritance,
#' allowing customizable defaults with less repeated code.
#'
#' @export
CascadingTheme <- R6Class(
  "CascadingTheme",
  public = list(
    data = list(),
    nodes = list(),
    tree = list(),
    node_validators = list(),
    value_validators = list(),

    initialize = function(data = list()) {
      self$set_data(!!!data)
    },

    compile = function() {
      value_list <- purrr::map(rlang::set_names(self$keys()), self$value)
      new_cascading_element(value_list, subclass = "compiled_theme")
    },

    keys = function() {
      names(self$nodes) %||% character(0)
    },

    inheritance = function(key) {
      assert_chr_scalar(key)
      branch <- calc_inheritance(key, self$tree)
      bad_references <- branch[!(branch %in% self$keys())]
      if (length(bad_references) > 0) {
        bad_refs_label <- paste0("'", bad_references, "'", collapse = ", ")
        abort(
          glue::glue(
            "Can't calculate inheritance for key '{key}': no such node ({bad_refs_label})"
          )
        )
      }

      branch
    },

    value_validator = function(key, default = abort(glue::glue("No validators for value: '{key}'"))) {
      assert_chr_scalar(key)
      self$value_validators[[key]] %||% default
    },

    node_validator = function(key, default = abort(glue::glue("No validators for node: '{key}'"))) {
      self$node_validators[[key]] %||% default
    },

    node = function(key, default = abort(glue::glue("No such node: '{key}'"))) {
      assert_chr_scalar(key)
      if (key %in% self$keys()) {
        self$nodes[[key]]
      } else {
        default
      }
    },

    value = function(key, default = abort(glue::glue("No such value: '{key}'"))) {
      assert_chr_scalar(key)
      if (key %in% self$keys()) {
        value <- self$value_base(key, default)
        if (rlang::is_box(value)) {
          rlang::unbox(value)
        } else {
          value
        }
      } else {
        default
      }
    },

    value_base = function(key, default = abort(glue::glue("No such node: '{key}'"))) {
      assert_chr_scalar(key)
      if (key %in% self$keys()) {
        branch <- self$inheritance(key)
        value <- tryCatch(
          purrr::reduce(self$nodes[branch], cascade, .init = rlang::zap()),
          error = function(e) {
            abort(
              glue::glue("Error calculating value for key '{key}':\n{e}"),
              class = "cascading_error",
              parent = e
            )
          }
        )

        value <- tryCatch(
          self$value_validator(key, identity)(value),
          error = function(e) {
            abort(
              glue::glue("Value failed validation for key '{key}':\n{e}"),
              class = "value_validation_error",
              parent = e
            )
          }
        )

        value
      } else {
        default
      }
    },

    set_node = function(key, value) {
      assert_chr_scalar(key)
      if (rlang::is_zap(value)) {
        self$nodes[[key]] <- NULL
      } else {
        value <- tryCatch(
          self$node_validator(key, identity)(value),
          error = function(e) {
            abort(
              glue::glue("Node failed validation for key '{key}':\n{e}"),
              class = "node_validation_error",
              parent = e
            )
          }
        )
        self$nodes[key] <- list(value)
      }

      invisible(self)
    },

    set_value = function(key, value) {
      assert_chr_scalar(key)
      if (key %in% self$keys()) {
        current_value <- self$value(key)
      } else {
        current_value <- missing_value()
      }

      self$set_node(key, cascade(current_value, value, self))
    },

    set_nodes = function(...) {
      items <- rlang::list2(...)
      if (!rlang::is_dictionaryish(items)) {
        abort("CascadingTheme nodes must have unique keys")
      }
      purrr::walk2(names(items), items, self$set_node)
      invisible(self)
    },

    set_values = function(...) {
      items <- rlang::list2(...)
      if (!rlang::is_dictionaryish(items)) {
        abort("CascadingTheme values must have unique keys")
      }
      purrr::walk2(names(items), items, self$set_value)
      invisible(self)
    },

    set_value_validator = function(key, validator) {
      assert_chr_scalar(key)
      if (is.null(validator)) {
        self$value_validators[[key]] <- NULL
      } else {
        self$value_validators[[key]] <- rlang::as_function(validator)
      }

      invisible(self)
    },

    set_node_validator = function(key, validator) {
      assert_chr_scalar(key)
      if (is.null(validator)) {
        self$node_validators[[key]] <- NULL
      } else {
        self$node_validators[[key]] <- rlang::as_function(validator)
      }

      invisible(self)
    },

    set_tree = function(...) {
      items <- rlang::list2(...)
      if (!rlang::is_dictionaryish(items)) {
        abort("Tree nodes in a CascadingTheme must have unique keys")
      }

      # store zapped keys (length zero)
      zapped_keys <- names(items)[purrr::map_int(items, length) == 0]
      items <- items[setdiff(names(items), zapped_keys)]

      bad_types <- names(items)[!purrr::map_lgl(items, rlang::is_character, n = 1)]
      if (length(bad_types) > 0) {
        bad_types_label <- paste0("'", bad_types, "'", collapse = ", ")
        abort(
          glue::glue("All tree nodes must be character vectors of length 1 ({bad_types_label})")
        )
      }

      # copy tree for testing
      tree_copy <- self$tree
      tree_copy[names(items)] <- items

      # make sure all inheritance can be calculated
      purrr::walk(names(tree_copy), calc_inheritance, tree_copy)

      # make sure all references are defined
      references <- union(names(tree_copy), unlist(tree_copy))
      bad_references <- references[!(references %in% self$keys())]
      if (length(bad_references) > 0) {
        bad_refs_label <- paste0("'", bad_references, "'", collapse = ", ")
        abort(
          glue::glue(
            "Bad references in tree: no such node ({bad_refs_label})"
          )
        )
      }

      # reassign tree and remove zapped elements
      self$tree <- tree_copy[setdiff(names(tree_copy), zapped_keys)]
      invisible(self)
    },

    set_data = function(...) {
      items <- rlang::list2(...)
      if (!rlang::is_dictionaryish(items)) {
        abort("CascadingTheme data must have unique keys")
      }
      self$data[names(items)] <- items
      invisible(self)
    },

    set_node_validators = function(...) {
      items <- rlang::list2(...)
      if (!rlang::is_dictionaryish(items)) {
        abort("CascadingTheme node validators must have unique keys")
      }

      purrr::walk2(names(items), items, self$set_node_validator)
      invisible(self)
    },

    set_value_validators = function(...) {
      items <- rlang::list2(...)
      if (!rlang::is_dictionaryish(items)) {
        abort("CascadingTheme value validators must have unique keys")
      }

      purrr::walk2(names(items), items, self$set_value_validator)
      invisible(self)
    }
  )
)

#' Create a cascading element
#'
#' A cascading element is a [list()] with unique names whose elements
#' can be inherited by a child [cascading_element()]. The details of
#' cascading are handled by the [cascade()] and [reverse_cascade()]
#' generics.
#'
#' @param ... Key/value pairs. Passed to [rlang::list2()], so
#'   tidy evaluation is supported.
#' @param .subclass The class to use for this cascading element
#'
#' @return A list with class `cascading_element` and any subclasses
#'   specified by `.subclass`.
#' @export
#'
cascading_element <- function(..., .subclass = NULL) {
  x <- new_cascading_element(rlang::list2(...), subclass = .subclass)
  validate_cascading_element(x)
  x
}

#' S3 details for cascading elements
#'
#' @param x (possibly) a [cascading_element()]
#' @param subclass The class to use for this cascading element
#'
#' @export
#'
#' @examples
#' is_cascading_element(cascading_element())
#' new_cascading_element(list())
#' validate_cascading_element(cascading_element())
#'
is_cascading_element <- function(x) {
  inherits(x, "cascading_element")
}

#' @rdname is_cascading_element
#' @export
new_cascading_element <- function(x, subclass = NULL) {
  if (!is.list(x)) {
    abort("A cascading_element() must be a list()")
  }

  structure(x, class = union(subclass, "cascading_element"))
}

#' @rdname is_cascading_element
#' @export
validate_cascading_element <- function(x) {
  if (!is.list(x)) {
    abort("A cascading_element() must be a list()")
  }

  if (!rlang::is_dictionaryish(x)) {
    abort("A cascading_element() must have unique names")
  }

  invisible(x)
}

#' Combine cascading elements
#'
#' Combines two values. For most values, `child` is returned in place
#' of `parent`. Exeptions are formulas (converted to quosures
#' and evaluated with the object `parent` and objects from the
#' [CascadingTheme]'s `data` field available), functions (evaluated
#' on the `parent` if there is one), and [cascading_element()]s (values
#' are merged recursively). Use [rlang::as_box()] to cascade items
#' without applying any class-based rules, and [rlang::zap()] to
#' remove a key from the parent [cascading_element()].
#'
#' @param parent The value to be inherited from
#' @param child The value to inherit
#' @param cascading_theme The [CascadingTheme] object from which [cascade()]
#'   is called.
#'
#' @export
#'
#' @examples
#' # in most cases, child is returned in place parent
#' cascade("parent value", "child value")
#'
#' # formulas/quosures can use `parent` (tidy evaluation is supported)
#' # and data supplied by the theme
#' cascade(
#'   "parent value",
#'   ~paste(parent, "child value", sep = separator),
#'   CascadingTheme$new(data = list(separator = "=>"))
#' )
#'
#' # items of cascading elements are merged recursively using the
#' # same rules
#' cascade(
#'   cascading_element(key1 = "parent value 1", key2 = "parent_value 2"),
#'   cascading_element(
#'     key1 = "child value 1",
#'     key2 = ~paste(parent, "child value2", sep = separator)
#'   ),
#'   CascadingTheme$new(data = list(separator = "=>"))
#' )
#'
cascade <- function(parent, child = missing_value(), cascading_theme = NULL) {
  UseMethod("cascade")
}

#' @rdname cascade
#' @export
cascade.default <- function(parent, child = missing_value(), cascading_theme = NULL) {
  if (is_missing_value(child)) {
    parent
  } else {
    if (missing(parent)) {
      parent <- missing_value()
    }
    reverse_cascade(child, parent, cascading_theme)
  }
}

#' @rdname cascade
#' @export
cascade.function <- function(parent, child = missing_value(), cascading_theme = NULL) {
  parent <- parent()
  cascade(parent, child, cascading_theme)
}

#' @rdname cascade
#' @export
cascade.quosure <- function(parent, child = missing_value(), cascading_theme = NULL) {
  parent <- rlang::eval_tidy(
    parent,
    cascading_theme$data
  )

  cascade(parent, child, cascading_theme)
}

#' @rdname cascade
#' @export
cascade.formula <- function(parent, child = missing_value(), cascading_theme = NULL) {
  cascade(rlang::as_quosure(parent), child, cascading_theme)
}

#' @rdname cascade
#' @export
reverse_cascade <- function(child, parent = missing_value(), cascading_theme = NULL) {
  UseMethod("reverse_cascade")
}

#' @rdname cascade
#' @export
reverse_cascade.default <- function(child, parent = missing_value(), cascading_theme = NULL) {
  child
}

#' @rdname cascade
#' @export
reverse_cascade.function <- function(child, parent = missing_value(), cascading_theme = NULL) {
  if (is_missing_value(parent)) {
    child()
  } else {
    child(parent)
  }
}

#' @rdname cascade
#' @export
reverse_cascade.quosure <- function(child, parent = missing_value(), cascading_theme = NULL) {
  rlang::eval_tidy(
    child,
    rlang::list2(parent = parent, !!!cascading_theme$data)
  )
}

#' @rdname cascade
#' @export
reverse_cascade.formula <- function(child, parent = missing_value(), cascading_theme = NULL) {
  reverse_cascade(rlang::as_quosure(child), parent, cascading_theme)
}

#' @rdname cascade
#' @export
reverse_cascade.cascading_element <- function(child, parent = missing_value(), cascading_theme = NULL) {
  if (is_cascading_element(parent)) {
    parent_only_keys <- setdiff(names(parent), names(child))
    child_only_keys <- setdiff(names(child), names(parent))
    child[parent_only_keys] <- list(missing_value())
    parent[child_only_keys] <- list(missing_value())

    final_keys <- union(names(child), names(parent))
    result <- purrr::map2(
      parent[final_keys], child[final_keys],
      cascade,
      cascading_theme = cascading_theme
    )

    # remove 'zapped' elements, return new element with child class
    zapped_keys <- names(result)[purrr::map_lgl(result, rlang::is_zap)]
    new_cascading_element(
      result[setdiff(names(result), zapped_keys)],
      subclass = class(child)
    )
  } else {
    child
  }
}

#' Sentinel for missing values
#'
#' @param x A (possibly) missing value
#'
#' @export
missing_value <- function() {
  structure(list(), class = "missing_value")
}

#' @rdname missing_value
#' @export
is_missing_value <- function(x) {
  inherits(x, "missing_value")
}

calc_inheritance <- function(key, tree, branch = character(0)) {
  new_branch <- c(key, branch)

  if (key %in% branch) {
    original_key <- branch[length(branch)]
    abort(
      glue::glue(
        "Error calculating branch for key '{original_key}': circular reference to '{key}'"
      ),
      class = "circular_reference"
    )
  } else if(key %in% names(tree)) {
    calc_inheritance(tree[[key]], tree, new_branch)
  } else {
    new_branch
  }
}