R/layer_factory.R

In ggformula: Formula Interface to the Grammar of Graphics

utils::globalVariables("role")

#' @importFrom utils head tail
#' @importFrom tibble tibble
#' @importFrom stringr str_split str_match
#' @importFrom stats as.formula
#' @importFrom utils modifyList
#' @importFrom rlang is_character exprs f_rhs f_lhs is_formula is_null enquo
#' @importFrom rlang get_expr
#' @importFrom rlang is_missing
#' @import ggplot2
#' @import scales
#' @importFrom ggiraph girafe
#'
NA


#' Create a ggformula layer function
#'
#' Primarily intended for package developers, this function factory
#' is used to create the layer functions in the ggformula package.
#'
#' @param geom The geom to use for the layer
#'   (may be specified as a string).
#' @param position The position function to use for the layer
#'   (may be specified as a string).
#' @param stat The stat function to use for the layer
#'   (may be specified as a string).
#' @param interactive A logical indicating whether this is being used
#'   to create an interactive layer.
#' @param layer_func_interactive layer function passed to call of
#'   the internal function `layer_interactive()`.
#' @param pre code to run as a "pre-process".
#' @param aes_form A single formula or a list of formulas specifying
#'   how attributes are inferred from the formula.  Use `NULL` if the
#'   function may be used without a formula.
#' @param extras An alist of additional arguments (potentially with defaults)
#' @param note A note to add to the quick help.
#' @param aesthetics Additional aesthetics (typically created using
#'   [ggplot2::aes()]) set rather than inferred from formula.
#'   `gf_dhistogram()` uses this to set the y aesthetic to `stat(density)`,
#'   for example.
#' @param inherit.aes A logical indicating whether aesthetics should be
#'   inherited from prior layers or a vector of character names of aesthetics
#'   to inherit.
#' @param check.aes A logical indicating whether a warning should be emited
#'   when aesthetics provided don't match what is expected.
#' @param data A data frame or `NULL` or `NA`.
#' @param layer_func_interactive The function used to create the layer when `interactive`` is TRUE
#'   (or a quosure that evaluates to such a function).
#' @param layer_fun function used to create a layer. The default value is anticipated
#'   to work in most (all?) cases.
#'
#' @param ... Additional arguments.
#' @return A function.
#' @export

layer_factory <-
  function(
    geom = "point",
    position = "identity",
    stat = "identity",
    interactive = FALSE,
    layer_func_interactive = "geom_point",
    pre = {},
    aes_form = y ~ x,
    extras = alist(),
    note = NULL,
    aesthetics = aes(),
    inherit.aes = TRUE,
    check.aes = TRUE,
    data = NULL,
    layer_fun = if (interactive) {
      quo(layer_interactive)
    } else {
      quo(ggplot2::layer)
    },
    ...
  ) {
    pre <- substitute(pre)

    geom <- enexpr(geom)
    stat <- enexpr(stat)
    position <- enexpr(position)

    if (!is.logical(inherit.aes)) {
      inherited.aes <- inherit.aes
      inherit.aes <- FALSE
    } else {
      inherited.aes <- character(0)
    }

    # the formals of this will be modified below
    # the formals included here help avoid CRAN warnings
    res <-
      function(
        xlab,
        ylab,
        title,
        subtitle,
        caption,
        show.legend,
        function_name,
        inherit,
        environment = parent.frame(),
        ...
      ) {
        # pre and will be placed in the function environment so available here
        eval(pre)

        # evaluate quosures
        geom = rlang::eval_tidy(geom)
        stat = rlang::eval_tidy(stat)
        position = rlang::eval_tidy(position)
        layer_fun = rlang::eval_tidy(layer_fun)
        layer_func_interactive = rlang::eval_tidy(layer_func_interactive)

        function_name <- as.character(match.call()[1])
        orig_args <- as.list(match.call())[-1]

        # make sure we have a list of formulas here
        if (!is.list(aes_form)) {
          aes_form <- list(aes_form)
        }

        # show help if requested or if there are no arguments to the function
        if (is.null(show.help)) {
          show.help <- length(orig_args) < 1
        }

        if (show.help) {
          emit_help(
            function_name = function_name,
            aes_form,
            extras,
            note,
            geom = geom,
            stat = stat,
            position = position
          )
          return(invisible(NULL))
        }

        # figure out what sort of object is first and adjust args as required
        if (inherits(object, "formula")) {
          gformula <- object
          object <- NULL
        }

        if (inherits(object, "data.frame")) {
          data <- object
          object <- NULL
        }

        # not sure whether we should use the environment recorded in object or not,
        # but this is how/where to do it.

        # if (inherits(object, "gg")) {
        #   environment <- object$plot_env
        # }

        # convert y ~ 1 into ~ y if a 1-sided formula is an option and 2-sided is not
        gformula <- response2explanatory(gformula, aes_form)

        # find matching formula shape
        aes_form <-
          first_matching_formula(
            gformula,
            aes_form,
            object,
            inherit,
            inherited.aes,
            function_name
          )

        ############# create extras_and_dots ############
        # collect arguments
        #  * remove those that are "missing"
        #  * remove function args not for layer, stat, or geom

        stat_formals <- grab_formals(stat, "stat")
        geom_formals <- grab_formals(geom, "geom")
        extras_and_dots <-
          create_extras_and_dots(
            args = orig_args,
            formals = formals(),
            stat_formals = stat_formals,
            geom_formals = geom_formals,
            extras = extras,
            env = environment
          )
        # turn character position into a position object using any available arguments
        if (is.character(position)) {
          position_fun <- paste0("position_", position)
          pdots <-
            extras_and_dots[intersect(
              names(extras_and_dots),
              names(formals(position_fun))
            )]
          position <- do.call(position_fun, pdots)
        }

        # remove symbols from extras_and_dots (why?)
        if (length(extras_and_dots) > 0) {
          extras_and_dots <-
            extras_and_dots[sapply(extras_and_dots, function(x) !is.symbol(x))]
        }

        add <- inherits(object, c("gg", "ggplot"))

        # add in selected additional aesthetics -- partial inheritance
        if (add) {
          for (aes.name in inherited.aes) {
            aesthetics[[aes.name]] <- object$mapping[[aes.name]]
          }
        }

        # look for arguments of the form argument = ~ something and turn them
        # into aesthetics
        if (length(extras_and_dots) > 0) {
          w <- which(
            sapply(extras_and_dots, function(x) {
              rlang::is_formula(x) && length(x) == 2L
            })
          )
          aesthetics <- add_aes(aesthetics, extras_and_dots[w], environment)
          extras_and_dots[w] <- NULL
        }
        ingredients <-
          gf_ingredients(
            formula = gformula,
            data = data,
            gg_object = object,
            extras = extras_and_dots,
            aes_form = aes_form,
            aesthetics = aesthetics,
            envir = environment
          )

        # layer has a params argument, geoms and stats do not
        if ("params" %in% names(formals(layer_fun))) {
          layer_args <-
            list(
              geom = geom,
              stat = stat,
              data = ingredients[["data"]],
              mapping = ingredients[["mapping"]],
              position = position,
              params = remove_from_list(ingredients[["params"]], "inherit"),
              check.aes = check.aes,
              check.param = FALSE,
              show.legend = show.legend,
              inherit.aes = inherit
            )
        } else {
          layer_args <-
            c(
              list(
                geom = geom,
                stat = stat,
                data = ingredients[["data"]],
                mapping = ingredients[["mapping"]],
                show.legend = show.legend
                # arguments below are not used by geom_abline() and friends, so don't include them.
                # check.aes = TRUE, check.param = FALSE,
                # inherit.aes = inherit
              ),
              # these become regular arguments for other layer functions
              remove_from_list(ingredients[["params"]], "inherit")
            )
        }

        # If no ..., be sure to remove things not in the formals list
        if (!"..." %in% names(formals(layer_fun))) {
          layer_args <- cull_list(layer_args, names(formals(layer_fun)))
        }

        # remove additional arguments that layer_fun doesn't use, even if we have ...
        # this is here to avoid unused arguments in gf_abline(), gf_hline(), and gf_vline()
        for (f in c("geom", "stat", "position")) {
          if (!f %in% names(formals(layer_fun))) {
            layer_args[[f]] <- NULL
          }
        }

        # remove any duplicated arguments
        layer_args <- layer_args[unique(names(layer_args))]

        # remove mapping and data if mapping is empty -- to avoid warnings from gf_abline() and friends
        if (length(layer_args[['mapping']]) < 1) {
          layer_args[['mapping']] <- NULL
          layer_args[['data']] <- NULL
        }

        if (interactive) {
          layer_args <- c(list(layer_func = layer_func_interactive), layer_args)
        }
        new_layer <- do.call(layer_fun, layer_args, envir = environment)

        if (is.null(ingredients[["facet"]])) {
          if (add) {
            p <- object + new_layer
          } else {
            p <-
              do.call(
                ggplot,
                list(
                  data = ingredients$data,
                  mapping = ingredients[["mapping"]]
                ),
                envir = environment
              ) +
              new_layer
          }
        } else {
          if (add) {
            p <- object + new_layer + ingredients[["facet"]]
          } else {
            p <-
              do.call(
                ggplot,
                list(
                  data = ingredients$data,
                  mapping = ingredients[["mapping"]]
                ),
                envir = environment
              ) +
              new_layer +
              ingredients[["facet"]]
          }
        }

        if (!rlang::is_missing(ylab)) {
          p <- p + ggplot2::ylab(ylab)
        }
        if (!rlang::is_missing(xlab)) {
          p <- p + ggplot2::xlab(xlab)
        }
        if (!rlang::is_missing(title)) {
          p <- p + ggplot2::labs(title = title)
        }
        if (!rlang::is_missing(subtitle)) {
          p <- p + ggplot2::labs(subtitle = subtitle)
        }
        if (!rlang::is_missing(caption)) {
          p <- p + ggplot2::labs(caption = caption)
        }
        class(p) <- unique(c("gf_ggplot", class(p)))
        p
      }
    formals(res) <-
      c(
        create_formals(
          extras,
          layer_fun = layer_fun,
          geom = geom,
          stat = stat,
          position = position,
          inherit.aes = inherit.aes
        ),
        list(...)
      )

    assign("inherit.aes", inherit.aes, environment(res))
    assign("check.aes", check.aes, environment(res))
    assign("pre", pre, environment(res))
    assign("extras", extras, environment(res))
    res
  }

###############################################################################
##
## modified version of function in ggiraph, branching based on whether position
## is specified.

layer_interactive <- function(
    layer_func, stat = NULL, position = NULL, ...,
    interactive_geom = NULL, extra_interactive_params = NULL) {

  dots <- list(...)
  if (is.null(position)) {
    ggiraph_layer_interactive(
      layer_func, stat = stat, ...,
      interactive_geom = interactive_geom, extra_interactive_params = extra_interactive_params
    )
  } else {
    ggiraph_layer_interactive(
      layer_func, stat = stat, position = position, ...,
      interactive_geom = interactive_geom, extra_interactive_params = extra_interactive_params
    )
  }
}


###############################################################################

#' Create an interactive ggformula layer function
#'
#' Primarily intended for package developers, this function factory
#' is used to create layer functions in the ggformula package.
#'
#' @param geom_fun A character string naming an interactive geom (example: "geom_point_interactive")
#'
interactive_layer_factory <- function(geom_fun) {
  stopifnot(is.character(geom_fun))
  geom_noninteractive <- gsub("_interactive", "", geom_fun, fixed = TRUE)
  gf_noninteractive <- gsub("geom_", "gf_", geom_noninteractive, fixed = TRUE)
  gfenv <- tryCatch(
    environment(get(gf_noninteractive)),
    error = function(e) NULL
  )
  if (is.null(gfenv)) {
    return(NULL)
  }

  aes_form_from_env <- rlang::env_get(gfenv, "aes_form", default = NULL)
  extras_from_env <- rlang::env_get(gfenv, "extras", default = alist())
  geom_from_env <- rlang::env_get(gfenv, "geom", default = "point")
  stat_from_env <- rlang::env_get(gfenv, "stat", default = "identity")
  position_from_env <- rlang::env_get(gfenv, "position", default = "identity")
  inherit_from_env <- rlang::env_get(gfenv, "inherit.aes", default = TRUE)
  aesthetics_from_env <- rlang::env_get(gfenv, "aesthetics", default = aes())
  check_aes_from_env <- rlang::env_get(gfenv, "check.aes", default = TRUE)

  do.call(
    layer_factory,
    list(
      geom = geom_from_env,
      position = position_from_env,
      stat = stat_from_env,
      interactive = TRUE,
      layer_func_interactive = geom_fun,
      # pre,
      aes_form = aes_form_from_env,
      extras = extras_from_env,
      # note,
      aesthetics = aesthetics_from_env,
      inherit.aes = inherit_from_env,
      check.aes = check_aes_from_env,
      layer_fun = layer_interactive
    )
  )
}


#########################################################################
#

# Modify environments of aesthetics in a mapping
#
# @param mapping an aesthetic mapping
# @param environment an environment to use for aesthetics that have environments.
#
aes_env <- function(mapping, envir) {
  for (i in one_upto(length(mapping))) {
    if (!is.null(environment(mapping[[i]]))) {
      environment(mapping[[i]]) <- envir
    }
  }
  mapping
}

# Check if an aesthetic uses a stat
#
# @param aes an item in an aesthetic mapping
# @return a logical indicating whether the aethetic is of the form `stat( ... )`.

uses_stat <- function(aes) {
  e <- rlang::get_expr(aes)
  length(e) > 1 && e[[1]] == as.name("stat")
}


add_aes <- function(mapping, new, envir = parent.frame()) {
  # convert ~ x into just x (as a name)
  if (length(new) > 0L) {
    for (i in 1L:length(new)) {
      if (rlang::is_formula(new[[i]]) && length(new[[i]] == 2L)) {
        new[[i]] <- new[[i]][[2]]
      }
    }
  }
  new <- do.call(aes, new) |> aes_env(envir)
  res <- modifyList(mapping, new)
  res
}


# grab formals from a stat or geom (or similar)

grab_formals <- function(f, type = "stat") {
  # wrapping with c() is per issue #150 due to change in "union() and friends"
  if (is.character(f) && !grepl(paste0("^", type), f)) {
    return(c(formals(paste0(type, "_", f))))
  } else if (is.function(f)) {
    return(c(formals(f)))
  } else {
    return(list())
  }
}

#' @importFrom rlang enexpr !!

create_formals <-
  function(
    extras = list(),
    layer_fun,
    geom,
    stat,
    position,
    inherit.aes = TRUE
  ) {
    layer_fun <- rlang::eval_tidy(layer_fun)

    res <-
      c(
        list(object = NULL, gformula = NULL, data = NULL),
        alist(... = ),
        extras[setdiff(
          names(extras),
          c("xlab", "ylab", "title", "subtitle", "caption")
        )],
        if (is.null(extras[["xlab"]])) {
          alist(xlab = )
        } else {
          list(xlab = extras[["xlab"]])
        },
        if (is.null(extras[["ylab"]])) {
          alist(ylab = )
        } else {
          list(ylab = extras[["ylab"]])
        },
        if (is.null(extras[["title"]])) {
          alist(title = )
        } else {
          list(title = extras[["title"]])
        },
        if (is.null(extras[["subtitle"]])) {
          alist(subtitle = )
        } else {
          list(subtitle = extras[["subtitle"]])
        },
        if (is.null(extras[["caption"]])) {
          alist(caption = )
        } else {
          list(caption = extras[["caption"]])
        },
        list(
          geom = geom,
          stat = stat,
          position = position,
          show.legend = NA,
          show.help = NULL,
          inherit = inherit.aes,
          environment = quote(parent.frame())
        )
      )

    # remove arguments from resulting function that layer_fun doesn't use.
    # this is here to avoid unused arguments in gf_abline(), gf_hline(), and gf_vline()
    for (f in c("geom", "stat", "position")) {
      if (!f %in% names(formals(layer_fun))) {
        res[[f]] <- NULL
      }
    }
    res
  }

create_extras_and_dots <-
  function(
    args,
    formals,
    stat_formals = list(),
    geom_formals = list(),
    extras = list(),
    env
  ) {
    extras_and_dots <- modifyList(formals, args)
    # to avoid object = formula becoming an aesthetic
    extras_and_dots[["object"]] <- NULL
    # remove missing -- is there a better way to determine missing?
    extras_and_dots <-
      extras_and_dots[
        !sapply(
          extras_and_dots,
          function(x) is.symbol(x) && identical(as.character(x), "")
        )
      ]
    # remove args not used by stat or geom and not in extras
    for (n in setdiff(
      names(formals),
      union(
        union(
          stat_formals,
          geom_formals
        ),
        names(extras)
      )
    )) {
      extras_and_dots[[n]] <- NULL
    }

    # evaluate any items that are names or still calls
    extras_and_dots <-
      lapply(extras_and_dots, function(x) {
        if (is.symbol(x) || is.call(x)) eval(x, env) else x
      })
    extras_and_dots
  }

# Find first matching formula shape.
# Emit error message when no good matches.

first_matching_formula <-
  function(gformula, aes_form, object, inherit, inherited.aes, function_name) {
    fmatches <- formula_match(gformula, aes_form = aes_form)

    if (!any(fmatches)) {
      if (inherits(object, "gg") && (inherit || length(inherited.aes) > 0)) {
        return(NULL)
      } else {
        stop("Invalid formula type for ", function_name, ".", call. = FALSE)
      }
    } else {
      return(aes_form[[which.max(fmatches)]])
    }
  }

# if aes_form includes 1-sided formula but no 2-sided formula, then
#   covert y ~ 1 into ~ y
#   convert y ~ 1 | a into ~ y | a
#   convert y ~ 1 | a ~ b into ~ y | a ~ b
#   convert y ~ 1 | ~ a into ~ y | ~ a

# This is clunky because | doen't have the right precedence for the intended
# interpretation of the formula.

response2explanatory <-
  function(formula, aes_form = NULL) {
    if (
      !is.null(aes_form) &&
        (!any(sapply(aes_form, function(f) length(f) == 2L)) ||
          any(sapply(aes_form, function(f) length(f) == 3L)))
    ) {
      return(formula)
    }

    if (length(formula) == 3L && isTRUE(formula[[3]] == 1)) {
      formula[[3]] <- formula[[2]]
      # can remove either slot 2 or slot 3 here to get 1-sided formula
      formula[[2]] <- NULL
    } else if (
      length(formula) == 3L &&
        length(formula[[3]]) == 3L &&
        isTRUE(formula[[3]][[1]] == as.name("|")) &&
        isTRUE(formula[[3]][[2]] == 1L)
    ) {
      formula[[3]][[2]] <- formula[[2]]
      formula[[2]] <- NULL
    } else if (length(formula) == 3L && rlang::is_formula(formula[[2]])) {
      formula[[2]] <- response2explanatory(formula[[2]])
    }
    formula
  }


# The actual graphing functions are created dynamically.
#  See the functions at the bottom of this file

# These are unexported helper functions to create the gf_ functions. The gf_ functions
# themselves are at the end of this file....

# traverse a formula and return a nested list of "nodes"
# stop traversal if we encounter a binary operator in stop_binops
formula_slots <- function(x, stop_binops = c(":", "::")) {
  if (length(x) == 2L && deparse(x[[1]]) == "~") {
    formula_slots(x[[2]])
  } else if (length(x) == 3L && deparse(x[[1]]) == "~") {
    list(formula_slots(x[[2]]), formula_slots(x[[3]]))
  } else if (
    length(x) > 1 && is.name(x[[1]]) && !deparse(x[[1]]) %in% c("+", "|")
  ) {
    list(x)
  } else if (length(x) == 3L && deparse(x[[1]]) %in% stop_binops) {
    list(x)
  } else if (length(x) <= 2L) {
    list(x)
  } else {
    list(formula_slots(x[[2]]), formula_slots(x[[3]]))
  }
}


as_formula <- function(x, ...) {
  UseMethod("as_formula", x)
}

#' @export
as_formula.formula <- function(x, ...) {
  x
}


#' @export
as_formula.call <- function(x, ...) {
  res <- ~x
  # environment(res) <- env
  res[[2]] <- x[[2]]
  res
}

#' @export
as_formula.name <- function(x, env = parent.frame(), ...) {
  res <- ~x
  environment(res) <- env
  res[[2]] <- x
  res
}

f_formula_slots <- function(x, env = parent.frame()) {
  if (is.null(x)) {
    return(x)
  }
  if (length(x) == 1L) {
    return(as_formula(x, env))
  }
  if (x[[1]] == as.symbol("~")) {
    return(list(
      f_formula_slots(rlang::f_lhs(x), env),
      f_formula_slots(rlang::f_rhs(x), env)
    ))
  }
  if (x[[1]] == as.symbol("(")) {
    res <- ~x
    res[[2]] <- x[[2]] # strip parens
    environment(res) <- env
    return(res)
  }
  if (length(x) == 2L) {
    res <- ~x
    res[[2]] <- x # leave call as is
    environment(res) <- env
    return(res)
  }
  # if we get here, we should have a binary operation
  return(list(
    f_formula_slots(rlang::f_lhs(x), env),
    f_formula_slots(rlang::f_rhs(x), env)
  ))
}

# add quotes to character elements of list x and returns a vector of character
.quotify <- function(x) {
  if (is_null(x)) {
    return("NULL")
  }
  x <- if (rlang::is_character(x)) paste0('"', x, '"') else x
  x <- if (is.name(x)) as.character(x) else x
  x <- if (rlang::is_character(x)) x else format(x)
  x
}


.default_value <- function(x) {
  sapply(
    x,
    function(x) if (is.symbol(x)) "" else paste0(" = ", .quotify(x))
  )
}

aes_from_qdots <- function(qdots, mapping = aes()) {
  if (length(qdots) > 0) {
    # proceed backwards through list so that removing items doesn't mess up indexing
    for (i in length(qdots):1L) {
      if (
        rlang::is_formula(f_rhs(qdots[[i]])) &&
          length(rlang::f_rhs(qdots[[i]])) == 2L
      ) {
        mapping[[names(qdots)[i]]] <- rlang::f_rhs(qdots[[i]])[[2]]
        qdots[[i]] <- NULL
      }
    }
  }
  list(
    mapping = do.call(aes, mapping),
    qdots = qdots
  )
}

emit_help <- function(
  function_name,
  aes_form,
  extras = list(),
  note = NULL,
  geom,
  stat = "identity",
  position = "identity"
) {
  message_text <- ""
  if (any(sapply(aes_form, is.null))) {
    message_text <-
      paste0(message_text, function_name, "() does not require a formula.")
  } else {
    message_text <-
      paste0(
        message_text,
        function_name,
        "() uses \n    * a formula with shape ",
        paste(sapply(aes_form, format), collapse = " or "),
        "."
      )
  }
  if (is.character(geom)) {
    message_text <- paste(message_text, "\n    * geom: ", geom)
  }
  if (is.character(stat) && stat != "identity") {
    message_text <- paste(message_text, "\n    * stat: ", stat)
  }
  if (is.character(position) && position != "identity") {
    message_text <- paste(message_text, "\n    * position: ", position)
  }

  if (length(extras) > 0) {
    message_text <-
      paste(
        message_text,
        "\n    * key attributes: ",
        paste(
          strwrap(
            width = options("width")[[1]] - 20,
            simplify = TRUE,
            paste(
              names(extras),
              .default_value(extras),
              collapse = ", ",
              sep = ""
            ),
            initial = "",
            prefix = "\n                   "
          ),
          collapse = "",
          sep = ""
        )
      )
  }
  if (!is.null(note)) {
    message_text <- paste(message_text, "\nNote: ", note)
  }
  message_text <- paste0(
    message_text,
    "\n\nFor more information, try ?",
    function_name
  )

  message(message_text)

  return(invisible(NULL))
}


formula_split <- function(formula) {
  # split A | B into formula <- A; condition <- B
  fs <-
    stringr::str_split(deparse(formula), "\\|")[[1]]
  # try to split, else leave formula unchanged and set condition to NULL
  if (
    (length(fs) != 2) ||
      !tryCatch(
        {
          formula_string <- fs[1]
          condition_string <- fs[2]
          if (!grepl("~", condition_string)) {
            condition_string <- paste0("~", condition_string)
            condition <- as.formula(
              condition_string,
              env = environment(formula)
            )
            facet_type <- "facet_wrap"
          } else {
            condition <- as.formula(
              condition_string,
              env = environment(formula)
            )
            facet_type <- "facet_grid"
          }
          formula <- as.formula(formula_string, env = environment(formula))
          TRUE
        },
        error = function(e) {
          warning(e)
          FALSE
        }
      )
  ) {
    condition <- NULL
    facet_type <- "none"
  }
  list(formula = formula, condition = condition, facet_type = facet_type)
}

#  #' @export
#  match_call <- function(n = 1L, include_missing = FALSE) {
#    call <- evalq(match.call(), parent.frame(n))
#    formals <- evalq(formals(), parent.frame(n))
#
#    for(i in setdiff(names(formals), names(call))) {
#      if (include_missing || !rlang::is_missing(formals[[i]])) {
#        call[i] <- list( formals[[i]] )
#      }
#    }
#    match.call(sys.function(sys.parent()), call)
#  }
#
#  #' @export
#  have_arg <-
#    function(arg, n = 1L,
#             call = evalq(match_call(include_missing = FALSE), parent.frame(n))
#    ) {
#    arg %in% names(call)
#  }

gf_ingredients <-
  function(
    formula = NULL,
    data = NULL,
    extras = list(),
    aes_form = y ~ x,
    aesthetics = aes(),
    gg_object = NULL,
    envir = NULL
  ) {
    if (is.null(envir)) {
      if (inherits(formula, "formula")) envir <- environment(formula)
    }
    # split A | B into formula <- A; condition <- B
    fs <- formula_split(formula)

    var_names <-
      if (is.null(data)) {
        if (is.null(gg_object)) {
          character(0)
        } else {
          names(gg_object$data)
        }
      } else {
        names(data)
      }

    # create mapping -- assume ggplot2 version >= 3.0
    aes_df <-
      formula_to_df(fs[["formula"]], var_names, aes_form = aes_form)

    mapped_list <- as.list(aes_df[["expr"]][aes_df$map])
    names(mapped_list) <- aes_df[["role"]][aes_df$map]
    # . is placeholder for "no aesthetic mapping", so remove the dots
    mapped_list[mapped_list == "."] <- NULL

    mapping <- modifyList(aesthetics, do.call(aes, mapped_list)) # was aes_string
    mapping <- aes_env(mapping, envir)
    mapping <- remove_dot_from_mapping(mapping)

    set_list <- as.list(aes_df[["expr"]][!aes_df$map])
    names(set_list) <- aes_df[["role"]][!aes_df$map]
    set_list <- modifyList(extras, set_list)

    res <-
      list(
        data = data,
        mapping = mapping,
        setting = set_list,
        facet = if (is.null(fs[["condition"]])) {
          NULL
        } else {
          switch(
            fs[["facet_type"]],
            "facet_wrap" = do.call(
              fs[["facet_type"]],
              list(facets = fs[["condition"]])
            ),
            "facet_grid" = do.call(
              fs[["facet_type"]],
              list(rows = fs[["condition"]])
            )
          )
        },
        params = modifyList(set_list, extras)
      )
    if (identical(data, NA)) {
      res$data <-
        do.call(
          data.frame,
          c(
            lapply(res[["mapping"]], rlang::get_expr),
            res[["setting"]],
            list(stringsAsFactors = FALSE)
          )
        )
      res$params[names(res$mapping)] <- NULL # remove mapped attributes
      aes_list <- as.list(intersect(names(res$data), names(res$mapping)))
      names(aes_list) <- aes_list
      res$mapping <- do.call(aes_string, aes_list)
      res$setting <- as.list(res$data)[names(res$setting)]
      res$params[names(res$setting)] <- res$setting
    }
    res
  }


# remove item -> . mappings
remove_dot_from_mapping <- function(mapping) {
  for (item in rev(seq_along(mapping))) {
    if (identical(rlang::get_expr(mapping[[item]]), quote(.))) {
      mapping[[item]] <- NULL
    }
  }
  mapping
}

formula_shape0 <- function(x) {
  if (length(x) < 2) {
    return(0)
  }
  arity <- length(x) - 1
  if (as.character(x[[1]]) %in% c("(")) {
    return(0)
  }
  if (as.character(x[[1]]) %in% c(":", "(")) {
    return(0) # was -1 when supporting attribute:value
  }
  # stop if we hit a name that isn't + or ~
  if (is.name(x[[1]]) && !as.character(x[[1]]) %in% c("+", "~")) {
    return(0)
  }

  # if (as.character(x[[1]]) %in% c("|")){
  #   return(formula_shape0(x[[2]]))
  # }

  if (arity == 1L) {
    right_shape0 <- formula_shape0(x[[2]])
    arity <- arity - (right_shape0[1] < 0)
    if (arity == 0) {
      return(arity)
    }
    return(right_shape0)
  }
  if (arity == 2L) {
    right_shape0 <- formula_shape0(x[[3]])
    left_shape0 <- formula_shape0(x[[2]])
    if (left_shape0[1] < 0 && right_shape0 < 0) {
      return(0)
    }
    if (left_shape0[1] < 0) {
      if (right_shape0[1] == 1L) {
        return(right_shape0[-1])
      }
      return(right_shape0)
    }
    if (right_shape0[1] < 0) {
      if (left_shape0[1] == 1L) {
        return(left_shape0[-1])
      }
      return(left_shape0)
    }
    return(c(2, left_shape0, right_shape0))
  }
  stop("Bug: problems determining formula shape (0).")

  c(length(x) - 1, unlist(sapply(x[-1], formula_shape0)))
  # list(length(x) - 1, lapply(x[-1], formula_shape0))
}


formula_shape <- function(x) {
  if (is.null(x)) {
    return(integer(0))
  }
  if (length(x) == 1L) {
    return(0L)
  }
  if (x[[1]] == as.symbol("~")) {
    return(c(
      length(x) - 1,
      formula_shape(rlang::f_lhs(x)),
      formula_shape(rlang::f_rhs(x))
    ))
  }
  if (x[[1]] == as.symbol("(")) {
    return(0L)
  }
  # this is covered by fall through below now
  # if (length(x) == 2L) {
  #   return(0L)
  # }

  if (length(x) == 3 && as.character(x[[1]]) %in% c('+')) {
    # treat as binary op and call recusively on lhs and rhs
    return(c(
      2L,
      formula_shape(rlang::f_lhs(x)),
      formula_shape(rlang::f_rhs(x))
    ))
  }

  return(0)
}

# @param formula a formula describing aesthetics
# @param aes_form a list of template formulas (or a single formula)
# @param value a logical indicating whether the first matching value should be returend
#   rather than a vector of logicals
# @param unmatched value of retun if value = TRUE and there are no matches.

formula_match <-
  function(formula, aes_form = y ~ x, value = FALSE, unmatched = NULL) {
    if (!is.list(aes_form)) {
      aes_form <- list(aes_form)
    }
    user_shape <- formula_shape(formula_split(formula)$formula)
    shapes <- lapply(aes_form, formula_shape)
    bools <- sapply(shapes, function(s) identical(s, user_shape))
    if (value) {
      if (any(bools)) {
        aes_form[[which.max(bools)]]
      } else {
        unmatched
      }
    } else {
      bools
    }
  }

formula_to_df <- function(
  formula = NULL,
  data_names = character(0),
  aes_form = y ~ x
) {
  if (is.null(formula)) {
    return(data.frame(
      role = character(0),
      expr = character(0),
      map = logical(0)
    ))
  }
  get_leaf <- function(x) {
    # if there are any special cases, add them here
    return(x)
  }

  parts <- formula_slots(formula) |>
    rapply(get_leaf, how = "replace") |>
    unlist()
  aes_names <- formula_slots(aes_form) |>
    rapply(get_leaf, how = "replace") |>
    unlist()

  # trim leading/trailing blanks and turn `some name` into "`some name`"
  # parts <- gsub("^\\s+|\\s+$", "", parts)

  # # split into pairs/nonpairs
  # pairs <- parts[grepl(":+", parts)]
  # nonpairs <- parts[ !grepl(":+", parts)]

  # ## !! turning off support for attribute:value !!
  # pairs <- parts[FALSE]
  # nonpairs <- parts[TRUE]

  # pair_list <- list()
  # mapped_pairs <- character(0)
  # for (pair in pairs) {
  #   this_pair <- stringr::str_split(pair, ":+", n = 2)[[1]]
  #   pair_list[this_pair[1]] <- this_pair[2]
  #   if (stringr::str_match(pair, ":+") == "::") {
  #     mapped_pairs <- c(mapped_pairs, this_pair[1])
  #   }
  # }

  parts_list <- parts # nonpairs

  # remove items specified explicitly
  aes_names <- all.vars(aes_form) # setdiff(all.vars(aes_form), names(pair_list))
  names(parts_list) <- head(aes_names, length(parts_list))

  if (length(parts_list) > length(aes_names)) {
    stop(
      "Formula too large.  I'm looking for ",
      format(aes_form),
      call. = FALSE
    )
  }
  if (length(parts_list) < length(aes_names)) {
    stop(
      "Formula too small.  I'm looking for ",
      format(aes_form),
      call. = FALSE
    )
  }

  # res <- c(parts_list, pair_list)

  res <-
    tibble::tibble(
      role = names(parts_list),
      expr = unlist(parts_list),
      map = unlist(parts_list) %in% c(data_names) | role %in% aes_names #  | role %in% mapped_pairs
    )
  row.names(res) <- NULL
  res
}

df_to_aesthetics <- function(formula_df, data_names = NULL, prefix = "") {
  aes_substr <-
    if (is.null(data_names) || nrow(formula_df) == 0) {
      ""
    } else {
      paste0(
        "aes(",
        with(
          subset(formula_df, formula_df$map),
          paste(role, expr, sep = " = ", collapse = ", ")
        ),
        ")",
        ifelse(any(!formula_df$map), ", ", "") # prepare for more args
      )
    }
  S <- paste0(
    "",
    prefix,
    ifelse(nchar(prefix) > 0, ", ", ""),
    aes_substr,
    with(
      subset(formula_df, !formula_df$map),
      paste(role, expr, sep = " = ", collapse = ", ")
    ),
    ""
  )
  S
}


formula_to_aesthetics <- function(
  formula,
  data_names = NULL,
  prefix = "",
  aes_form = y ~ x
) {
  df <- formula_to_df(formula, data_names, aes_form = aes_form)
  df_to_aesthetics(df, data_names = data_names, prefix = prefix)
}

# pairs_in_formula() was here.  but we don't use formulas that way anymore,
# so it has been removed.