#' Text annotations plot type
#'
#' @description Type function for adding text annotations to a plot. This function allows
#' you to draw text at specified (x,y) coordinates.
#'
#' @param labels Character vector of length 1 or of the same length as the
#'  number of x,y coordinates.
#' @param font Font to be used, following [graphics::par()].
#' @param xpd Logical value or `NA` denoting text clipping behaviour, following
#'  [graphics::par()].
#' @param srt Numeric giving the desired string rotation in degrees.
#' @inheritParams graphics::text
#' @examples
#' tinyplot(mpg ~ hp | factor(cyl),
#'   data = mtcars,
#'   type = type_text(
#'     labels = row.names(mtcars),
#'     font = 2,
#'     adj = 0
#'   )
#' )
#'
#' # to avoid clipping text at the plot region, we can use xpd = NA
#' tinyplot(mpg ~ hp | factor(cyl),
#'   data = mtcars,
#'   type = type_text(
#'     labels = row.names(mtcars),
#'     font = 2,
#'     adj = 0,
#'     xpd = NA
#'   )
#' )
#'
#' @export
type_text = function(labels, adj = NULL, pos = NULL, offset = 0.5, vfont = NULL, font = NULL, xpd = NULL, srt = 0) {
  out = list(
    draw = draw_text(adj = adj, pos = pos, offset = offset, vfont = vfont, font = font, xpd = xpd, srt = srt),
    data = data_text(labels = labels),
    name = "text"
  )
  class(out) = "tinyplot_type"
  return(out)
}

data_text = function(labels) {
  fun = function(datapoints, ...) {
    if (length(labels) != 1 && length(labels) != nrow(datapoints)) {
      msg <- sprintf("`labels` must be of length 1 or %s.", nrow(datapoints))
      stop(msg, call. = FALSE)
    }
    datapoints$labels = labels
    out = list(datapoints = datapoints)
    return(out)
  }
  return(fun)
}

draw_text =

function(adj = NULL, pos = NULL, offset = 0.5, vfont = NULL, font = NULL, xpd = NULL, srt = 0) {
  if (is.null(xpd)) xpd = par("xpd")
  fun = function(ix, iy, ilabels, icol, cex, ...) {
    text(
      x = ix, y = iy, labels = ilabels, col = icol,
      adj = adj, pos = pos, offset = offset,
      vfont = vfont, font = font,
      xpd = xpd,
      srt = srt,
      cex = cex
    )
  }
}

#' @title Lightweight extension of the base R plotting function
#'
#' @description
#' Enhances the base \code{\link[graphics]{plot}} function. Supported features
#' include automatic legends and facets for grouped data, additional plot types,
#' theme customization, and so on. Users can call either `tinyplot()`, or its
#' shorthand alias `plt()`.
#'
#' @md
#' @param x,y the x and y arguments provide the x and y coordinates for the
#'   plot. Any reasonable way of defining the coordinates is acceptable; most
#'   likely the names of existing vectors or columns of data frames. See the
#'   'Examples' section below, or the function
#'   \code{\link[grDevices]{xy.coords}} for details. If supplied separately, `x`
#'   and `y` must be of the same length.
#' @param xmin,xmax,ymin,ymax minimum and maximum coordinates of relevant area
#'   or interval plot types. Only used when the `type` argument is one of
#'   `"rect"` or `"segments"` (where all four min-max coordinates are required),
#'   or `"pointrange"`, `"errorbar"`, or `"ribbon"` (where only `ymin` and
#'   `ymax` required alongside `x`). In the formula method the arguments
#'   can be specified as `ymin = var` if `var` is a variable in `data`.
#' @param by grouping variable(s). The default behaviour is for groups to be
#'   represented in the form of distinct colours, which will also trigger an
#'   automatic legend. (See `legend` below for customization options.) However,
#'   groups can also be presented through other plot parameters (e.g., `pch` or
#'   `lty`) by passing an appropriate "by" keyword; see Examples. Note that
#'   continuous (i.e., gradient) colour legends are also supported if the user
#'   passes a numeric or integer to `by`. To group by multiple variables, wrap
#'   them with \code{\link[base]{interaction}}.
#' @param facet the faceting variable(s) that you want arrange separate plot
#'   windows by. Can be specified in various ways:
#'   - In "atomic" form, e.g. `facet = fvar`. To facet by multiple variables in
#'   atomic form, simply interact them, e.g.
#'   `interaction(fvar1, fvar2)` or `factor(fvar1):factor(fvar2)`.
#'   - As a one-sided formula, e.g. `facet = ~fvar`. Multiple variables can be
#'   specified in the formula RHS, e.g. `~fvar1 + fvar2` or `~fvar1:fvar2`. Note
#'   that these multi-variable cases are _all_ treated equivalently and
#'   converted to `interaction(fvar1, fvar2, ...)` internally. (No distinction
#'   is made between different types of binary operators, for example, and so
#'   `f1+f2` is treated the same as `f1:f2`, is treated the same as `f1*f2`,
#'   etc.)
#'   - As a two-side formula, e.g. `facet = fvar1 ~ fvar2`. In this case, the
#'   facet windows are arranged in a fixed grid layout, with the formula LHS
#'   defining the facet rows and the RHS defining the facet columns. At present
#'   only single variables on each side of the formula are well supported. (We
#'   don't recommend trying to use multiple variables on either the LHS or RHS
#'   of the two-sided formula case.)
#'   - As a special `"by"` convenience keyword, in which case facets will match
#'   the grouping variable(s) passed to `by` above.
#' @param facet.args an optional list of arguments for controlling faceting
#'   behaviour. (Ignored if `facet` is NULL.) Supported arguments are as
#'   follows:
#'   - `nrow`, `ncol` for overriding the default "square" facet window
#'   arrangement. Only one of these should be specified, but `nrow` will take
#'   precedence if both are specified together. Ignored if a two-sided formula
#'   is passed to the main `facet` argument, since the layout is arranged in a
#'   fixed grid.
#'   - `free` a logical value indicating whether the axis limits (scales) for
#'   each individual facet should adjust independently to match the range of
#'   the data within that facet. Default is `FALSE`. Separate free scaling of
#'   the x- or y-axis (i.e., whilst holding the other axis fixed) is not
#'   currently supported.
#'   - `fmar` a vector of form `c(b,l,t,r)` for controlling the base margin
#'   between facets in terms of lines. Defaults to the value of `tpar("fmar")`,
#'   which should be `c(1,1,1,1)`, i.e. a single line of padding around each
#'   individual facet, assuming it hasn't been overridden by the user as part
#'   their global \code{\link[tinyplot]{tpar}} settings. Note some automatic
#'   adjustments are made for certain layouts, and depending on whether the plot
#'   is framed or not, to reduce excess whitespace. See
#'   \code{\link[tinyplot]{tpar}} for more details.
#'   - `cex`, `font`, `col`, `bg`, `border` for adjusting the facet title text
#'   and background. Default values for these arguments are inherited from
#'   \code{\link[tinyplot]{tpar}} (where they take a "facet." prefix, e.g.
#'   `tpar("facet.cex")`). The latter function can also be used to set these
#'   features globally for all `tinyplot` plots.
#' @param formula a \code{\link[stats]{formula}} that optionally includes
#'   grouping variable(s) after a vertical bar, e.g. `y ~ x | z`. One-sided
#'   formulae are also permitted, e.g. `~ y | z`. Only a single `y` and `x`
#'   variable (if any) must be specified but multiple grouping variables
#'   can be included in different ways, e.g. `y ~ x | z1:z2` or
#'   `y ~ x | z1 + z2`. (These two representations are treated as equivalent;
#'   both are parsed as `interaction(z1, z2)` internally.) If arithmetic
#'   operators are used for transforming variables, they should be wrapped in
#'   `I()`, e.g., `I(y1/y2) ~ x`. Note that the `formula` and `x` arguments
#'   should not be specified in the same call.
#' @param data a data.frame (or list) from which the variables in formula
#'   should be taken. A matrix is converted to a data frame.
#' @param type character string or call to a `type_*()` function giving the
#'   type of plot desired.
#'   - NULL (default): Choose a sensible type for the type of `x` and `y` inputs
#'     (i.e., usually `"p"`).
#'   - 1-character values supported by \code{\link[graphics]{plot}}:
#'     - `"p"` Points
#'     - `"l"` Lines
#'     - `"b"` Both points and lines
#'     - `"c"` Empty points joined by lines
#'     - `"o"` Overplotted points and lines
#'     - `"s"` Stair steps
#'     - `"S"` Stair steps
#'     - `"h"` Histogram-like vertical lines
#'     - `"n"` Empty plot over the extent of the data
#'   - `tinyplot`-specific types. These fall into several categories:
#'     - Shapes:
#'       - `"area"` / [`type_area()`]: Plots the area under the curve from `y` = 0 to `y` = f(`x`).
#'       - `"errorbar"` / [`type_errorbar()`]: Adds error bars to points; requires `ymin` and `ymax`.
#'       - `"pointrange"` / [`type_pointrange()`]: Combines points with error bars.
#'       - `"polygon"` / [`type_polygon()`]: Draws polygons.
#'       - `"polypath"` / [`type_polypath()`]: Draws a path whose vertices are given in `x` and `y`.
#'       - `"rect"` / [`type_rect()`]: Draws rectangles; requires `xmin`, `xmax`, `ymin`, and `ymax`.
#'       - `"ribbon"` / [`type_ribbon()`]: Creates a filled area between `ymin` and `ymax`.
#'       - `"segments"` / [`type_segments()`]: Draws line segments between pairs of points.
#'       - `"text"` / [`type_text()`]: Add text annotations.
#'     - Visualizations:
#'       - `"barplot"` / [`type_barplot()`]: Creates a bar plot.
#'       - `"boxplot"` / [`type_boxplot()`]: Creates a box-and-whisker plot.
#'       - `"density"` / [`type_density()`]: Plots the density estimate of a variable.
#'       - `"histogram"` / [`type_histogram()`]: Creates a histogram of a single variable.
#'       - `"jitter"` / [`type_jitter()`]: Jittered points.
#'       - `"qq"` / [`type_qq()`]: Creates a quantile-quantile plot.
#'       - `"ridge"` / [`type_ridge()`]: Creates a ridgeline (aka joy) plot.
#'       - `"rug"` / [`type_rug()`]: Adds a rug to an existing plot.
#'       - `"spineplot"` / [`type_spineplot()`]: Creates a spineplot or spinogram.
#'       - `"violin"` / [`type_violin()`]: Creates a violin plot.
#'     - Models:
#'       - `"loess"` / [`type_loess()`]: Local regression curve.
#'       - `"lm"` / [`type_lm()`]: Linear regression line.
#'       - `"glm"` / [`type_glm()`]: Generalized linear model fit.
#'       - `"spline"` / [`type_spline()`]: Cubic (or Hermite) spline interpolation.
#'     - Functions:
#'       - [`type_abline()`]: line(s) with intercept and slope.
#'       - [`type_hline()`]: horizontal line(s).
#'       - [`type_vline()`]: vertical line(s).
#'       - [`type_function()`]: arbitrary function.
#'       - [`type_summary()`]: summarize `y` by unique values of `x`.
#' @param legend one of the following options:
#'    - NULL (default), in which case the legend will be determined by the
#'    grouping variable. If there is no group variable (i.e., `by` is NULL) then
#'    no legend is drawn. If a grouping variable is detected, then an automatic
#'    legend is drawn to the _outer_ right of the plotting area. Note that the
#'    legend title and categories will automatically be inferred from the `by`
#'    argument and underlying data.
#'    - A convenience string indicating the legend position. The string should
#'    correspond to one of the position keywords supported by the base `legend`
#'    function, e.g. "right", "topleft", "bottom", etc. In addition, `tinyplot`
#'    supports adding a trailing exclamation point to these keywords, e.g.
#'    "right!", "topleft!", or "bottom!". This will place the legend _outside_
#'    the plotting area and adjust the margins of the plot accordingly. Finally,
#'    users can also turn off any legend printing by specifying "none".
#'    - Logical value, where TRUE corresponds to the default case above (same
#'    effect as specifying NULL) and FALSE turns the legend off (same effect as
#'    specifying "none").
#'    - A list or, equivalently, a dedicated `legend()` function with supported
#'    legend arguments, e.g. "bty", "horiz", and so forth.
#' @param main a main title for the plot, see also `title`.
#' @param sub a subtitle for the plot.
#' @param xlab a label for the x axis, defaults to a description of x.
#' @param ylab a label for the y axis, defaults to a description of y.
#' @param ann a logical value indicating whether the default annotation (title
#'   and x and y axis labels) should appear on the plot.
#' @param xlim the x limits (x1, x2) of the plot. Note that x1 > x2 is allowed
#'   and leads to a ‘reversed axis’. The default value, NULL, indicates that
#'   the range of the `finite` values to be plotted should be used.
#' @param ylim the y limits of the plot.
#' @param axes logical or character. Should axes be drawn (`TRUE` or `FALSE`)?
#'   Or alternatively what type of axes should be drawn: `"standard"` (with
#'   axis, ticks, and labels; equivalent to `TRUE`), `"none"` (no axes;
#'   equivalent to `FALSE`), `"ticks"` (only ticks and labels without axis line),
#'   `"labels"` (only labels without ticks and axis line), `"axis"` (only axis
#'   line and labels but no ticks). To control this separately for the two
#'   axes, use the character specifications for `xaxt` and/or `yaxt`.
#' @param xaxt,yaxt character specifying the type of x-axis and y-axis,
#'   respectively. See `axes` for the possible values.
#' @param xaxs,yaxs character specifying the style of the interval calculation
#'   used for the x-axis and y-axis, respectively. See
#'   \code{\link[graphics]{par}} for the possible values.
#' @param xaxb,yaxb numeric vector (or character vector, if appropriate) giving
#'   the break points at which the axis tick-marks are to be drawn. Break points
#'   outside the range of the data will be ignored if the associated axis
#'   variable is categorical, or an explicit `x/ylim` range is given.
#' @param xaxl,yaxl a function or a character keyword specifying the format of
#'   the x- or y-axis tick labels. Note that this is a post-processing step that
#'   affects the _appearance_ of the tick labels only; use in conjunction with
#'   `x/yaxb` if you would like to adjust the position of the tick marks too. In
#'   addition to user-supplied formatting functions (e.g., [`format`],
#'   [`toupper`], [`abs`], or other custom function), several convenience
#'   keywords (or their symbol equivalents) are available for common formatting
#'   transformations: `"percent"` (`"%"`), `"comma"` (`","`), `"log"` (`"l"`),
#'   `"dollar"` (`"$"`), `"euro"` (`"€"`), or `"sterling"` (`"£"`). See the
#'   [`tinylabel`] documentation for examples.
#' @param log a character string which contains `"x"` if the x axis is to be
#'   logarithmic, `"y"` if the y axis is to be logarithmic and `"xy"` or `"yx"`
#'   if both axes are to be logarithmic.
#' @param flip logical. Should the plot orientation be flipped, so that the
#'   y-axis is on the horizontal plane and the x-axis is on the vertical plane?
#'   Default is FALSE.
#' @param frame.plot a logical indicating whether a box should be drawn around
#'   the plot. Can also use `frame` as an acceptable argument alias.
#'   The default is to draw a frame if both axis types (set via `axes`, `xaxt`,
#'   or `yaxt`) include axis lines.
#' @param grid argument for plotting a background panel grid, one of either:
#'    - a logical (i.e., `TRUE` to draw the grid), or
#'    - a panel grid plotting function like `grid()`.
#'   Note that this argument replaces the `panel.first` and `panel.last`
#'   arguments from base `plot()` and tries to make the process more seamless
#'   with better default behaviour. The default behaviour is determined by (and
#'   can be set globally through) the value of `tpar("grid")`.
#' @param palette one of the following options:
#'    - NULL (default), in which case the palette will be chosen according to
#'    the class and cardinality of the "by" grouping variable. For non-ordered
#'    factors or strings with a reasonable number of groups, this will inherit
#'    directly from the user's default \code{\link[grDevices]{palette}} (e.g.,
#'    "R4"). In other cases, including ordered factors and high cardinality, the
#'    "Viridis" palette will be used instead. Note that a slightly restricted
#'    version of the "Viridis" palette---where extreme color values have been
#'    trimmed to improve visual perception---will be used for ordered factors
#'    and continuous variables. In the latter case of a continuous grouping
#'    variable, we also generate a gradient legend swatch.
#'    - A convenience string corresponding to one of the many palettes listed by
#'    either `palette.pals()` or `hcl.pals()`. Note that the string can be
#'    case-insensitive (e.g., "Okabe-Ito" and "okabe-ito" are both valid).
#'    - A palette-generating function. This can be "bare" (e.g.,
#'    `palette.colors`) or "closed" with a set of named arguments (e.g.,
#'    `palette.colors(palette = "Okabe-Ito", alpha = 0.5)`). Note that any
#'    unnamed arguments will be ignored and the key `n` argument, denoting the
#'    number of colours, will automatically be spliced in as the number of
#'    groups.
#'    - A vector or list of colours, e.g. `c("darkorange", "purple", "cyan4")`.
#'    If too few colours are provided for a discrete (qualitative) set of
#'    groups, then the colours will be recycled with a warning. For continuous
#'    (sequential) groups, a gradient palette will be interpolated.
#' @param col plotting color. Character, integer, or vector of length equal to
#'   the number of categories in the `by` variable. See `col`. Note that the
#'   default behaviour in `tinyplot` is to vary group colors along any variables
#'   declared in the `by` argument. Thus, specifying colors manually should not
#'   be necessary unless users wish to override the automatic colors produced by
#'   this grouping process. Typically, this would only be done if grouping
#'   features are deferred to some other graphical parameter (i.e., passing the
#'   "by" keyword to one of `pch`, `lty`, `lwd`, or `bg`; see below.)
#' @param pch plotting "character", i.e., symbol to use. Character, integer, or
#'   vector of length equal to the number of categories in the `by` variable.
#'   See `pch`. In addition, users can supply a special `pch = "by"` convenience
#'   argument, in which case the characters will automatically loop over the
#'   number groups. This automatic looping will begin at the global character
#'   value (i.e., `par("pch")`) and recycle as necessary.
#' @param lty line type. Character, integer, or vector of length equal to the
#'   number of categories in the `by` variable. See `lty`. In addition, users
#'   can supply a special `lty = "by"` convenience argument, in which case the
#'   line type will automatically loop over the number groups. This automatic
#'   looping will begin at the global line type value (i.e., `par("lty")`) and
#'   recycle as necessary.
#' @param lwd line width. Numeric scalar or vector of length equal to the
#'   number of categories in the `by` variable. See `lwd`. In addition, users
#'   can supply a special `lwd = "by"` convenience argument, in which case the
#'   line width will automatically loop over the number of groups. This
#'   automatic looping will be centered at the global line width value (i.e.,
# `   par("lwd")`) and pad on either side of that.
#' @param bg background fill color for the open plot symbols 21:25 (see
#'   `points.default`), as well as ribbon and area plot types.
#'   Users can also supply either one of two special convenience arguments that
#'   will cause the background fill to inherit the automatic grouped coloring
#'   behaviour of `col`:
#'
#'   - `bg = "by"` will insert a background fill that inherits the main color
#'   mappings from `col`.
#'   - `by = <numeric[0,1]>` (i.e., a numeric in the range `[0,1]`) will insert
#'   a background fill that inherits the main color mapping(s) from `col`, but
#'   with added alpha-transparency.
#'
#'   For both of these convenience arguments, note that the (grouped) `bg`
#'   mappings will persist even if the (grouped) `col` defaults are themselves
#'   overridden. This can be useful if you want to preserve the grouped palette
#'   mappings by background fill but not boundary color, e.g. filled points. See
#'   examples.
#' @param fill alias for `bg`. If non-NULL values for both `bg` and `fill` are
#'   provided, then the latter will be ignored in favour of the former.
#' @param alpha a numeric in the range `[0,1]` for adjusting the alpha channel
#'   of the color palette, where 0 means transparent and 1 means opaque. Use
#'   fractional values, e.g. `0.5` for semi-transparency.
#' @param cex character expansion. A numerical vector (can be a single value)
#'   giving the amount by which plotting characters and symbols should be scaled
#'   relative to the default. Note that NULL is equivalent to 1.0, while NA
#'   renders the characters invisible.
#' @param subset,na.action,drop.unused.levels arguments passed to `model.frame`
#'   when extracting the data from `formula` and `data`.
#' @param add logical. If TRUE, then elements are added to the current plot rather
#'   than drawing a new plot window. Note that the automatic legend for the
#'   added elements will be turned off. See also [tinyplot_add], which provides
#'   a convenient wrapper around this functionality for layering on top of an
#'   existing plot without having to repeat arguments.
#' @param draw a function that draws directly on the plot canvas (before `x` and
#'   `y` are plotted). The `draw` argument is primarily useful for adding common
#'   elements to each facet of a faceted plot, e.g.
#'   \code{\link[graphics]{abline}} or \code{\link[graphics]{text}}. Note that
#'   this argument is somewhat experimental and that _no_ internal checking is
#'   done for correctness; the provided argument is simply captured and
#'   evaluated as-is. See Examples.
#' @param restore.par a logical value indicating whether the
#'   \code{\link[graphics]{par}} settings prior to calling `tinyplot` should be
#'   restored on exit. Defaults to FALSE, which makes it possible to add
#'   elements to the plot after it has been drawn. However, note the the outer
#'   margins of the graphics device may have been altered to make space for the
#'   `tinyplot` legend. Users can opt out of this persistent behaviour by
#'   setting to TRUE instead. See also [get_saved_par] for another option to
#'   recover the original \code{\link[graphics]{par}} settings, as well as
#'   longer discussion about the trade-offs involved.
#' @param empty logical indicating whether the interior plot region should be
#'  left empty. The default is `FALSE`. Setting to `TRUE` has a similar effect
#'  to invoking `type = "n"` above, except that any legend artifacts owing to a
#'  particular plot type (e.g., lines for `type = "l"` or squares for
#'  `type = "area"`) will still be drawn correctly alongside the empty plot. In
#'  contrast,`type = "n"` implicitly assumes a scatterplot and so any legend
#'  will only depict points.
#' @param file character string giving the file path for writing a plot to disk.
#'   If specified, the plot will not be displayed interactively, but rather sent
#'   to the appropriate external graphics device (i.e.,
#'   \code{\link[grDevices]{png}}, \code{\link[grDevices]{jpeg}},
#'   \code{\link[grDevices]{pdf}}, or \code{\link[grDevices]{svg}}). As a point
#'   of convenience, note that any global parameters held in `(t)par` are
#'   automatically carried over to the external device and don't need to be
#'   reset (in contrast to the conventional base R approach that requires
#'   manually opening and closing the device). The device type is determined by
#'   the file extension at the end of the provided path, and must be one of
#'   ".png", ".jpg" (".jpeg"), ".pdf", or ".svg". (Other file types may be
#'   supported in the future.) The file dimensions can be controlled by the
#'   corresponding `width` and `height` arguments below, otherwise will fall
#'   back to the `"file.width"` and `"file.height"` values held in
#'   \code{\link[tinyplot]{tpar}} (i.e., both defaulting to 7 inches, and where
#'   the default resolution for bitmap files is also specified as 300
#'   DPI).
#' @param width numeric giving the plot width in inches. Together with `height`,
#'  typically used in conjunction with the `file` argument above, overriding the
#'  default values held in `tpar("file.width", "file.height")`. If either `width`
#'  or `height` is specified, but a corresponding `file` argument is not
#'  provided as well, then a new interactive graphics device dimensions will be
#'  opened along the given dimensions. Note that this interactive resizing may
#'  not work consistently from within an IDE like RStudio that has an integrated
#'  graphics windows.
#' @param height numeric giving the plot height in inches. Same considerations as
#'  `width` (above) apply, e.g. will default to `tpar("file.height")` if not
#'  specified.
#' @param asp the y/xy/x aspect ratio, see `plot.window`.
#' @param ... other graphical parameters. If `type` is a character specification
#'   (such as `"hist"`) then any argument names that match those from the corresponding
#'   `type_*()` function (such as \code{\link{type_hist}}) are passed on to that.
#'   All remaining arguments from `...` can be further graphical parameters, see
#'   \code{\link[graphics]{par}}).
#'
#' @returns No return value, called for side effect of producing a plot.
#'
#' @details
#' Disregarding the enhancements that it supports, `tinyplot` tries as far as
#' possible to mimic the behaviour and syntax logic of the original base
#' \code{\link[graphics]{plot}} function. Users should therefore be able to swap
#' out existing `plot` calls for `tinyplot` (or its shorthand alias `plt`),
#' without causing unexpected changes to the output.
#'
#' @importFrom grDevices axisTicks adjustcolor cairo_pdf colorRampPalette extendrange palette palette.colors palette.pals hcl.colors hcl.pals xy.coords png jpeg pdf svg dev.off dev.new dev.list
#' @importFrom graphics abline arrows axis Axis axTicks box boxplot grconvertX grconvertY hist lines mtext par plot.default plot.new plot.window points polygon polypath segments rect text title
#' @importFrom utils modifyList head tail
#' @importFrom stats na.omit
#' @importFrom tools file_ext
#'
#' @examples
#' aq = transform(
#'   airquality,
#'   Month = factor(Month, labels = month.abb[unique(Month)])
#' )
#'
#' # In most cases, `tinyplot` should be a drop-in replacement for regular
#' # `plot` calls. For example:
#'
#' op = tpar(mfrow = c(1, 2))
#' plot(0:10, main = "plot")
#' tinyplot(0:10, main = "tinyplot")
#' tpar(op) # restore original layout
#'
#' # Aside: `tinyplot::tpar()` is a (near) drop-in replacement for `par()`
#'
#' # Unlike vanilla plot, however, tinyplot allows you to characterize groups
#' # using either the `by` argument or equivalent `|` formula syntax.
#'
#' with(aq, tinyplot(Day, Temp, by = Month)) ## atomic method
#' tinyplot(Temp ~ Day | Month, data = aq) ## formula method
#'
#' # (Notice that we also get an automatic legend.)
#'
#' # You can also use the equivalent shorthand `plt()` alias if you'd like to
#' # save on a few keystrokes
#'
#' plt(Temp ~ Day | Month, data = aq) ## shorthand alias
#'
#' # Use standard base plotting arguments to adjust features of your plot.
#' # For example, change `pch` (plot character) to get filled points and `cex`
#' # (character expansion) to increase their size.
#'
#' tinyplot(
#'   Temp ~ Day | Month,
#'   data = aq,
#'   pch = 16,
#'   cex = 2
#' )
#'
#' # We can add alpha transparency for overlapping points
#'
#' tinyplot(
#'   Temp ~ Day | Month,
#'   data = aq,
#'   pch = 16,
#'   cex = 2,
#'   alpha = 0.3
#' )
#'
#' # To get filled points with a common solid background color, use an
#' # appropriate plotting character (21:25) and combine with one of the special
#' # `bg` convenience arguments.
#' tinyplot(
#'   Temp ~ Day | Month,
#'   data = aq,
#'   pch = 21, # use filled circles
#'   cex = 2,
#'   bg = 0.3, # numeric in [0,1] adds a grouped background fill with transparency
#'   col = "black" # override default color mapping; give all points a black border
#' )
#'
#' # Converting to a grouped line plot is a simple matter of adjusting the
#' # `type` argument.
#'
#' tinyplot(
#'   Temp ~ Day | Month,
#'   data = aq,
#'   type = "l"
#' )
#'
#' # Similarly for other plot types, including some additional ones provided
#' # directly by tinyplot, e.g. density plots or internal plots (ribbons,
#' # pointranges, etc.)
#'
#' tinyplot(
#'   ~ Temp | Month,
#'   data = aq,
#'   type = "density",
#'   fill = "by"
#' )
#'
#' # Facet plots are supported too. Facets can be drawn on their own...
#'
#' tinyplot(
#'   Temp ~ Day,
#'   facet = ~Month,
#'   data = aq,
#'   type = "area",
#'   main = "Temperatures by month"
#' )
#'
#' # ... or combined/contrasted with the by (colour) grouping.
#'
#' aq = transform(aq, Summer = Month %in% c("Jun", "Jul", "Aug"))
#' tinyplot(
#'   Temp ~ Day | Summer,
#'   facet = ~Month,
#'   data = aq,
#'   type = "area",
#'   palette = "dark2",
#'   main = "Temperatures by month and season"
#' )
#'
#' # Users can override the default square window arrangement by passing `nrow`
#' # or `ncol` to the helper facet.args argument. Note that we can also reduce
#' # axis label repetition across facets by turning the plot frame off.
#'
#' tinyplot(
#'   Temp ~ Day | Summer,
#'   facet = ~Month, facet.args = list(nrow = 1),
#'   data = aq,
#'   type = "area",
#'   palette = "dark2",
#'   frame = FALSE,
#'   main = "Temperatures by month and season"
#' )
#'
#' # Use a two-sided formula to arrange the facet windows in a fixed grid.
#' # LHS -> facet rows; RHS -> facet columns
#'
#' aq$hot = ifelse(aq$Temp >= 75, "hot", "cold")
#' aq$windy = ifelse(aq$Wind >= 15, "windy", "calm")
#' tinyplot(
#'   Temp ~ Day,
#'   facet = windy ~ hot,
#'   data = aq
#' )
#'
#' # To add common elements to each facet, use the `draw` argument
#'
#' tinyplot(
#'   Temp ~ Day,
#'   facet = windy ~ hot,
#'   data = aq,
#'   draw = abline(h = 75, lty = 2, col = "hotpink")
#' )
#'
#' # The (automatic) legend position and look can be customized using
#' # appropriate arguments. Note the trailing "!" in the `legend` position
#' # argument below. This tells `tinyplot` to place the legend _outside_ the plot
#' # area.
#'
#' tinyplot(
#'   Temp ~ Day | Month,
#'   data = aq,
#'   type = "l",
#'   legend = legend("bottom!", title = "Month of the year", bty = "o")
#' )
#'
#' # The default group colours are inherited from either the "R4" or "Viridis"
#' # palettes, depending on the number of groups. However, all palettes listed
#' # by `palette.pals()` and `hcl.pals()` are supported as convenience strings,
#' # or users can supply a valid palette-generating function for finer control
#'
#' tinyplot(
#'   Temp ~ Day | Month,
#'   data = aq,
#'   type = "l",
#'   palette = "tableau"
#' )
#'
#' # It's possible to customize the look of your plots by setting graphical
#' # parameters (e.g., via `(t)par`)... But a more convenient way is to just use
#' # built-in themes (see `?tinytheme`).
#'
#' tinytheme("clean2")
#' tinyplot(
#'   Temp ~ Day | Month,
#'   data = aq,
#'   type = "b",
#'   alpha = 0.5,
#'   main = "Daily temperatures by month",
#'   sub = "Brought to you by tinyplot"
#' )
#' # reset the theme
#' tinytheme()
#'
#' # For more examples and a detailed walkthrough, please see the introductory
#' # tinyplot tutorial available online:
#' # https://grantmcdermott.com/tinyplot/vignettes/introduction.html
#'
#' @rdname tinyplot
#' @export
tinyplot =
  function(x, ...) {
    UseMethod("tinyplot")
  }

#' @rdname tinyplot
#' @export
tinyplot.default = function(
    x = NULL,
    y = NULL,
    xmin = NULL,
    xmax = NULL,
    ymin = NULL,
    ymax = NULL,
    by = NULL,
    facet = NULL,
    facet.args = NULL,
    data = NULL,
    type = NULL,
    legend = NULL,
    main = NULL,
    sub = NULL,
    xlab = NULL,
    ylab = NULL,
    ann = par("ann"),
    xlim = NULL,
    ylim = NULL,
    axes = TRUE,
    xaxt = NULL,
    yaxt = NULL,
    xaxs = NULL,
    yaxs = NULL,
    xaxb = NULL,
    yaxb = NULL,
    xaxl = NULL,
    yaxl = NULL,
    log = "",
    flip = FALSE,
    frame.plot = NULL,
    grid = NULL,
    palette = NULL,
    pch = NULL,
    lty = NULL,
    lwd = NULL,
    col = NULL,
    bg = NULL,
    fill = NULL,
    alpha = NULL,
    cex = 1,
    add = FALSE,
    draw = NULL,
    empty = FALSE,
    restore.par = FALSE,
    file = NULL,
    width = NULL,
    height = NULL,
    asp = NA,
    ...) {

  par_first = get_saved_par("first")
  if (is.null(par_first)) set_saved_par("first", par())

  assert_logical(add)

  # save for tinyplot_add()
  if (!add) {
    calls = sys.calls()
    idx = grep("^tinyplot", sapply(calls, function(k) k[[1]]))
    if (length(idx) > 0) {
      options(tinyplot_last_call = calls[[idx[1]]])
    }
    ## TODO: remove the global option above and move to this when density is refactored
    # cal = match.call(call = sys.call(sys.parent()), expand.dots = TRUE)
    # assign(".last_call", cal, envir = get(".tinyplot_env", envir = parent.env(environment())))
  }

  dots = list(...)

  if (add) legend = FALSE
  draw = substitute(draw)

  # sanitize arguments

  # type factories vs. strings
  type = sanitize_type(type, x, y, dots)
  if ("dots" %in% names(type)) dots = type$dots

  # retrieve type-specific data and drawing functions
  type_data = type$data
  type_draw = type$draw
  type = type$name

  # area flag (mostly for legend)
  was_area_type = identical(type, "area")
  # check flip flag is logical
  assert_flag(flip)

  palette = substitute(palette)

  # themes
  if (is.null(palette)) palette = get_tpar("palette", default = NULL)
  if (is.null(pch)) pch = get_tpar("pch", default = NULL)

  xlabs = ylabs = NULL

  # type_ridge()
  ygroup = NULL

  # will be overwritten by some type_data() functions and ignored by others
  ribbon.alpha = sanitize_ribbon.alpha(NULL)

  ## handle defaults of axes, xaxt, yaxt, frame.plot
  ## - convert axes to character if necessary
  ## - set defaults of xaxt/yaxt (if these are NULL) based on axes
  ## - set logical axes based on xaxt/yaxt
  ## - set frame.plot default based on xaxt/yaxt
  if (isFALSE(axes)) {
    axes = xaxt = yaxt = "none"
  } else if (isTRUE(axes)) {
    axes = "standard"
    if (is.null(xaxt)) xaxt = get_tpar("xaxt", default = "standard")
    if (is.null(yaxt)) yaxt = get_tpar("yaxt", default = "standard")
  } else {
    xaxt = yaxt = axes
  }
  axis_types = c("standard", "none", "labels", "ticks", "axis")
  axes = match.arg(axes, axis_types)
  xaxt = match.arg(xaxt, axis_types)
  yaxt = match.arg(yaxt, axis_types)
  xaxt = substr(match.arg(xaxt, axis_types), 1L, 1L)
  yaxt = substr(match.arg(yaxt, axis_types), 1L, 1L)
  axes = any(c(xaxt, yaxt) != "n")
  if (is.null(frame.plot) || !is.logical(frame.plot)) frame.plot = all(c(xaxt, yaxt) %in% c("s", "a"))

  # Write plot to output file or window with fixed dimensions
  setup_device(file = file, width = width, height = height)
  if (!is.null(file)) on.exit(dev.off(), add = TRUE)

  # Save current graphical parameters
  opar = par(no.readonly = TRUE)
  if (restore.par || !is.null(facet)) {
    if (!is.null(file) || !is.null(width) || !is.null(height)) {
      opar$new = FALSE # catch for some interfaces
    }
    on.exit(par(opar), add = TRUE)
  }
  # set_orig_par(opar)
  set_saved_par(when = "before", opar)

  # catch for adding to existing facet plot
  if (!is.null(facet) && add) {
    recordGraphics(
      par(get_saved_par(when = "after")),
      list = list(),
      env = getNamespace('tinyplot')
    )
  }

  # Capture deparsed expressions early, before x, y and by are evaluated
  x_dep = if (!is.null(x)) {
    deparse1(substitute(x))
  } else if (type %in% c("rect", "segments")) {
    x = NULL
    NULL
  }
  y_dep = if (is.null(y)) {
    deparse1(substitute(x))
  } else {
    deparse1(substitute(y))
  }
  by_dep = deparse1(substitute(by))
  null_by = is.null(by)

  ## coerce character variables to factors
  if (!is.null(x) && is.character(x)) x = factor(x)
  if (!is.null(y) && is.character(y)) y = factor(y)
  if (!null_by && is.character(by)) by = factor(by)

  # flag if x==by (currently only used for "boxplot", "spineplot" and "ridges" types)
  x_by = identical(x, by)

  facet_dep = deparse1(substitute(facet))
  # flag if facet==by
  facet_by = FALSE
  if (!is.null(facet) && length(facet) == 1 && facet == "by") {
    by = as.factor(by) ## if by==facet, then both need to be factors
    facet = by
    facet_by = TRUE
  } else if (!is.null(facet) && inherits(facet, "formula")) {
    facet = get_facet_fml(facet, data = data)
    if (isTRUE(attr(facet, "facet_grid"))) {
      facet.args[["nrow"]] = attr(facet, "facet_nrow")
    }
  }
  facet_attr = attributes(facet) ## TODO: better solution for restoring facet attributes?
  null_facet = is.null(facet)

  if (is.null(x)) {
    ## Special catch for rect and segment plots without a specified y-var
    if (type %in% c("rect", "segments")) {
      xmin_dep = deparse(substitute(xmin))
      xmax_dep = deparse(substitute(xmax))
      x_dep = paste0("[", xmin_dep, ", ", xmax_dep, "]")
      x = rep(NA, length(x))
    }
  }
  if (is.null(y)) {
    ## Special catch for area and interval plots without a specified y-var
    if (type %in% c("rect", "segments", "pointrange", "errorbar", "ribbon")) {
      ymin_dep = deparse(substitute(ymin))
      ymax_dep = deparse(substitute(ymax))
      y_dep = paste0("[", ymin_dep, ", ", ymax_dep, "]")
      y = rep(NA, length(x))
    } else if (type == "density") {
      if (is.null(ylab)) ylab = "Density"
    } else if (type == "function") {
      if (is.null(ylab)) ylab = "Frequency"
    } else if (!(type %in% c("histogram", "barplot"))) {
      y = x
      x = seq_along(x)
      if (is.null(xlab)) xlab = "Index"
    }
  }

  if (is.null(xlab)) xlab = x_dep
  if (is.null(ylab) && type != "histogram") ylab = y_dep

  # flag(s) indicating whether x/ylim was set by the user (needed later for
  # special case where facets are free but still want to set x/ylim manually)
  xlim_user = !is.null(xlim)
  ylim_user = !is.null(ylim)

  # alias
  if (is.null(bg) && !is.null(fill)) bg = fill

  datapoints = list(x = x, y = y, xmin = xmin, xmax = xmax, ymin = ymin, ymax = ymax, ygroup = ygroup)
  datapoints = Filter(function(z) length(z) > 0, datapoints)
  datapoints = data.frame(datapoints)
  if (nrow(datapoints) > 0) {
    datapoints[["rowid"]] = seq_len(nrow(datapoints))
    datapoints[["facet"]] = if (!is.null(facet)) facet else ""
    datapoints[["by"]] = if (!null_by) by else ""
  }

  ## initialize empty list with information that type_data
  ## can overwrite in order to pass on to type_draw
  type_info = list()

  if (!is.null(type_data)) {
    fargs = list(
      datapoints   = datapoints,
      bg           = bg,
      by           = by,
      col          = col,
      log          = log,
      lty          = lty,
      lwd          = lwd,
      facet        = facet,
      facet_by     = facet_by,
      facet.args   = facet.args,
      null_by      = null_by,
      null_facet   = null_facet,
      palette      = palette,
      ribbon.alpha = ribbon.alpha,
      xaxt         = xaxt,
      xaxb         = xaxb,
      xaxl         = xaxl,
      xlab         = xlab,
      xlabs        = xlabs,
      xlim         = xlim,
      yaxt         = yaxt,
      yaxb         = yaxb,
      yaxl         = yaxl,
      ylab         = ylab,
      ylim         = ylim
    )
    fargs = c(fargs, dots)
    list2env(do.call(type_data, fargs), environment())
  }

  # swap x and y values if flip is TRUE
  assert_flag(flip)
  # extra catch for boxplots
  # now swap the values
  if (isTRUE(flip)) {
    if (type != "boxplot") {
      # limits, labs, etc.
      xlim_cp = xlim
      xlim = ylim
      ylim = xlim_cp
      xlab_cp = xlab
      xlab = ylab
      ylab = xlab_cp
      xlabs_cp = xlabs
      xlabs = ylabs
      ylabs = xlabs_cp
      xaxt_cp = xaxt
      xaxt = yaxt
      yaxt = xaxt_cp
      xaxs_cp = xaxs
      xaxs = yaxs
      yaxs = xaxs_cp
      xaxb_cp = xaxb
      xaxb = yaxb
      yaxb = xaxb_cp
      xaxl_cp = xaxl
      xaxl = yaxl
      yaxl = xaxl_cp
      if (!is.null(log)) {
        log = if (log == "x") "y" else if (log == "y") "x" else log
      }
      # x/y vars
      x_cp = datapoints[["x"]]
      datapoints[["x"]] = datapoints[["y"]]
      datapoints[["y"]] = x_cp
      # x/y min and max vars
      xmin_cp = if (!is.null(datapoints[["xmin"]])) datapoints[["xmin"]] else NULL
      datapoints[["xmin"]] = if (!is.null(datapoints[["ymin"]])) datapoints[["ymin"]] else NULL
      datapoints[["ymin"]] = if (!is.null(xmin_cp)) xmin_cp else NULL
      xmax_cp = if (!is.null(datapoints[["xmax"]])) datapoints[["xmax"]] else NULL
      datapoints[["xmax"]] = if (!is.null(datapoints[["ymax"]])) datapoints[["ymax"]] else NULL
      datapoints[["ymax"]] = if (!is.null(xmax_cp)) xmax_cp else NULL
      # clean up
      rm(xlim_cp, xlab_cp, xlabs_cp, xaxt_cp, xaxs_cp, xaxb_cp, xaxl_cp, x_cp, xmin_cp, xmax_cp)
    } else {
      # We'll let boxplot(..., horizontal = TRUE) handle most of the adjustments
      # and just catch a few elements that we draw beforehand.
      xlab_cp = xlab
      xlab = ylab
      ylab = xlab_cp
      rm(xlab_cp)
    }
  }

  # For cases where x/yaxb is provided and corresponding x/ylabs is not null...
  # We can subset these here to provide breaks
  if (!is.null(xaxb) && !is.null(xlabs)) {
    xlabs = xlabs[names(xlabs) %in% xaxb]
    xaxb = NULL # don't need this any more
  }
  if (!is.null(yaxb) && !is.null(ylabs)) {
    ylabs = ylabs[names(ylabs) %in% yaxb]
    yaxb = NULL # don't need this any more
  }

  # plot limits
  fargs = lim_args(
    datapoints = datapoints,
    xlim = xlim, ylim = ylim,
    xaxb = xaxb, yaxb = yaxb,
    xlim_user = xlim_user, ylim_user = ylim_user,
    type = type
  )
  list2env(fargs, environment())

  # split data
  by_ordered = FALSE
  by_continuous = !null_by && inherits(datapoints$by, c("numeric", "integer"))
  if (isTRUE(by_continuous) && type %in% c("l", "b", "o", "ribbon", "polygon", "polypath", "boxplot")) {
    warning("\nContinuous legends not supported for this plot type. Reverting to discrete legend.")
    by_continuous = FALSE
  } else if (!null_by) {
    by_ordered = is.ordered(by)
  }

  if (length(unique(datapoints$facet)) == 1) {
    datapoints[["facet"]] = NULL
  }
  if (!is.null(datapoints$facet)) {
    split_data = split(datapoints, datapoints$facet)
    split_data = lapply(split_data, as.list)
  } else {
    split_data = list(as.list(datapoints))
  }

  # aesthetics by group: col, bg, etc.
  ngrps = if (null_by) 1L else if (is.factor(by)) length(levels(by)) else if (by_continuous) 100L else length(unique(by))
  pch = by_pch(ngrps = ngrps, type = type, pch = pch)
  lty = by_lty(ngrps = ngrps, type = type, lty = lty)
  lwd = by_lwd(ngrps = ngrps, type = type, lwd = lwd)
  col = by_col(
    ngrps = ngrps, col = col, palette = palette,
    gradient = by_continuous, ordered = by_ordered, alpha = alpha)
  bg = by_bg(
    adjustcolor = adjustcolor, alpha = alpha, bg = bg, by = by, by_continuous = by_continuous,
    by_ordered = by_ordered, col = col, fill = fill, palette = substitute(palette),
    ribbon.alpha = ribbon.alpha, ngrps = ngrps, type = type)

  ncolors = length(col)
  lgnd_labs = rep(NA, times = ncolors)
  if (isTRUE(by_continuous)) {
    ## Identify the pretty break points for our labels
    nlabs = 5
    ncolors = length(col)
    ubyvar = unique(by)
    byvar_range = range(ubyvar)
    pbyvar = pretty(byvar_range, n = nlabs)
    pbyvar = pbyvar[pbyvar >= byvar_range[1] & pbyvar <= byvar_range[2]]
    # optional thinning
    if (length(ubyvar) == 2 && all(ubyvar %in% pbyvar)) {
      pbyvar = ubyvar
    } else if (length(pbyvar) > nlabs) {
      pbyvar = pbyvar[seq_along(pbyvar) %% 2 == 0]
    }
    ## Find the (approximate) location of our pretty labels
    pidx = rescale_num(c(byvar_range, pbyvar), to = c(1, ncolors))[-c(1:2)]
    pidx = round(pidx)
    lgnd_labs[pidx] = pbyvar
  }

  # Determine the number and arrangement of facets.
  # Note: We're do this up front, so we can make some adjustments to legend cex
  #   next (if there are facets). But the actual drawing of the facets will only
  #   come later.
  attributes(datapoints$facet) = facet_attr ## TODO: better solution for restoring facet attributes?
  fargs = facet_layout(facet = datapoints$facet, facet.args = facet.args, add = add)
  list2env(fargs, environment())

  #
  ## Global plot elements (legend and titles)
  #

  # place and draw the legend
  has_legend = FALSE # simple indicator variable for later use

  if (!exists("legend_args")) {
    legend_args = dots[["legend_args"]]
  }
  if (is.null(legend_args)) legend_args = list(x = NULL)
  legend = substitute(legend)

  if (isFALSE(legend)) {
    legend = "none"
  } else if (isTRUE(legend)) {
    legend = NULL
  }
  if (!is.null(legend) && legend == "none") {
    legend_args[["x"]] = "none"
  }

  if (null_by) {
    if (is.null(legend)) {
      legend = "none"
      legend_args[["x"]] = "none"
    }
  }

  if ((is.null(legend) || legend != "none") && !add) {
    if (isFALSE(by_continuous)) {
      if (ngrps > 1) {
        lgnd_labs = if (is.factor(datapoints$by)) levels(datapoints$by) else unique(datapoints$by)
      } else {
        lgnd_labs = ylab
      }
    }

    has_sub = !is.null(sub)

    if (isTRUE(was_area_type) || isTRUE(type %in% c("area", "rect", "hist", "histogram"))) {
      legend_args[["pt.lwd"]] = par("lwd")
      legend_args[["lty"]] = 0
    }

    draw_legend(
      legend = legend,
      legend_args = legend_args,
      by_dep = by_dep,
      lgnd_labs = lgnd_labs,
      type = type,
      pch = pch,
      lty = lty,
      lwd = lwd,
      col = col,
      bg = bg,
      gradient = by_continuous,
      cex = cex * cex_fct_adj,
      has_sub = has_sub
    )

    has_legend = TRUE
  } else if (legend_args[["x"]] == "none" && !add) {
    omar = par("mar")
    ooma = par("oma")
    topmar_epsilon = 0.1

    # Catch to avoid recursive offsets, e.g. repeated tinyplot calls with
    # "bottom!" legend position.

    ## restore inner margin defaults
    ## (in case the plot region/margins were affected by the preceding tinyplot call)
    if (any(ooma != 0)) {
      if (ooma[1] != 0 && omar[1] == par("mgp")[1] + 1 * par("cex.lab")) omar[1] = 5.1
      if (ooma[2] != 0 && omar[2] == par("mgp")[1] + 1 * par("cex.lab")) omar[2] = 4.1
      if (ooma[3] == topmar_epsilon && omar[3] != 4.1) omar[3] = 4.1
      if (ooma[4] != 0 && omar[4] == 0) omar[4] = 2.1
      par(mar = omar)
    }
    ## restore outer margin defaults (with a catch for custom mfrow plots)
    if (all(par("mfrow") == c(1, 1))) {
      par(omd = c(0, 1, 0, 1))
    }

    # clean up for now
    rm(omar, ooma, topmar_epsilon)

    # Draw new plot
    plot.new()
  }

  # Titles. Only draw these if add = FALSE
  if (!add) {
    # main title
    # Note that we include a special catch for the main title if legend is
    # "top!" (and main is specified in the first place).
    legend_eval = tryCatch(eval(legend), error = function(e) NULL)
    # Extra bit of footwork if user passed legend = legend(...) instead of
    # legend = list(...), since the call environment is tricky
    if (is.null(legend_eval)) {
      legend_eval = tryCatch(paste0(legend)[[2]], error = function(e) NULL)
    }

    adj_title = !is.null(legend) && (legend == "top!" || (!is.null(legend_args[["x"]]) && legend_args[["x"]] == "top!") || (is.list(legend_eval) && legend_eval[[1]] == "top!"))

    # For the "top!" legend case, bump main title up to make space for the
    # legend beneath it: Take the normal main title line gap (i.e., 1.7 lines)
    # and add the difference between original top margin and new one (i.e.,
    # which should equal the height of the new legend). Note that we also
    # include a 0.1 epsilon bump, which we're using to reset the tinyplot
    # window in case of recursive "top!" calls. (See draw_legend code.)

    if (isTRUE(adj_title)) {
      line_main = par("mar")[3] - opar[["mar"]][3] + 1.7 + 0.1
    } else {
      line_main = NULL
    }

    if (!is.null(sub)) {
      if (isTRUE(get_tpar("side.sub", 1) == 3)) {
        if (is.null(line_main)) line_main = par("mgp")[3] + 1.7 - .1
        line_main = line_main + 1.2
      }
      if (isTRUE(get_tpar("side.sub", 1) == 3)) {
        line_sub = get_tpar("line.sub", 1.7)
      } else {
        line_sub = get_tpar("line.sub", 4)
      }
      args = list(
        text = sub,
        line = line_sub,
        cex = get_tpar("cex.sub", 1.2),
        col = get_tpar("col.sub", "black"),
        adj = get_tpar(c("adj.sub", "adj")),
        font = get_tpar("font.sub", 1),
        side = get_tpar("side.sub", 1),
        las = 1
      )
      args = Filter(function(x) !is.null(x), args)
      do.call(mtext, args)
    }

    if (!is.null(main)) {
      args = list(
        main = main,
        line = line_main,
        cex.main = get_tpar("cex.main", 1.4),
        col.main = get_tpar("col.main", "black"),
        font.main = get_tpar("font.main", 2),
        adj = get_tpar(c("adj.main", "adj"), 3))
      args = Filter(function(x) !is.null(x), args)
      do.call(title, args)
    }

    # Axis titles
    args = list(xlab = xlab)
    args[["adj"]] = get_tpar(c("adj.xlab", "adj"))
    do.call(title, args)
    args = list(ylab = ylab)
    args[["adj"]] = get_tpar(c("adj.ylab", "adj"))
    do.call(title, args)
  }

  #
  ## Exterior plot elements (plot and facet windows, axes, etc.)
  #

  omar = NULL # Placeholder variable for now, which we re-assign as part of facet margins

  # placeholders for facet_window_args() call
  facet_newlines = facet_text = facet_rect = facet_font = facet_col = facet_bg = facet_border = NULL

  if (!is.null(facet) && !add) {
    if (is.null(omar)) omar = par("mar")

    # Grab some of the customizable facet args that we'll be using later
    facet_rect = FALSE
    facet_text = .tpar[["facet.cex"]]
    facet_font = .tpar[["facet.font"]]
    facet_col = .tpar[["facet.col"]]
    facet_bg = .tpar[["facet.bg"]]
    facet_border = .tpar[["facet.border"]]
    if (!is.null(facet.args)) {
      if (!is.null(facet.args[["cex"]])) facet_text = facet.args[["cex"]]
      if (!is.null(facet.args[["col"]])) facet_col = facet.args[["col"]]
      if (!is.null(facet.args[["font"]])) facet_font = facet.args[["font"]]
      if (!is.null(facet.args[["bg"]])) facet_bg = facet.args[["bg"]]
      if (!is.null(facet.args[["border"]])) facet_border = facet.args[["border"]]
    }
    if (!is.null(facet_bg) || !is.null(facet_border)) facet_rect = TRUE

    # Need extra adjustment to top margin if facet titles have "\n" newline
    # separator. (Note that we'll also need to take account for this in the
    # individual facet margins / gaps further below.)
    facet_newlines = lengths(gregexpr("\n", grep("\\n", facets, value = TRUE)))
    # if (length(facet_newlines)==0) facet_newlines = 0
    # omar[3] = omar[3] + max(facet_newlines)
    facet_newlines = ifelse(length(facet_newlines) == 0, 0, max(facet_newlines))
    omar[3] = omar[3] + facet_newlines * facet_text / cex_fct_adj
    # apply the changes
    par(mar = omar)
  }

  # Now draw the individual facet windows (incl. axes, grid lines, and facet titles)
  # Will be skipped if adding to an existing plot; see ?facet

  facet_window_args = recordGraphics(
    draw_facet_window(
      add = add,
      # facet-specific args
      cex_fct_adj = cex_fct_adj,
      facet.args = facet.args,
      facet_newlines = facet_newlines, facet_font = facet_font,
      facet_rect = facet_rect, facet_text = facet_text,
      facet_col = facet_col, facet_bg = facet_bg, facet_border = facet_border,
      facet = facet,
      facets = facets, ifacet = ifacet,
      nfacets = nfacets, nfacet_cols = nfacet_cols, nfacet_rows = nfacet_rows,
      # axes args
      axes = axes, flip = flip, frame.plot = frame.plot,
      oxaxis = oxaxis, oyaxis = oyaxis,
      xlabs = xlabs, xlim = xlim, xlim_user = xlim_user, xaxt = xaxt, xaxs = xaxs, xaxb = xaxb, xaxl = xaxl,
      ylabs = ylabs, ylim = ylim, ylim_user = ylim_user, yaxt = yaxt, yaxs = yaxs, yaxb = yaxb, yaxl = yaxl,
      asp = asp, log = log,
      # other args (in approx. alphabetical + group ordering)
      dots = dots,
      draw = draw,
      grid = grid,
      has_legend = has_legend,
      type = type,
      x = x, xmax = xmax, xmin = xmin,
      y = y, ymax = ymax, ymin = ymin
    ),
    list = list(
      add = add,
      cex_fct_adj = cex_fct_adj,
      facet.args = facet.args,
      facet_newlines = facet_newlines, facet_font = facet_font,
      facet_rect = facet_rect, facet_text = facet_text,
      facet_col = facet_col, facet_bg = facet_bg, facet_border = facet_border,
      facet = datapoints$facet,
      facets = facets, ifacet = ifacet,
      nfacets = nfacets, nfacet_cols = nfacet_cols, nfacet_rows = nfacet_rows,
      axes = axes, flip = flip, frame.plot = frame.plot,
      oxaxis = oxaxis, oyaxis = oyaxis,
      xlabs = xlabs, xlim = xlim, xlim_user = xlim_user, xaxt = xaxt, xaxs = xaxs, xaxb = xaxb, xaxl = xaxl,
      ylabs = ylabs, ylim = ylim, ylim_user = ylim_user, yaxt = yaxt, yaxs = yaxs, yaxb = yaxb, yaxl = yaxl,
      asp = asp, log = log,
      dots = dots,
      draw = draw,
      grid = grid,
      has_legend = has_legend,
      type = type,
      x = datapoints$x, xmax = datapoints$xmax, xmin = datapoints$xmin,
      y = datapoints$y, ymax = datapoints$ymax, ymin = datapoints$ymin
    ),
    getNamespace("tinyplot")
  )
  list2env(facet_window_args, environment())

  #
  ## Interior plot elements
  #

  # Finally, we can draw all of the plot elements (points, lines, etc.)
  # We'll do this via a nested loops:
  #  1) Outer loop over facets
  #  2) Inner loop over groups

  ## Outer loop over the facets
  for (i in seq_along(split_data)) {
    # Split group-level data again to grab any "by" groups
    idata = split_data[[i]]
    iby = idata[["by"]]
    if (!null_by) { ## maybe all(iby=="")
      if (isTRUE(by_continuous)) {
        idata[["col"]] = col[round(rescale_num(idata$by, from = range(datapoints$by), to = c(1, 100)))]
        idata[["bg"]] = bg[round(rescale_num(idata$by, from = range(datapoints$by), to = c(1, 100)))]
        idata = list(idata)
      } else {
        idata = lapply(idata, split, iby)
        idata = do.call(function(...) Map("list", ...), idata)
      }
    } else {
      idata = list(idata)
      if (isTRUE(by_continuous)) {
        if (length(col) != 1) {
          idata[[1]][["col"]] = col[round(rescale_num(by, to = c(1, 100)))]
        } else {
          idata[[1]][["col"]] = col
        }
        if (length(bg) != 1) {
          idata[[1]][["bg"]] = bg[round(rescale_num(by, to = c(1, 100)))]
        } else {
          idata[[1]][["bg"]] = bg
        }
      }
    }

    # Set the facet "window" manually
    # See: https://github.com/grantmcdermott/tinyplot/issues/65
    if (nfacets > 1) {
      mfgi = ceiling(i / nfacet_cols)
      mfgj = i %% nfacet_cols
      if (mfgj == 0) mfgj = nfacet_cols
      par(mfg = c(mfgi, mfgj))

      # For free facets, we need to reset par(usr) based extent of that
      # particular facet... which we calculated and saved to the .fusr env var
      # (list) back in draw_facet_window()
      if (isTRUE(facet.args[["free"]])) {
        fusr = get(".fusr", envir = get(".tinyplot_env", envir = parent.env(environment())))
        par(usr = fusr[[i]])
      }
    }

    ## Inner loop over the "by" groupings
    for (ii in seq_along(idata)) {
      icol = col[ii]
      ibg = bg[ii]
      ipch = pch[ii]
      ilty = lty[ii]
      ilwd = lwd[ii]

      ix = idata[[ii]][["x"]]
      iy = idata[[ii]][["y"]]
      iz = idata[[ii]][["z"]]
      ixmin = idata[[ii]]$xmin
      ixmax = idata[[ii]]$xmax
      iymin = idata[[ii]]$ymin
      iymax = idata[[ii]]$ymax
      ilabels = idata[[ii]][["labels"]]

      if (isTRUE(by_continuous)) {
        icol = idata[[ii]]$col
        ibg = idata[[ii]]$bg
      }

      # empty plot flag
      empty_plot = FALSE
      if (isTRUE(empty) || isTRUE(type == "n") || ((length(ix) == 0) && !(type %in% c("histogram", "hist", "rect", "segments", "spineplot")))) {
        empty_plot = TRUE
      }

      # Draw the individual plot elements...
      if (!isTRUE(empty_plot)) {
        if (is.null(type_draw)) {
          type_draw = switch(type,
            "ribbon" = type_ribbon()$draw,
            "polygon" = type_polygon()$draw,
            "rect" = type_rect()$draw,
            "p" = ,
            "points" = type_points()$draw,
            "l" = ,
            "o" = ,
            "b" = ,
            "c" = ,
            "h" = ,
            "s" = ,
            "S" = type_lines(type = type)$draw
          )
        }
        type_draw(
          ibg = ibg,
          icol = icol,
          ilty = ilty,
          ilwd = ilwd,
          ipch = ipch,
          ix = ix,
          ixmax = ixmax,
          ixmin = ixmin,
          iy = iy,
          iymax = iymax,
          iymin = iymin,
          ilabels = ilabels,
          iz = iz,
          cex = cex,
          dots = dots,
          type = type,
          x_by = x_by,
          by_continuous = by_continuous,
          iby = ii,
          ifacet = i,
          facet_by = facet_by,
          data_facet = idata,
          ngrps = ngrps,
          nfacets = nfacets,
          flip = flip,
          type_info = type_info,
          facet_window_args = facet_window_args
        )
      }
    }
  }

  if (!add) {
    # save end pars for possible recall later
    recordGraphics(
      {
        apar = par(no.readonly = TRUE)
        set_saved_par(when = "after", apar)
      },
      list = list(),
      env = getNamespace('tinyplot')
    )
  }

}

#' @rdname tinyplot
#' @importFrom stats as.formula model.frame terms
#' @export
tinyplot.formula = function(
    x = NULL,
    data = parent.frame(),
    facet = NULL,
    facet.args = NULL,
    type = NULL,
    xmin = NULL,
    xmax = NULL,
    ymin = NULL,
    ymax = NULL,
    xlim = NULL,
    ylim = NULL,
    # log = "",
    main = NULL,
    sub = NULL,
    xlab = NULL,
    ylab = NULL,
    ann = par("ann"),
    axes = TRUE,
    frame.plot = NULL,
    asp = NA,
    grid = NULL,
    pch = NULL,
    col = NULL,
    lty = NULL,
    lwd = NULL,
    restore.par = FALSE,
    formula = NULL,
    subset = NULL,
    na.action = NULL,
    drop.unused.levels = TRUE,
    ...) {
  ## formula for variables must be specified through 'x' or 'formula' but not both
  if (is.null(x)) {
    if (missing(formula)) {
      stop("plot formula must be specified by either 'x' or 'formula' argument")
    }
  } else {
    if (missing(formula)) {
      formula = x
    } else {
      warning("only one of the arguments 'x' and 'formula' should be specified, defaulting to the 'formula' argument")
    }
  }

  ## placeholder for legend title
  legend_args = list(x = NULL)

  ## turn facet into a formula if it does not evaluate successfully
  if (inherits(try(facet, silent = TRUE), "try-error")) {
    facet = as.formula(paste("~", deparse(substitute(facet))))
    environment(facet) = environment(formula)
  }

  ## process all formulas
  tf = tinyformula(formula, facet)

  ## set up model frame
  m = match.call(expand.dots = FALSE)
  m = m[c(1L, match(c("formula", "data", "subset", "na.action", "drop.unused.levels", "xmin", "xmax", "ymin", "ymax"), names(m), 0L))]
  m$formula = tf$full
  ## need stats:: for non-standard evaluation
  m[[1L]] = quote(stats::model.frame)
  mf = eval.parent(m)

  ## extract x
  x = tinyframe(tf$x, mf)
  xnam = names(x)[[1L]]
  if (length(names(x)) != 1L) warning(
    paste("formula should specify exactly one x-variable, using:", xnam),
    "\nif you want to use arithmetic operators, make sure to wrap them inside I()")
  x = x[[xnam]]

  ## extract y (if any)
  y = tinyframe(tf$y, mf)
  if (!is.null(y)) {
    ynam = names(y)[[1L]]
    if (length(names(y)) > 1L) warning(paste("formula should specify at most one y-variable, using:", ynam),
    "\nif you want to use arithmetic operators, make sure to wrap them inside I()")
    y = y[[ynam]]
  }

  ## extract by (if any)
  by = tinyframe(tf$by, mf)
  if (!is.null(by)) {
    bynam = names(by)
    by = if (length(bynam) == 1L) by[[bynam]] else interaction(by, sep = ":")
  }

  ## extract x/y facet (if formula)
  if (!is.null(tf$xfacet) || !is.null(tf$yfacet)) {
    xfacet = tinyframe(tf$xfacet, mf)
    yfacet = tinyframe(tf$yfacet, mf)
    if (!is.null(xfacet)) xfacet = if (ncol(xfacet) == 1L) xfacet[[1L]] else interaction(xfacet, sep = ":")
    if (!is.null(yfacet)) yfacet = if (ncol(yfacet) == 1L) yfacet[[1L]] else interaction(yfacet, sep = ":")
    if (is.null(yfacet)) {
      facet = xfacet
    } else {
      facet = interaction(xfacet, yfacet, sep = "~")
      attr(facet, "facet_grid") = TRUE
      attr(facet, "facet_nrow") = length(unique(yfacet))
    }
  }

  ## nice axis and legend labels
  dens_type = (is.atomic(type) && identical(type, "density")) || (!is.atomic(type) && identical(type$name, "density"))
  hist_type = (is.atomic(type) && type %in% c("hist", "histogram")) || (!is.atomic(type) && identical(type$name, "histogram"))
  if (!is.null(type) && dens_type) {
    # if (is.null(ylab)) ylab = "Density" ## rather assign ylab as part of internal type_density() logic
    if (is.null(xlab)) xlab = xnam
  } else if (!is.null(type) && hist_type) {
    # if (is.null(ylab)) ylab = "Frequency" ## rather assign ylab as part of internal type_histogram() logic
    if (is.null(xlab)) xlab = xnam
  } else if (is.null(y)) {
    if (is.null(ylab)) ylab = xnam
    if (is.null(xlab)) xlab = "Index"
  } else {
    if (is.null(ylab)) ylab = ynam
    if (is.null(xlab)) xlab = xnam
  }
  if (!is.null(by)) {
    legend_args[["title"]] = if (length(bynam) == 1L) bynam else sprintf("interaction(%s)", paste(bynam, collapse = ", "))
  }

  tinyplot.default(
    x = x, y = y, by = by,
    facet = facet, facet.args = facet.args,
    data = data,
    type = type,
    xmin = mf[["(xmin)"]],
    xmax = mf[["(xmax)"]],
    ymin = mf[["(ymin)"]],
    ymax = mf[["(ymax)"]],
    xlim = xlim,
    ylim = ylim,
    # log = "",
    main = main,
    sub = sub,
    xlab = xlab,
    ylab = ylab,
    ann = ann,
    axes = axes,
    frame.plot = frame.plot,
    asp = asp,
    grid = grid,
    legend_args = legend_args,
    pch = pch,
    col = col,
    lty = lty,
    lwd = lwd,
    restore.par = restore.par,
    ...
  )
}

#' @rdname tinyplot
#' @export
tinyplot.density = function(
    x = NULL,
    type = c("l", "area"),
    ...) {

  dots = list(...)

  if (!is.null(dots[["by"]]) || !is.null(dots[["facet"]])) {
    stop(
      '\nGrouped and/or faceted plots are no longer supported with the tinyplot.density() method. ',
      '\nPlease use the dedicated type argument instead, e.g. `tinyplot(..., type = "density")`. See `?type_density` for details.',
      '\n\nThis breaking change was introduced in tinyplot v0.3.0.'
    )
  }

  type = match.arg(type)

  ## override if bg = "by"
  if (!is.null(dots[["bg"]]) || !is.null(dots[["fill"]])) type = "area"

  if (inherits(x, "density")) {
    object = x
    # legend_args = list(x = NULL)
    # # Grab by label to pass on legend title to tinyplot.default
    # legend_args[["title"]] = deparse(substitute(by))
  } else {
    ## An internal catch for non-density objects that were forcibly
    ## passed to tinyplot.density (e.g., via a one-side formula)
    if (anyNA(x)) {
      x = na.omit(x)
      x = as.numeric(x)
    }
    object = density(x)
  }

  x = object$x
  y = object$y

  if (type == "area") {
    ymin = rep(0, length(y))
    ymax = y
    # # set extra legend params to get bordered boxes with fill
    # legend_args[["x.intersp"]] = 1.25
    # legend_args[["lty"]] = 0
    # legend_args[["pt.lwd"]] = 1
  }

  # splice in change arguments
  dots[["x"]] = x
  dots[["y"]] = y
  dots[["type"]] = type

  ## axes range
  if (is.null(dots[["xlim"]])) dots[["xlim"]] = range(x)
  if (is.null(dots[["ylim"]])) dots[["ylim"]] = range(y)

  ## nice labels and titles
  if (is.null(dots[["ylab"]])) dots[["ylab"]] = "Density"
  if (is.null(dots[["xlab"]])) dots[["xlab"]] = paste0("N = ", object$n, "   Bandwidth = ", sprintf("%.4g", object$bw))
  if (is.null(dots[["main"]])) dots[["main"]] = paste0(paste(object$call, collapse = "(x = "), ")")

  do.call(tinyplot.default, args = dots)

}

#' @export
#' @name plt
#' @rdname tinyplot
plt = tinyplot

#' @title Calculate placement of legend and draw it
#'
#' @description Function used to calculate the placement of (including
#'   outside the plotting area) and drawing of legend.
#'
#' @md
#' @param legend Legend placement keyword or list, passed down from [tinyplot].
#' @param legend_args Additional legend arguments to be passed to
#'   \code{\link[graphics]{legend}}.
#' @param by_dep The (deparsed) "by" grouping variable name.
#' @param lgnd_labs The labels passed to `legend(legend = ...)`.
#' @param type Plotting type(s), passed down from [tinyplot].
#' @param pch Plotting character(s), passed down from [tinyplot].
#' @param lty Plotting linetype(s), passed down from [tinyplot].
#' @param lwd Plotting line width(s), passed down from [tinyplot].
#' @param col Plotting colour(s), passed down from [tinyplot].
#' @param bg Plotting character background fill colour(s), passed down from [tinyplot].
#' @param cex Plotting character expansion(s), passed down from [tinyplot].
#' @param gradient Logical indicating whether a continuous gradient swatch
#'   should be used to represent the colors.
#' @param lmar Legend margins (in lines). Should be a numeric vector of the form
#'   `c(inner, outer)`, where the first number represents the "inner" margin
#'   between the legend and the plot, and the second number represents the
#'   "outer" margin between the legend and edge of the graphics device. If no
#'   explicit value is provided by the user, then reverts back to `tpar("lmar")`
#'   for which the default values are `c(1.0, 0.1)`.
#' @param has_sub Logical. Does the plot have a sub-caption. Only used if
#'   keyword position is "bottom!", in which case we need to bump the legend
#'   margin a bit further.
#' @param new_plot Logical. Should we be calling plot.new internally?
#' @param draw Logical. If `FALSE`, no legend is drawn but the sizes are
#'   returned. Note that a new (blank) plot frame will still need to be started
#'   in order to perform the calculations.
#'
#' @returns No return value, called for side effect of producing a(n empty) plot
#'   with a legend in the margin.
#'
#' @importFrom graphics grconvertX grconvertY rasterImage strwidth
#' @importFrom grDevices as.raster recordGraphics
#' @importFrom utils modifyList
#'
#' @examples
#' oldmar = par("mar")
#'
#' draw_legend(
#'   legend = "right!", ## default (other options incl, "left(!)", ""bottom(!)", etc.)
#'   legend_args = list(title = "Key", bty = "o"),
#'   lgnd_labs = c("foo", "bar"),
#'   type = "p",
#'   pch = 21:22,
#'   col = 1:2
#' )
#'
#' # The legend is placed in the outer margin...
#' box("figure", col = "cyan", lty = 4)
#' # ... and the plot is proportionally adjusted against the edge of this
#' # margin.
#' box("plot")
#' # You can add regular plot objects per normal now
#' plot.window(xlim = c(1,10), ylim = c(1,10))
#' points(1:10)
#' points(10:1, pch = 22, col = "red")
#' axis(1); axis(2)
#' # etc.
#'
#' # Important: A side effect of draw_legend is that the inner margins have been
#' # adjusted. (Here: The right margin, since we called "right!" above.)
#' par("mar")
#'
#' # To reset you should call `dev.off()` or just reset manually.
#' par(mar = oldmar)
#'
#' # Note that the inner and outer margin of the legend itself can be set via
#' # the `lmar` argument. (This can also be set globally via
#' # `tpar(lmar = c(inner, outer))`.)
#' draw_legend(
#'   legend_args = list(title = "Key", bty = "o"),
#'   lgnd_labs = c("foo", "bar"),
#'   type = "p",
#'   pch = 21:22,
#'   col = 1:2,
#'   lmar = c(0, 0.1) ## set inner margin to zero
#' )
#' box("figure", col = "cyan", lty = 4)
#'
#' par(mar = oldmar)
#'
#' # Continuous (gradient) legends are also supported
#' draw_legend(
#'   legend = "right!",
#'   legend_args = list(title = "Key"),
#'   lgnd_labs = LETTERS[1:5],
#'   col = hcl.colors(5),
#'   gradient = TRUE ## enable gradient legend
#' )
#'
#' par(mar = oldmar)
#'
#' @export
draw_legend = function(
    legend = NULL,
    legend_args = NULL,
    by_dep = NULL,
    lgnd_labs = NULL,
    type = NULL,
    pch = NULL,
    lty = NULL,
    lwd = NULL,
    col = NULL,
    bg = NULL,
    cex = NULL,
    gradient = FALSE,
    lmar = NULL,
    has_sub = FALSE,
    new_plot = TRUE,
    draw = TRUE
) {

    if (is.null(lmar)) {
      lmar = tpar("lmar")
    } else {
      if (!is.numeric(lmar) || length(lmar)!=2) stop ("lmar must be a numeric of length 2.")
    }

    assert_logical(gradient)
    assert_logical(has_sub)
    assert_logical(new_plot)
    assert_logical(draw)

    #
    ## legend args ----

    if (is.null(legend_args[["x"]])) {
      if (is.null(legend)) {
        legend_args[["x"]] = "right!"
      } else if (is.character(legend)) {
        legend_args = utils::modifyList(legend_args, list(x = legend))
      } else if (class(legend) %in% c("call", "name")) {
        largs = as.list(legend)
        if (is.null(largs[["x"]])) {
          lnms = names(largs)
          # check second position b/c first will be a symbol
          if (is.null(lnms)) {
            largs = stats::setNames(largs, c("", "x"))
          } else if (length(largs)>=2 && lnms[2] == "") {
            lnms[2] = "x"
            largs = stats::setNames(largs, lnms)
          } else {
            largs[["x"]] = "right!"
          }
        }
        # Finally, combine with any pre-existing legend args (e.g., title from the by label)
        legend_args = utils::modifyList(legend_args, largs, keep.null = TRUE)
      }
    }

    ## Use `!exists` rather than `is.null` for title in case user specified no title
    if (!exists("title", where = legend_args)) legend_args[["title"]] = by_dep

    legend_args[["pch"]] = legend_args[["pch"]] %||% pch
    legend_args[["lty"]] = legend_args[["lty"]] %||% lty
    legend_args[["col"]] = legend_args[["col"]] %||% col
    legend_args[["bty"]] = legend_args[["bty"]] %||% "n"
    legend_args[["horiz"]] = legend_args[["horiz"]] %||% FALSE
    legend_args[["xpd"]] = legend_args[["xpd"]] %||% NA

    if (!isTRUE(type %in% c("p", "ribbon", "polygon", "polypath"))) {
      legend_args[["lwd"]] = legend_args[["lwd"]] %||% lwd
    }

    if (isTRUE(type %in% c("p", "pointrange", "errorbar")) && (length(col) == 1 || length(cex) == 1)) {
      legend_args[["pt.cex"]] = legend_args[["pt.cex"]] %||% cex
    }

    # turn off inner line for "barplot" type
    if (identical(type, "barplot")) {
      legend_args[["lty"]] = 0
    }

    if (isTRUE(type %in% c("rect", "ribbon", "polygon", "polypath", "boxplot", "hist", "histogram", "spineplot", "ridge", "barplot", "violin")) || gradient) {
      legend_args[["pch"]] = 22
      legend_args[["pt.cex"]] = legend_args[["pt.cex"]] %||% 3.5
      legend_args[["y.intersp"]] = legend_args[["y.intersp"]] %||% 1.25
      legend_args[["seg.len"]] = legend_args[["seg.len"]] %||% 1.25
    }

    if (isTRUE(type %in% c("ribbon", "hist", "histogram", "spineplot"))) {
      legend_args[["pt.lwd"]] = legend_args[["pt.lwd"]] %||% 0
    }

    if (identical(type, "p")) {
      legend_args[["pt.lwd"]] = legend_args[["pt.lwd"]] %||% lwd
    }

    if (identical(type, "n") && isFALSE(gradient)) {
      legend_args[["pch"]] = legend_args[["pch"]] %||% par("pch")
    }

    if (identical(type, "spineplot")) {
      legend_args[["pt.bg"]] = legend_args[["pt.bg"]] %||% legend_args[["col"]]
    }

    if (identical(type, "ridge") && isFALSE(gradient)) {
      legend_args[["pt.bg"]] = legend_args[["pt.bg"]] %||% sapply(legend_args[["col"]], function(ccol) seq_palette(ccol, n = 2)[2])
    }

    legend_args[["pt.bg"]] = legend_args[["pt.bg"]] %||% bg

    legend_args[["legend"]] = legend_args[["legend"]] %||% lgnd_labs
    if (length(lgnd_labs) != length(eval(legend_args[["legend"]]))) {
      warning(
        "\nUser-supplied legend labels do not match the number of groups.\n",
        "Defaulting to automatic labels determined by the group splits in `by`,\n"
      )
      legend_args[["legend"]] = lgnd_labs
    }

    if (isTRUE(gradient)) {
      legend_args[["ncol"]] = NULL
    }

    #
    ## legend placement ----

    # Note: "side" = left/right ; "end" = top/bottom
    outer_side = outer_end = outer_right = outer_bottom = FALSE ## placeholders

    ooma = par("oma")
    omar = par("mar")
    topmar_epsilon = 0.1

    # Catch to avoid recursive offsets, e.g. repeated tinyplot calls with
    # "bottom!" legend position.

    ## restore inner margin defaults
    ## (in case the plot region/margins were affected by the preceding tinyplot call)
    dynmar = isTRUE(.tpar[["dynmar"]])
    if (any(ooma != 0) && !dynmar) {
      if ( ooma[1] != 0 & omar[1] == par("mgp")[1] + 1*par("cex.lab") ) omar[1] = 5.1
      if ( ooma[2] != 0 & omar[2] == par("mgp")[1] + 1*par("cex.lab") ) omar[2] = 4.1
      if ( ooma[3] == topmar_epsilon & omar[3] != 4.1 ) omar[3] = 4.1
      if ( ooma[4] != 0 & omar[4] == 0 ) omar[4] = 2.1
      par(mar = omar)
    }
    ## restore outer margin defaults
    par(omd = c(0,1,0,1))
    ooma = par("oma")

    ## Legend to outer side (either right or left) of plot
    if (grepl("right!$|left!$", legend_args[["x"]])) {

      outer_side = TRUE
      outer_right = grepl("right!$", legend_args[["x"]])

      # extra bump for spineplot if outer_right legend (to accommodate secondary y-axis)
      if (identical(type, "spineplot")) lmar[1] = lmar[1] + 1.1

      ## Switch position anchor (we'll adjust relative to the _opposite_ side below)
      if (outer_right) legend_args[["x"]] = gsub("right!$", "left", legend_args[["x"]])
      if (!outer_right) legend_args[["x"]] = gsub("left!$", "right", legend_args[["x"]])

      ## We have to set the inner margins of the plot before the (fake) legend is
      ## drawn, otherwise the inset calculation---which is based in the legend
      ## width---will be off the first time.
      if (outer_right) {
        omar[4] = 0
      } else {
        # For outer left we have to account for the y-axis label too, which
        # requires additional space
        omar[2] = par("mgp")[1] + 1*par("cex.lab")
      }
      par(mar = omar)

      if (new_plot && draw) {
        plot.new()
        # For themed + dynamic plots, we need to make sure the adjusted plot
        # margins for the legend are reinstated (after being overwritten by
        # the before.plot.new hook.
        if (dynmar) {
          omar = par("mar")
          if (outer_right) {
            omar[4] = 0
          } else {
            omar[2] = par("mgp")[1] + 1*par("cex.lab")
          }
          par(mar = omar)
        }
      }

      legend_args[["horiz"]] = FALSE

      ## Legend at the outer top or bottom of plot
    } else if (grepl("bottom!$|top!$", legend_args[["x"]])) {

      outer_end = TRUE
      outer_bottom = grepl("bottom!$", legend_args[["x"]])

      ## Switch position anchor (we'll adjust relative to the _opposite_ side below)
      if (outer_bottom) legend_args[["x"]] = gsub("bottom!$", "top", legend_args[["x"]])
      if (!outer_bottom) legend_args[["x"]] = gsub("top!$", "bottom", legend_args[["x"]])

      ## We have to set the inner margins of the plot before the (fake) legend is
      ## drawn, otherwise the inset calculation---which is based in the legend
      ## width---will be off the first time.
      if (outer_bottom) {
        omar[1] = par("mgp")[1] + 1*par("cex.lab")
        if (has_sub && (is.null(.tpar[["side.sub"]]) || .tpar[["side.sub"]]==1)) omar[1] = omar[1] + 1*par("cex.sub")
      } else {
        ## For "top!", the logic is slightly different: We don't expand the outer
        ## margin b/c we need the legend to come underneath the main title. So
        ## we rather expand the existing inner margin.
        ooma[3] = ooma[3] + topmar_epsilon
        par(oma = ooma)
      }
      par(mar = omar)

      if (new_plot && draw) {
        plot.new()
        # For themed + dynamic plots, we need to make sure the adjusted plot
        # margins for the legend are reinstated (after being overwritten by
        # the before.plot.new hook.
        if (dynmar) {
          omar = par("mar")
          if (outer_bottom) {
            # omar[1] = par("mgp")[1] + 1*par("cex.lab")
            omar[1] = theme_clean$mgp[1] + 1*par("cex.lab") ## bit of a hack
            if (has_sub && (is.null(.tpar[["side.sub"]]) || .tpar[["side.sub"]]==1)) omar[1] = omar[1] + 1*par("cex.sub")
          } else {
            ooma[3] = ooma[3] + topmar_epsilon
            par(oma = ooma)
          }
          par(mar = omar)
        }
      }

      # enforce horizontal legend if user hasn't specified ncol arg
      # (exception: gradient legends at bottom/top are always horizontal)
      if (is.null(legend_args[["ncol"]]) || gradient) legend_args[["horiz"]] = TRUE

    } else {

      legend_args[["inset"]] = 0
      if (new_plot && draw) plot.new()

    }

    # Additional tweaks for horiz and/or multi-column legends
    if (isTRUE(legend_args[["horiz"]]) ||  !is.null(legend_args[["ncol"]])) {
      # tighter horizontal labelling
      # See: https://github.com/grantmcdermott/tinyplot/issues/434
      if (!gradient) {
        legend_args[["text.width"]] = NA
        # Add a space to all labs except the outer most right ones
        nlabs = length(legend_args[["legend"]])
        nidx = nlabs
        if (!is.null(legend_args[["ncol"]])) nidx = tail(1:nlabs, (nlabs %/% legend_args[["ncol"]]))
        legend_args[["legend"]][-nidx] = paste(legend_args[["legend"]][-nidx], " ")
      }
      # catch for horizontal ribbon legend spacing
      if (type=="ribbon") {
        if (legend_args[["pt.lwd"]] == 1) {
          legend_args[["x.intersp"]] = 1
        } else {
          legend_args[["x.intersp"]] = 0.5
        }
      } else if (gradient) {
        legend_args[["x.intersp"]] = 0.5
      }
    }

    #
    ## draw the legend ----

    # Legend drawing is handled by the internal `tinylegend()` function, which:
    #   1. calculates appropriate insets for "outer" legend placement
    #   2. can draw gradient legends (via `gradient_legend()` below)
    #
    # Note: We wrap everything in `recordGraphics()` to preserve legend spacing
    # if the plot is resized (also necessary for Positron graphics logic regardless)
      recordGraphics(
        tinylegend(
          legend_args = legend_args,
          ooma = ooma,
          omar = omar,
          lmar = lmar,
          topmar_epsilon = topmar_epsilon,
          outer_side = outer_side,
          outer_right = outer_right,
          outer_end = outer_end,
          outer_bottom = outer_bottom,
          gradient = gradient,
          draw = draw
        ),
        list = list(
          legend_args = legend_args,
          ooma = ooma,
          omar = omar,
          lmar = lmar,
          topmar_epsilon = topmar_epsilon,
          outer_side = outer_side,
          outer_right = outer_right,
          outer_end = outer_end,
          outer_bottom = outer_bottom,
          gradient = gradient,
          draw = draw
        ),
        env = getNamespace("tinyplot")
      )

}

# tinylegend ----

## Internal workhorse function that draws the legend, given a set of legend
## arguments and other graphical parameters. It does this in three steps:
## 1) draw a fake legend, 2) calculate the associated inset and adjust the plot
## margins accordingly, 3) draw the real legend

tinylegend = function(
    legend_args,
    ooma, omar, lmar, topmar_epsilon,
    outer_side, outer_right, outer_end, outer_bottom,
    gradient,
    draw
) {

  #
  ## Step 1: "draw" fake legend

  fklgnd.args = modifyList(
    legend_args,
    list(plot = FALSE),
    keep.null = TRUE
  )

  if (gradient) {
    lgnd_labs_tmp = na.omit(fklgnd.args[["legend"]])
    if (length(lgnd_labs_tmp) < 5L) {
      nmore = 5L - length(lgnd_labs_tmp)
      lgnd_labs_tmp = c(lgnd_labs_tmp, rep("", nmore))
    }
    fklgnd.args = modifyList(
      fklgnd.args,
      list(legend = lgnd_labs_tmp),
      keep.null = TRUE
    )
    if (outer_end) fklgnd.args = modifyList(fklgnd.args, list(title = NULL), keep.null = TRUE)
  }

  if (draw) {
    fklgnd = do.call("legend", fklgnd.args)
  } else {
    plot.new()
    fklgnd = do.call("legend", fklgnd.args)
    return(fklgnd)
  }

  #
  ## Step 2: Calculate legend inset (for outer placement in plot region)

  # calculate outer margin width in lines
  soma = 0
  if (outer_side) {
    soma = grconvertX(fklgnd$rect$w, to="lines") - grconvertX(0, to="lines")
  } else if (outer_end) {
    soma = grconvertY(fklgnd$rect$h, to="lines") - grconvertY(0, to="lines")
  }
  # Add legend margins to the outer margin
  soma = soma + sum(lmar)

  ## differing outer margin adjustments depending on side
  if (outer_side) {
    if (outer_right) {
      ooma[4] = soma
    } else {
      ooma[2] = soma
    }
  } else if (outer_end) {
    if (outer_bottom) {
      ooma[1] = soma
    } else {
      omar[3] = omar[3] + soma - topmar_epsilon
      par(mar = omar)
    }
  }
  par(oma = ooma)

  # determine legend inset
  inset = 0
  if (outer_side) {
    inset = grconvertX(lmar[1], from="lines", to="npc") - grconvertX(0, from = "lines", to = "npc")
    # extra space needed for "left!" b/c of lhs inner margin
    if (!outer_right) {
      inset_bump = grconvertX(par("mar")[2], from = "lines", to = "npc") - grconvertX(0, from = "lines", to = "npc")
      inset = inset + inset_bump
    }
    inset = c(1+inset, 0)
  } else if (outer_end) {
    inset = grconvertY(lmar[1], from="lines", to="npc") - grconvertY(0, from="lines", to="npc")
    if (outer_bottom) {
      # extra space needed for "bottom!" b/c of lhs inner margin
      inset_bump = grconvertY(par("mar")[1], from="lines", to="npc") - grconvertY(0, from="lines", to="npc")
      inset = inset + inset_bump
    } else {
      epsilon_bump = grconvertY(topmar_epsilon, from="lines", to="npc") - grconvertY(0, from="lines", to="npc")
      inset = inset + epsilon_bump
    }
    inset = c(0, 1+inset)
  }

  # GM: The legend inset spacing only works _exactly_ if we refresh the plot
  # area. I'm not sure why (and it works properly if we use the same
  # parameters manually while debugging), but this hack seems to work.
  ## v0.3.0 update: Using (temporary) hook instead of direct par(new = TRUE)
  ## assignment to play nice with tinytheme logic.
  oldhook = getHook("before.plot.new")
  setHook("before.plot.new", function() par(new = TRUE), action = "append")
  setHook("before.plot.new", function() par(mar = omar), action = "append")
  plot.new()
  setHook("before.plot.new", oldhook, action = "replace")

  # Finally, set the inset as part of the legend args.
  legend_args[["inset"]] = inset

  #
  ## Step 3: Draw the legend

  if (gradient) {
    if (!more_than_n_unique(legend_args[["col"]], 1)) {
      if (!is.null(legend_args[["pt.bg"]]) && length(legend_args[["pt.bg"]])==100) {
        legend_args[["col"]] = legend_args[["pt.bg"]]
      }
    }
    gradient_legend(
      legend_args = legend_args,
      fklgnd = fklgnd,
      lmar = lmar,
      outer_side = outer_side,
      outer_end = outer_end,
      outer_right = outer_right,
      outer_bottom = outer_bottom
    )
  } else {
    do.call("legend", legend_args)
  }

}

# gradient legend ----

# For gradient (i.e., continuous color) legends, we'll role our own bespoke
# legend function based on grDevices::as.raster

gradient_legend = function(legend_args, fklgnd, lmar, outer_side, outer_end, outer_right, outer_bottom) {
  pal = legend_args[["col"]]
  lgnd_labs = legend_args[["legend"]]
  if (!is.null(legend_args[["horiz"]])) horiz = legend_args[["horiz"]] else horiz = FALSE
  if (isTRUE(horiz)) {
    rasterlgd = as.raster(matrix(pal, nrow = 1))
  } else {
    rasterlgd = as.raster(matrix(rev(pal), ncol = 1))
  }

  corners = par("usr")
  rasterbox = rep(NA_real_, 4)

  inner = !any(c(outer_side, outer_end))
  inner_right = inner_bottom = FALSE
  if (inner) {
    if (!is.null(legend_args[["x"]]) && grepl("left$|right$", legend_args[["x"]])) {
      inner_right = grepl("right$", legend_args[["x"]])
    }
    if (!is.null(legend_args[["x"]]) && grepl("^bottoml|^top", legend_args[["x"]])) {
      inner_bottom = grepl("^bottom", legend_args[["x"]])
    }
  }

  if (inner) {

    fklgnd$rect$h = fklgnd$rect$h - (grconvertY(1.5 + 0.4, from="lines", to="user") - grconvertY(0, from="lines", to="user"))

    rasterbox[1] = fklgnd$rect$left
    if (isFALSE(inner_right)) rasterbox[1] = rasterbox[1] + (grconvertX(0.2, from="lines", to="user") - grconvertX(0, from="lines", to="user"))
    rasterbox[2] = fklgnd$rect$top - fklgnd$rect$h - (grconvertY(1.5 + 0.2, from="lines", to="user") - grconvertY(0, from="lines", to="user"))
    rasterbox[3] = rasterbox[1] + (grconvertX(1.25, from="lines", to="user") - grconvertX(0, from="lines", to="user"))
    rasterbox[4] = rasterbox[2] + fklgnd$rect$h

  } else if (outer_side) {

   rb1_adj = grconvertX(lmar[1] + 0.2, from="lines", to="user") - grconvertX(0, from="lines", to="user")
   rb3_adj = grconvertX(1.25, from="lines", to="user") - grconvertX(0, from="lines", to="user")
   rb2_adj = (corners[4] - corners[3] - (grconvertY(5+1 + 2.5, from="lines", to="user") - grconvertY(0, from="lines", to="user"))) / 2
   # override if top or bottom
   if (!is.null(legend_args[["x"]])) {
     if (grepl("^bottom", legend_args[["x"]])) {
       rb2_adj = corners[3]
     }
     if (grepl("^top", legend_args[["x"]])) {
       rb2_adj = corners[4] - (grconvertY(5+1 + 2.5, from="lines", to="user") - grconvertY(0, from="lines", to="user"))
     }
   }
   rb4_adj = grconvertY(5+1, from="lines", to="user") - grconvertY(0, from="lines", to="user")

   if (outer_right) {
     rasterbox[1] = corners[2] + rb1_adj
     rasterbox[2] = rb2_adj
     rasterbox[3] = rasterbox[1] + rb3_adj
     rasterbox[4] = rasterbox[2] + rb4_adj
   } else {
     rb1_adj = rb1_adj + grconvertX(par("mar")[2] + 1, from="lines", to="user") - grconvertX(0, from="lines", to="user")
     rasterbox[1] = corners[1] - rb1_adj
     rasterbox[2] = rb2_adj
     rasterbox[3] = rasterbox[1] - rb3_adj
     rasterbox[4] = rasterbox[2] + rb4_adj
   }

  } else if (outer_end) {

    rb1_adj = (corners[2] - corners[1] - (grconvertX(5+1, from="lines", to="user") - grconvertX(0, from="lines", to="user"))) / 2
    rb3_adj = grconvertX(5+1, from="lines", to="user") - grconvertX(0, from="lines", to="user")
    rb2_adj = grconvertY(lmar[1], from="lines", to="user") - grconvertY(0, from="lines", to="user")
    rb4_adj = grconvertY(1.25, from="lines", to="user") - grconvertY(0, from="lines", to="user")

    if (outer_bottom) {
      rb2_adj = rb2_adj + grconvertY(par("mar")[2], from="lines", to="user") - grconvertY(0, from="lines", to="user")
      rasterbox[1] = rb1_adj
      rasterbox[2] = corners[3] - rb2_adj
      rasterbox[3] = rasterbox[1] + rb3_adj
      rasterbox[4] = rasterbox[2] - rb4_adj
    } else {
      rb2_adj = rb2_adj + grconvertY(1.25 + 1, from="lines", to="user") - grconvertY(0, from="lines", to="user")
      rasterbox[1] = rb1_adj
      rasterbox[2] = corners[4] + rb2_adj
      rasterbox[3] = rasterbox[1] + rb3_adj
      rasterbox[4] = rasterbox[2] - rb4_adj
    }

  }

  #
  ## Draw the gradient swatch

  rasterImage(
    rasterlgd,
    rasterbox[1], #x1
    rasterbox[2], #y1
    rasterbox[3], #x2
    rasterbox[4], #y2
    xpd = NA
  )

  #
  ## Add the labels, tick marks, and title

  if (isFALSE(horiz)) {
    labs_idx = !is.na(lgnd_labs)
    lgnd_labs[labs_idx] = paste0(" ", format(lgnd_labs[labs_idx]))
    lbl_x_anchor = rasterbox[3]
    ttl_x_anchor = rasterbox[1]
    lbl_adj = c(0, 0.5)
    tck_adj = c(1, 0.5)
    ttl_adj = c(0, 0)
    if (!inner && !outer_right) {
      lbl_x_anchor = rasterbox[1]
      ttl_x_anchor = ttl_x_anchor + max(strwidth(lgnd_labs[labs_idx]))
      ttl_adj = c(1, 0)
    }
    text(
      x = lbl_x_anchor,
      y = seq(rasterbox[2], rasterbox[4], length.out = length(lgnd_labs)),
      labels = lgnd_labs,
      xpd = NA,
      adj = lbl_adj
    )
    # legend tick marks
    lgnd_ticks = lgnd_labs
    lgnd_ticks[labs_idx] = "-   -"
    text(
      x = lbl_x_anchor,
      y = seq(rasterbox[2], rasterbox[4], length.out = length(lgnd_labs)),
      labels = lgnd_ticks, col = "white",
      xpd = NA, adj = tck_adj
    )
    # legend title
    text(
      x = ttl_x_anchor,
      y = rasterbox[4] + grconvertY(1, from = "lines", to = "user") - grconvertY(0, from = "lines", to = "user"),
      labels = legend_args[["title"]],
      xpd = NA, adj = ttl_adj
    )
  } else {
    lbl_y_anchor = rasterbox[4]
    ttl_y_anchor = rasterbox[4]
    lbl_adj = c(0.5, 1.25)
    tck_adj = c(0, 0.5)
    ttl_adj = c(1, -0.5)
    # legend labs
    text(
      x = seq(rasterbox[1], rasterbox[3], length.out = length(lgnd_labs)),
      y = lbl_y_anchor,
      labels = lgnd_labs,
      xpd = NA, adj = lbl_adj
    )
    # legend tick marks
    lgnd_ticks = lgnd_labs
    lgnd_ticks[!is.na(lgnd_ticks)] = "-   -"
    text(
      x = seq(rasterbox[1], rasterbox[3], length.out = length(lgnd_labs)),
      y = lbl_y_anchor,
      labels = lgnd_ticks, col = "white",
      xpd = NA, adj = tck_adj, srt = 90
    )
    # legend title
    text(
      x = rasterbox[1],
      y = ttl_y_anchor,
      labels = paste0(legend_args[["title"]], " "),
      xpd = NA, adj = ttl_adj
    )
  }
}

#' Draw facet windows
#'
#' @description Internal functions called from `tinyplot` in order to draw the
#' plot window with different facets, grids, axes, etc.
#'
#' `facet_layout` determines the layout of the facets, based on a set of inputs.
#'
#' `draw_facet_window` is the main workhorse function for setting the exterior
#' plot elements as part of a `tinyplot` call, including adjustment of margins
#' for dynamic themes, etc.
#'
#' @keywords internal
#' @rdname facet
draw_facet_window = function(
    # add arg first, since that determines what happens (if at all)
    add,
    # facet-specific args
    cex_fct_adj,
    facet.args,
    facet_newlines, facet_font, facet_rect, facet_text,
    facet_col, facet_bg, facet_border,
    facet, facets, ifacet,
    nfacets, nfacet_cols, nfacet_rows,
    # axes args
    axes, flip, frame.plot, oxaxis, oyaxis,
    xlabs, xlim, xlim_user, xaxt, xaxs, xaxb, xaxl,
    ylabs, ylim, ylim_user, yaxt, yaxs, yaxb, yaxl,
    asp, log,
    # other args (in approx. alphabetical + group ordering)
    dots,
    draw,
    grid,
    has_legend,
    type,
    x, xmax, xmin,
    y, ymax, ymin
    ) {

  # if add is TRUE, just return inputs without any calculations
  if (isTRUE(add)) {
    return(as.list(environment()))
  }

  # if breaks are provided use these (but only if x/ylabs are null)
  if (!is.null(xaxb) && !is.null(xlabs)) xlabs = xaxb
  if (!is.null(yaxb) && !is.null(ylabs)) ylabs = yaxb

  # draw background color only in the grid rectangle
  grid.bg = get_tpar("grid.bg")
  if (!is.null(grid.bg)) {
    corners = par("usr")
    rect(corners[1], corners[3], corners[2], corners[4], col = grid.bg, border = NA)
  }

  ## dynamic margins flag
  dynmar = isTRUE(.tpar[["dynmar"]])

  ## optionally allow to modify the style of axis interval calculation
  if (!is.null(xaxs)) par(xaxs = xaxs)
  if (!is.null(yaxs)) par(yaxs = yaxs)

  if (nfacets > 1) {
    # Set facet margins (i.e., gaps between facets)
    if (is.null(facet.args[["fmar"]])) {
      fmar = tpar("fmar")
    } else {
      if (length(facet.args[["fmar"]]) != 4) {
        warning(
          "`fmar` has to be a vector of length four, e.g.",
          "`facet.args = list(fmar = c(b,l,t,r))`.",
          "\n",
          "Resetting to fmar = c(1,1,1,1) default.",
          "\n"
        )
        fmar = tpar("fmar")
      } else {
        fmar = facet.args[["fmar"]]
      }
    }
    # We need to adjust for n>=3 facet cases for correct spacing...
    if (nfacets >= 3) {
      ## ... exception for 2x2 cases
      if (!(nfacet_rows == 2 && nfacet_cols == 2)) fmar = fmar * .75
    }
    # Extra reduction if no plot frame to reduce whitespace
    if (isFALSE(frame.plot) && !isTRUE(facet.args[["free"]])) {
      fmar = fmar - 0.5
    }

    ooma = par("oma")

    # Bump top margin down for facet titles
    fmar[3] = fmar[3] + 1
    if (isTRUE(attr(facet, "facet_grid"))) {
      fmar[3] = max(0, fmar[3] - 1)
      # Indent for RHS facet_grid title strip if "right!" legend
      if (has_legend && ooma[4] > 0) ooma[4] = ooma[4] + 1
    }
    fmar[3] = fmar[3] + facet_newlines * facet_text / cex_fct_adj

    omar = par("mar")

    ## Dynamic plot margin adjustments
    if (dynmar) {
      if (par("las") %in% 1:2) {
        # extra whitespace bump on the y axis
        ## overrides for ridge and some types that use integer spacing with (named) axis labels ## FXIME
        if (type == "ridge") {
          yaxlabs = levels(y)
        } else if (!is.null(ylabs)) {
          yaxlabs = if (!is.null(names(ylabs))) names(ylabs) else ylabs
        } else if (type == "boxplot" && isTRUE(flip) && !is.null(xlabs)) {
          yaxlabs = if (!is.null(names(xlabs))) names(xlabs) else xlabs
        } else {
          # yaxl = axTicks(2)
          yaxlabs = axisTicks(usr = extendrange(ylim, f = 0.04), log = par("ylog"))
        }
        if (!is.null(yaxl)) yaxlabs = tinylabel(yaxlabs, yaxl)
        # whtsbp = grconvertX(max(strwidth(yaxl, "figure")), from = "nfc", to = "lines") - 1
        whtsbp = grconvertX(max(strwidth(yaxlabs, "figure")), from = "nfc", to = "lines") - grconvertX(0, from = "nfc", to = "lines") - 1
        if (whtsbp > 0) {
          omar = omar + c(0, whtsbp, 0, 0) * cex_fct_adj
          fmar[2] = fmar[2] + whtsbp * cex_fct_adj
        }
        # Extra reduction if no plot frame to reduce whitespace
        if (isFALSE(frame.plot) && !isTRUE(facet.args[["free"]])) {
          fmar[2] = fmar[2] - (whtsbp * cex_fct_adj)
        }
      }
      if (par("las") %in% 2:3) {
        # extra whitespace bump on the x axis
        # xaxlabs = axTicks(1)
        xaxlabs = if (is.null(xlabs)) axisTicks(usr = extendrange(xlim, f = 0.04), log = par("xlog")) else
          if (!is.null(names(xlabs))) names(xlabs) else xlabs
        if (!is.null(xaxl)) xaxlabs = tinylabel(xaxlabs, xaxl)
        whtsbp = grconvertX(max(strwidth(xaxlabs, "figure")), from = "nfc", to = "lines") - 1
        if (whtsbp > 0) {
          omar = omar + c(whtsbp, 0, 0, 0) * cex_fct_adj
          fmar[1] = fmar[1] + whtsbp * cex_fct_adj
        }
        # Extra reduction if no plot frame to reduce whitespace
        if (isFALSE(frame.plot) && !isTRUE(facet.args[["free"]])) {
          fmar[1] = fmar[1] - (whtsbp * cex_fct_adj)
        }
      }
      # FIXME: Is this causing issues for lhs legends with facet_grid?
      # catch for missing rhs legend
      if (isTRUE(attr(facet, "facet_grid")) && !has_legend) {
        omar[4] = omar[4] + 1
      }
    }

    # Now we set the margins. The trick here is that we simultaneously adjust
    # inner (mar) and outer (oma) margins by the same amount, but in opposite
    # directions, to preserve the overall facet and plot centroids.
    nmar = (fmar + .1) / cex_fct_adj
    noma = (ooma + omar - fmar - .1) / cex_fct_adj
    # Catch in case of negative oma values. (Probably only occurs with some
    # user-supplied tpar(lmar) values and a "left!" positioned legend.)
    if (any(noma < 0)) {
      noma_orig = noma
      noma[noma < 0] = 0
      # noma_diff = noma-noma_orig
      # nmar = nmar + noma_diff
    }
    # apply changes
    par(oma = noma)
    par(mar = nmar)

    # Now that the margins have been set, arrange facet rows and columns based
    # on our earlier calculations.
    par(mfrow = c(nfacet_rows, nfacet_cols))
  } else if (dynmar) {
    # Dynamic plot margin adjustments
    omar = par("mar")
    omar = omar - c(0, 0, 1, 0) # reduce top whitespace since no facet (title)
    if (type == "spineplot") omar[4] = 2.1 # FIXME catch for spineplot RHS axis labs
    if (par("las") %in% 1:2) {
      # extra whitespace bump on the y axis
      ## overrides for ridge and some types that use integer spacing with (named) axis labels ## FXIME
      if (type == "ridge") {
        yaxlabs = levels(y)
      } else if (!is.null(ylabs)) {
        yaxlabs = if (!is.null(names(ylabs))) names(ylabs) else ylabs
      } else if (type == "boxplot" && isTRUE(flip) && !is.null(xlabs)) {
        yaxlabs = if (!is.null(names(xlabs))) names(xlabs) else xlabs
      } else {
        # yaxl = axTicks(2)
        yaxlabs = axisTicks(usr = extendrange(ylim, f = 0.04), log = par("ylog"))
      }
      if (!is.null(yaxl)) yaxlabs = tinylabel(yaxlabs, yaxl)
      # whtsbp = grconvertX(max(strwidth(yaxlabs, "figure")), from = "nfc", to = "lines") - 1
      whtsbp = grconvertX(max(strwidth(yaxlabs, "figure")), from = "nfc", to = "lines") - grconvertX(0, from = "nfc", to = "lines") - 1
      if (whtsbp > 0) {
        omar[2] = omar[2] + whtsbp
      }
    }
    if (par("las") %in% 2:3) {
      # extra whitespace bump on the x axis
      # xaxl = axTicks(1)
      xaxlabs = if (is.null(xlabs)) axisTicks(usr = extendrange(xlim, f = 0.04), log = par("xlog")) else
        if (!is.null(names(xlabs))) names(xlabs) else xlabs
      if (!is.null(xaxl)) xaxlabs = tinylabel(xaxlabs, xaxl)
      whtsbp = grconvertX(max(strwidth(xaxlabs, "figure")), from = "nfc", to = "lines") - 1
      if (whtsbp > 0) {
        omar[1] = omar[1] + whtsbp
      }
    }
     par(mar = omar)
  }

  ## Loop over the individual facet windows and draw the plot region
  ## components (axes, titles, box, grid, etc.)
  for (ii in ifacet) {
    # See: https://github.com/grantmcdermott/tinyplot/issues/65
    if (nfacets > 1) {
      mfgi = ceiling(ii / nfacet_cols)
      mfgj = ii %% nfacet_cols
      if (mfgj == 0) mfgj = nfacet_cols
      par(mfg = c(mfgi, mfgj))
    }

    ## Set the plot window
    ## Problem: Passing extra args through ... (e.g., legend_args) to plot.window
    ## triggers an annoying warning about unrecognized graphical params.
    # plot.window(
    #   xlim = xlim, ylim = ylim,
    #   asp = asp, log = log,
    #   # ...
    # )
    ## Solution: Only pass on relevant args using name checking and do.call.
    ## Idea borrowed from here: https://stackoverflow.com/a/4128401/4115816
    pdots = dots[names(dots) %in% names(formals(plot.default))]
    ## catch for flipped boxplots...
    if (type == "boxplot" && isTRUE(flip)) {
      log_flip = log
      if (!is.null(log)) {
        if (log == "x") log_flip = "y"
        if (log == "y") log_flip = "x"
      }
      do.call(
        "plot.window",
        c(list(xlim = ylim, ylim = xlim, asp = asp, log = log_flip), pdots)
      )
      xside = 2
      yside = 1
    } else {
      ## ... standard plot window for all other cases
      do.call(
        "plot.window",
        c(list(xlim = xlim, ylim = ylim, asp = asp, log = log), pdots)
      )
      xside = 1
      yside = 2
    }

    # axes, frame.plot and grid
    if (isTRUE(axes) || isTRUE(facet.args[["free"]])) {
      args_x = list(x,
        side = xside,
        type = xaxt,
        labeller = xaxl,
        cex = get_tpar(c("cex.xaxs", "cex.axis"), 0.8),
        lwd = get_tpar(c("lwd.xaxs", "lwd.axis"), 1),
        lty = get_tpar(c("lty.xaxs", "lty.axis"), 1)
      )
      args_y = list(y,
        side = yside,
        type = yaxt,
        labeller = yaxl,
        cex = get_tpar(c("cex.yaxs", "cex.axis"), 0.8),
        lwd = get_tpar(c("lwd.yaxs", "lwd.axis"), 1),
        lty = get_tpar(c("lty.yaxs", "lty.axis"), 1)
      )
      if (!is.null(xaxb)) args_x$at = xaxb
      if (!is.null(yaxb)) args_y$at = yaxb
      type_range_x = type %in% c("barplot", "pointrange", "errorbar", "ribbon", "boxplot", "p", "violin") && !is.null(xlabs)
      type_range_y = !is.null(ylabs) && (type == "p" || (isTRUE(flip) && type %in% c("barplot", "pointrange", "errorbar", "ribbon", "boxplot", "violin")))
      if (type_range_x) {
        args_x = modifyList(args_x, list(at = xlabs, labels = names(xlabs)))
      }
      if (type_range_y) {
        args_y = modifyList(args_y, list(at = ylabs, labels = names(ylabs)))
      }

      if (isTRUE(facet.args[["free"]]) && (par("xlog") || par("ylog"))) {
        warning(
          "\nFree scale axes for faceted plots are currently not supported if the axes are logged. Reverting back to fixed scales.",
          "\nIf support for this feature is important to you, please raise an issue on our GitHub repo:",
          "\nhttps://github.com/grantmcdermott/tinyplot/issues\n"
        )
        facet.args[["free"]] = FALSE
      }

      # Special logic if facets are free...
      if (isTRUE(facet.args[["free"]])) {
        # First, we need to calculate the plot extent and axes range of each
        # individual facet.
        xfree = split(c(x, xmin, xmax), facet)[[ii]]
        yfree = split(c(y, ymin, ymax), facet)[[ii]]
        if (!xlim_user) xlim = range(xfree, na.rm = TRUE)
        if (!ylim_user) ylim = range(yfree, na.rm = TRUE)
        xext = extendrange(xlim, f = 0.04)
        yext = extendrange(ylim, f = 0.04)
        # We'll save this in a special .fusr env var (list) that we'll re-use
        # when it comes to plotting the actual elements later
        if (ii == 1) {
          fusr = replicate(4, vector("double", length = nfacets), simplify = FALSE)
          assign(".fusr", fusr, envir = get(".tinyplot_env", envir = parent.env(environment())))
        }
        fusr = get(".fusr", envir = get(".tinyplot_env", envir = parent.env(environment())))
        fusr[[ii]] = c(xext, yext)
        assign(".fusr", fusr, envir = get(".tinyplot_env", envir = parent.env(environment())))
        # Explicitly set (override) the current facet extent
        par(usr = fusr[[ii]])
        # if plot frame is true then print axes per normal...
        if (type %in% c("barplot", "pointrange", "errorbar", "ribbon", "boxplot", "p", "violin") && !is.null(xlabs)) {
          tinyAxis(xfree, side = xside, at = xlabs, labels = names(xlabs), type = xaxt, labeller = xaxl)
        } else {
          tinyAxis(xfree, side = xside, type = xaxt, labeller = xaxl)
        }
        if (isTRUE(flip) && type %in% c("barplot", "pointrange", "errorbar", "ribbon", "boxplot", "p", "violin") && !is.null(ylabs)) {
          tinyAxis(yfree, side = yside, at = ylabs, labels = names(ylabs), type = yaxt, labeller = yaxl)
        } else {
          tinyAxis(yfree, side = yside, type = yaxt, labeller = yaxl)
        }

        # For fixed facets we can just reuse the same plot extent and axes limits
      } else if (isTRUE(frame.plot)) {
        # if plot frame is true then print axes per normal...
        do.call(tinyAxis, args_x)
        do.call(tinyAxis, args_y)
      } else {
        # ... else only print the "outside" axes.
        if (ii %in% oxaxis) do.call(tinyAxis, args_x)
        if (ii %in% oyaxis) do.call(tinyAxis, args_y)
      }
    }

    # facet titles
    ## Note: facet titles could be done more simply with mtext... but then we
    ## couldn't adjust background features (e.g., fill), or rotate the rhs
    ## facet grid text. So we're rolling our own "manual" versions with text
    ## and rect.
    if (!is.null(facet)) {
      # Get the four corners of plot area (x1, x2, y1, y2)
      corners = par("usr")
      # catch for logged axes
      xlog = isTRUE(par("xlog"))
      ylog = isTRUE(par("ylog"))
      if (xlog) corners[1:2] = 10^(corners[1:2])
      if (ylog) corners[3:4] = 10^(corners[3:4])
      # special logic for facet grids
      if (is.null(facet_newlines) || facet_newlines == 0) {
        facet_title_lines = 1
      } else {
        facet_title_lines = 1 + facet_newlines
      }
      # different logic for facet grids versus regular facets
      if (isTRUE(attr(facet, "facet_grid"))) {
        ## top facet strips
        if (ii %in% 1:nfacet_cols) {
          if (isTRUE(facet_rect)) {
            line_height = (facet_title_lines + .1) * facet_text / cex_fct_adj
            if (ylog) {
              line_height = grconvertY(line_height, from = "lines", to = "user") / grconvertY(0, from = "lines", to = "user")
              rect_height = corners[4] * line_height
            } else {
              line_height = grconvertY(line_height, from = "lines", to = "user") - grconvertY(0, from = "lines", to = "user")
              rect_height = corners[4] + line_height
            }
            rect(
              corners[1], corners[4], corners[2], rect_height,
              col = facet_bg, border = facet_border,
              xpd = NA
            )
          }
          xpos = if (xlog) 10^(mean(log10(corners[1:2]))) else mean(corners[1:2])
          if (ylog) {
            ypos = grconvertY(0.4, from = "lines", to = "user") / grconvertY(0, from = "lines", to = "user")
            ypos = corners[4] * ypos
          } else {
            ypos = grconvertY(0.4, from = "lines", to = "user") - grconvertY(0, from = "lines", to = "user")
            ypos = corners[4] + ypos
          }
          text(
            x = xpos,
            y = ypos,
            labels = sub("^(.*?)~.*", "\\1", facets[[ii]]),
            adj = c(0.5, 0),
            cex = facet_text / cex_fct_adj,
            col = facet_col,
            font = facet_font,
            xpd = NA,
          )
        }
        ## right facet strips
        if (ii %% nfacet_cols == 0 || ii == nfacets) {
          if (isTRUE(facet_rect)) {
            line_height = (facet_title_lines + .1) * facet_text / cex_fct_adj
            if (xlog) {
              line_height = grconvertX(line_height, from = "lines", to = "user") / grconvertX(0, from = "lines", to = "user")
              rect_width = corners[2] * line_height
            } else {
              line_height = grconvertX(line_height, from = "lines", to = "user") - grconvertX(0, from = "lines", to = "user")
              rect_width = corners[2] + line_height
            }
            rect(
              corners[2], corners[3], rect_width, corners[4],
              col = facet_bg, border = facet_border,
              xpd = NA
            )
          }
          if (xlog) {
            xpos = grconvertX(0.4, from = "lines", to = "user") / grconvertX(0, from = "lines", to = "user")
            xpos = corners[2] * xpos
          } else {
            xpos = grconvertX(0.4, from = "lines", to = "user") - grconvertX(0, from = "lines", to = "user")
            xpos = corners[2] + xpos
          }
          ypos = if (ylog) 10^(mean(log10(corners[3:4]))) else mean(corners[3:4])
          text(
            x = xpos,
            y = ypos,
            labels = sub("^.*?~(.*)", "\\1", facets[[ii]]),
            srt = 270,
            adj = c(0.5, 0),
            cex = facet_text / cex_fct_adj,
            col = facet_col,
            font = facet_font,
            xpd = NA
          )
        }
      } else {
        if (isTRUE(facet_rect)) {
          line_height = (facet_title_lines + .1) * facet_text / cex_fct_adj
          if (ylog) {
            line_height = grconvertY(line_height, from = "lines", to = "user") / grconvertY(0, from = "lines", to = "user")
            rect_height = corners[4] * line_height
          } else {
            line_height = grconvertY(line_height, from = "lines", to = "user") - grconvertY(0, from = "lines", to = "user")
            rect_height = corners[4] + line_height
          }
          rect(
            corners[1], corners[4], corners[2], rect_height,
            col = facet_bg, border = facet_border,
            xpd = NA
          )
        }
        xpos = if (xlog) 10^(mean(log10(corners[1:2]))) else mean(corners[1:2])
        if (ylog) {
          ypos = grconvertY(0.4, from = "lines", to = "user") / grconvertY(0, from = "lines", to = "user")
          ypos = corners[4] * ypos
        } else {
          ypos = grconvertY(0.4, from = "lines", to = "user") - grconvertY(0, from = "lines", to = "user")
          ypos = corners[4] + ypos
        }
        text(
          x = xpos,
          y = ypos,
          labels = paste(facets[[ii]]),
          adj = c(0.5, 0),
          cex = facet_text / cex_fct_adj,
          col = facet_col,
          font = facet_font,
          xpd = NA
        )
      }
    }

    # plot frame
    if (frame.plot) box()

    # panel grid lines
    if (is.null(grid)) grid = .tpar[["grid"]]
    if (!is.null(grid)) {
      if (is.logical(grid)) {
        ## If grid is TRUE create a default grid. Rather than just calling the default grid()
        ## abline(... = pretty(extendrange(...)), ...) is used. Reason: pretty() is generic
        ## and works better for axes based on date/time classes. Exception: For axes in logs,
        ## resort to using grid() which is likely better handled there.
        if (isTRUE(grid)) {
          gnx = gny = NULL
          if (!is.null(xaxb)) {
            abline(v = xaxb, col = .tpar[["grid.col"]], lty = .tpar[["grid.lty"]], lwd = .tpar[["grid.lwd"]])
            gnx = NA
          } else if (!any(c(par("xlog"), type == "boxplot"))) {
            xg = if (!inherits(x, c("POSIXt", "Date"))) axTicks(side = 1) else axTicksDateTime(side = 1, x = x)
            abline(v = xg, col = .tpar[["grid.col"]], lty = .tpar[["grid.lty"]], lwd = .tpar[["grid.lwd"]])
            gnx = NA
          }
          if (!is.null(yaxb)) {
            abline(h = yaxb, col = .tpar[["grid.col"]], lty = .tpar[["grid.lty"]], lwd = .tpar[["grid.lwd"]])
            gny = NA
          } else if (!any(c(par("ylog"), type == "boxplot"))) {
            yg = if (!inherits(y, c("POSIXt", "Date"))) axTicks(side = 2) else axTicksDateTime(side = 2, x = x)
            abline(h = yg, col = .tpar[["grid.col"]], lty = .tpar[["grid.lty"]], lwd = .tpar[["grid.lwd"]])
            gny = NA
          }
          grid(nx = gnx, ny = gny, col = .tpar[["grid.col"]], lty = .tpar[["grid.lty"]], lwd = .tpar[["grid.lwd"]])
        }
      } else {
        grid
      }
    }

    # add any drawn elements
    if (!is.null(draw)) eval(draw)
  } # end of ii facet loop

  return(as.list(environment()))
}

#' @rdname facet
#' @keywords internal
facet_layout = function(facet, add = FALSE, facet.args = list()) {
  nfacet_rows = 1
  nfacet_cols = 1
  if (!is.null(facet)) {
    facets = if (is.factor(facet)) levels(facet) else sort(unique(facet))
    ifacet = seq_along(facets)
    nfacets = length(facets)
    if (isTRUE(add)) {
      omfrow = par("mfrow")
      nfacet_rows = omfrow[1]
      nfacet_cols = omfrow[2]
    } else {
      if (isTRUE(attr(facet, "facet_grid"))) {
        facet.args[["nrow"]] = attr(facet, "facet_nrow")
      }
      if (!is.null(facet.args[["nrow"]])) {
        nfacet_rows = facet.args[["nrow"]]
        nfacet_cols = ceiling(nfacets / nfacet_rows)
      } else if (!is.null(facet.args[["ncol"]])) {
        nfacet_cols = facet.args[["ncol"]]
        nfacet_rows = ceiling(nfacets / nfacet_cols)
      } else {
        if (nfacets > 3) {
          nfacet_cols = ceiling(sqrt(nfacets))
          nfacet_rows = ceiling(nfacets / nfacet_cols)
        } else {
          nfacet_rows = 1L
          nfacet_cols = nfacets
        }
      }
    }

    oxaxis = tail(ifacet, nfacet_cols)
    oyaxis = seq(1, nfacets, by = nfacet_cols)

    if (nfacet_rows >= 3 || nfacet_cols >= 3) {
      cex_fct_adj = 0.66
    } else if (nfacet_rows == 2 && nfacet_cols == 2) {
      cex_fct_adj = 0.83
    } else {
      cex_fct_adj = 1
    }
  } else {
    facets = ifacet = nfacets = oxaxis = oyaxis = 1
    cex_fct_adj = 1
  }

  list(
    facets = facets,
    ifacet = ifacet,
    nfacets = nfacets,
    nfacet_rows = nfacet_rows,
    nfacet_cols = nfacet_cols,
    oxaxis = oxaxis,
    oyaxis = oyaxis,
    cex_fct_adj = cex_fct_adj
  )
}

#
# helper functions
#

# utility function for converting facet formulas into variables
get_facet_fml = function(formula, data = NULL) {
  xfacet = yfacet = NULL

  ## catch one-sided formula ~ x or ~ x | z with no "y" variable
  if (!inherits(formula, "formula")) formula = as.formula(formula)
  no_yfacet = length(formula) == 2L
  fml_rhs = if (no_yfacet) 2L else 3L

  ## set up model frame
  m = match.call(expand.dots = FALSE)

  if (!is.null(data)) {
    m = m[c(1L, match(c("formula", "data", "subset", "na.action", "drop.unused.levels"), names(m), 0L))]
  }

  m$formula = formula
  ## need stats:: for non-standard evaluation
  m[[1L]] = quote(stats::model.frame)
  mf = eval.parent(m)

  ## extract variables: x, y (if any)
  if (no_yfacet) {
    yfacet_loc = NULL
    xfacet_loc = 1L
  } else {
    yfacet_loc = 1L
    xfacet_loc = 2L
  }
  if (NCOL(mf) < xfacet_loc) stop("formula should specify at least one variable on the right-hand side")
  yfacet = if (no_yfacet) NULL else mf[, yfacet_loc]
  xfacet = mf[, xfacet_loc:NCOL(mf)]

  ## return object
  xfacet = interaction(xfacet, sep = ":")
  if (no_yfacet) {
    ret = xfacet
  } else {
    # yfacet = interaction(yfacet, sep = ":")
    ## NOTE: We "swap" the formula LHS and RHS since mfrow plots rowwise
    ret = interaction(xfacet, yfacet, sep = "~")
    attr(ret, "facet_grid") = TRUE
    attr(ret, "facet_nrow") = length(unique(yfacet))
  }

  return(ret)
}

## internal convenience function to determine whether the current facet panel
## has the position "left", "right", "top", or "bottom" in the facet grid
is_facet_position = function(position, ifacet, facet_window_args) {
  id = facet_window_args$ifacet
  nc = facet_window_args$nfacet_cols
  ni = tail(id, 1L)
  switch(position,
    "left"   = ifacet %in% seq(1L, ni, by = nc),
    "right"  = ifacet %in% pmin(ni, seq(1L, ni, by = nc) + nc - 1L),
    "top"    = ifacet %in% head(id, nc),
    "bottom" = ifacet %in% tail(id, nc),
    NA
  )
}

#' Ridge plot type
#'
#' @description Type function for producing ridge plots (also known as joy plots),
#' which display density distributions for multiple groups with vertical offsets.
#' This function uses `tinyplot` scaffolding, which enables added functionality
#' such as grouping and faceting.
#'
#' The line color is controlled by the `col` argument in the `tinyplot()` call.
#' The fill color is controlled by the `bg` argument in the `tinyplot()` call.
#'
#' @param scale Numeric. Controls the scaling factor of each plot.
#' Values greater than 1 means that plots overlap.
#' @param joint.max character indicating how to scale the maximum of the densities:
#'   The default `"all"` indicates that all densities are scaled jointly relative to
#'   the same maximum so that the areas of all densities are comparable.
#'   Alternatively, `"facet"` indicates that the maximum is computed within
#'   each facet so that the areas of the densities are comparable within each
#'   facet but not necessarily across facets. Finally, `"by"` indicates that
#'   each row (in each facet) is scaled separately, so that the areas of the
#'   densities for `by` groups in the same row are comparable but not necessarily
#'   across rows.
#' @param breaks Numeric. If a color gradient is used for shading, the
#' breaks between the colors can be modified. The default is to use
#' equidistant breaks spanning the range of the `x` variable.
#' @param probs Numeric. Instead of specifying the same `breaks` on the
#' x-axis for all groups, it is possible to specify group-specific quantiles
#' at the specified `probs`. The quantiles are computed based on the density
#' (rather than the raw original variable). Only one of `breaks` or
#' `probs` must be specified.
#' @param ylevels a character or numeric vector specifying in which order
#' the levels of the y-variable should be plotted.
#' @inheritParams stats::density
#' @param kernel a character string giving the smoothing kernel to be used. This
#'   must partially match one of `"gaussian"`, `"rectangular"`, `"triangular"`,
#'   `"epanechnikov"`, `"biweight"`, `"cosine"` or `"optcosine"`, with default
#'   `"gaussian"`, and may be abbreviated to a unique prefix (single letter).
#'
#'   `"cosine"` is smoother than `"optcosine"`, which is the usual 'cosine'
#'   kernel in the literature and almost MSE-efficient. However, `"cosine"` is
#'   the version used by S.
#' @param joint.bw character string indicating whether (and how) the smoothing
#'   bandwidth should be computed from the joint data distribution. The default
#'   of `"mean"` will compute the joint bandwidth as the mean of the individual
#'   subgroup bandwidths (weighted by their number of observations). Choosing
#'   `"full"` will result in a joint bandwidth computed from the full
#'   distribution (merging all subgroups). For `"none"` the individual bandwidth
#'   will be computed independently for each subgroup. Also accepts a logical
#'   argument, where `TRUE` maps to `"mean"` and `FALSE` maps to `"none"`. See
#'   \code{\link{type_density}} for some discussion of practical considerations.
#' @param gradient Logical or character. Should a gradient fill be used to
#'   shade the area under the density? If a character specification is used,
#'   then it can either be of length 1 and specify the palette to be used with
#'   `gradient = TRUE` corresponding to `gradient = "viridis"`. If a character
#'   vector of length greater than 1 is used, then it should specify the
#'   colors in the palette, e.g., `gradient = hcl.colors(512)`.
#' @param raster Logical. Should the `gradient` fill be drawn using
#'   \code{\link[graphics]{rasterImage}}? Defaults to `FALSE`, in which case the
#'   `gradient` fill will instead be drawn using
#'   \code{\link[graphics]{polygon}}. See the `Technical note on gradient fills`
#'   section below.
#' @param col Character string denoting the outline (border) color for all
#' of the ridge densities. Note that a singular value is expected; if multiple
#' colors are provided then only the first will be used. This argument is mostly
#' useful for the aesthetic effect of drawing a common outline color in
#' combination with gradient fills. See Examples.
#' @param alpha Numeric in the range `[0,1]` for adjusting the alpha
#' transparency of the density fills. In most cases, will default to a value of
#' 1, i.e. fully opaque. But for some `by` grouped plots (excepting the special
#' cases where `by==y` or `by==x`), will default to 0.6.
#'
#' @section Technical note on gradient fills:
#'
#' `tinyplot` uses two basic approaches for drawing gradient fills in ridge line
#' plots, e.g., if `type_ridge(gradient = TRUE)`.
#'
#' The first (and default) polygon-based approach involves dividing up the main
#' density region into many smaller polygons along the x-axis. Each of these
#' smaller polygons inherits a different color "segment" from the underlying
#' palette swatch, which in turn creates the effect of a continuous gradient
#' when they are all plotted together. Internally, this polygon-based approach
#' is vectorized (i.e., all of the sub-polygons are plotted simultaneously). It
#' is thus efficient from a plotting perspective and generally also performs
#' well from an aesthetic perspective. However, it can occasionally produce
#' undesirable plotting artifacts on some graphics devices---e.g., thin but
#' visible vertical lines---if alpha transparency is being used at the same
#' time.
#'
#' For this reason, we also offer an alternative raster-based approach for
#' gradient fills that users can invoke via
#' `type_ridge(gradient = TRUE, raster = TRUE)`. The essential idea is that we
#' coerce the density polygon into a raster representation (using
#' \code{\link[graphics]{rasterImage}}) and achieve the gradient effect via
#' color interpolation. The trade-off this time is potential smoothness
#' artifacts around the top of the ridge densities at high resolutions, since we
#' have converted a vector object into a raster object.
#'
#' Again, we expect that the choice between these two approaches will only
#' matter for ridge plots that combine gradient fills with alpha transparency
#' (and on certain graphics devices). We recommend that users experiment to
#' determine which approach is optimal for their device.
#'
#' @examples
#' aq = transform(
#'   airquality,
#'   Month = factor(month.abb[Month], levels = month.abb[5:9]),
#'   Month2 = factor(month.name[Month], levels = month.name[5:9]),
#'   Late = ifelse(Day > 15, "Late", "Early")
#'   )
#'
#' # default ridge plot (using the "ridge" convenience string)
#' tinyplot(Month ~ Temp, data = aq, type = "ridge")
#'
#' # for ridge plots, we recommend pairing with the dedicated theme(s), which
#' # facilitate nicer y-axis labels, grid lines, etc.
#'
#' tinytheme("ridge")
#' tinyplot(Month ~ Temp, data = aq, type = "ridge")
#'
#' tinytheme("ridge2") # removes the plot frame (but keeps x-axis line)
#' tinyplot(Month ~ Temp, data = aq, type = "ridge")
#'
#' # the "ridge(2)" themes are especially helpful for long y labels, due to
#' # dyanmic plot adjustment
#' tinyplot(Month2 ~ Temp, data = aq, type = "ridge")
#'
#' # pass customization arguments through type_ridge()... for example, use
#' # the scale argument to change/avoid overlap of densities (more on scaling
#' # further below)
#'
#' tinyplot(Month ~ Temp, data = aq, type = type_ridge(scale = 1))
#'
#' ## by grouping is also supported. two special cases of interest:
#'
#' # 1) by == y (color by y groups)
#' tinyplot(Month ~ Temp | Month, data = aq, type = "ridge")
#'
#' # 2) by == x (gradient coloring along x)
#' tinyplot(Month ~ Temp | Temp, data = aq, type = "ridge")
#'
#' # aside: pass explicit `type_ridge(col = <col>)` arg to set a different
#' # border color
#' tinyplot(Month ~ Temp | Temp, data = aq, type = type_ridge(col = "white"))
#'
#' # gradient coloring along the x-axis can also be invoked manually without
#' # a legend (the next two tinyplot calls are equivalent)
#'
#' # tinyplot(Month ~ Temp, data = aq, type = type_ridge(gradient = "agsunset"))
#' tinyplot(Month ~ Temp, data = aq, type = type_ridge(gradient = TRUE))
#'
#' # aside: when combining gradient fill with alpha transparency, it may be
#' # better to use the raster-based approach (test on your graphics device)
#'
#' tinyplot(Month ~ Temp, data = aq,
#'   type = type_ridge(gradient = TRUE, alpha = 0.5),
#'   main = "polygon fill (default)")
#' tinyplot(Month ~ Temp, data = aq,
#'   type = type_ridge(gradient = TRUE, alpha = 0.5, raster = TRUE),
#'   main = "raster fill")
#'
#' # highlighting only the center 50% of the density (i.e., 25%-75% quantiles)
#' tinyplot(Month ~ Temp, data = aq, type = type_ridge(
#'   gradient = hcl.colors(3, "Dark Mint")[c(2, 1, 2)],
#'   probs = c(0.25, 0.75), col = "white"))
#'
#' # highlighting the probability distribution by color gradient
#' # (darkest point = median)
#' tinyplot(Month ~ Temp, data = aq, type = type_ridge(
#'   gradient = hcl.colors(250, "Dark Mint")[c(250:1, 1:250)],
#'   probs = 0:500/500))
#'
#' # faceting also works, although we recommend switching (back) to the "ridge"
#' # theme for faceted ridge plots
#'
#' tinytheme("ridge")
#' tinyplot(Month ~ Ozone, facet = ~ Late, data = aq,
#'   type = type_ridge(gradient = TRUE))
#'
#' ## use the joint.max argument to vary the maximum density used for
#' ## determining relative scaling...
#'
#' # jointly across all densities (default) vs. per facet
#' tinyplot(Month ~ Temp, facet = ~ Late, data = aq,
#'   type = type_ridge(scale = 1))
#' tinyplot(Month ~ Temp, facet = ~ Late, data = aq,
#'   type = type_ridge(scale = 1, joint.max = "facet"))
#'
#' # jointly across all densities (default) vs. per by row
#' tinyplot(Month ~ Temp | Late, data = aq,
#'   type = type_ridge(scale = 1))
#' tinyplot(Month ~ Temp | Late, data = aq,
#'   type = type_ridge(scale = 1, joint.max = "by"))
#'
#' # restore the default theme
#' tinytheme()
#'
#' @export
type_ridge = function(
    scale = 1.5,
    joint.max = c("all", "facet", "by"),
    breaks = NULL,
    probs = NULL,
    ylevels = NULL,
    bw = "nrd0",
    joint.bw =  c("mean", "full", "none"),
    adjust = 1,
    kernel = c("gaussian", "epanechnikov", "rectangular", "triangular", "biweight", "cosine", "optcosine"),
    n = 512,
    # more args from density here?
    gradient = FALSE,
    raster = FALSE,
    col = NULL,
    alpha = NULL
    ) {

  kernel = match.arg(kernel, c("gaussian", "epanechnikov", "rectangular", "triangular", "biweight", "cosine", "optcosine"))
  if (is.logical(joint.bw)) {
    joint.bw = ifelse(joint.bw, "mean", "none")
  }
  joint.bw = match.arg(joint.bw, c("mean", "full", "none"))

  out = list(
    draw = draw_ridge(),
    data = data_ridge(bw = bw, adjust = adjust, kernel = kernel, n = n,
                      joint.bw = joint.bw,
                      scale = scale,
                      joint.max = joint.max,
                      gradient = gradient,
                      breaks = breaks,
                      probs = probs,
                      ylevels = ylevels,
                      raster = raster,
                      col = col,
                      alpha = alpha
                      ),
    name = "ridge"
  )
  class(out) = "tinyplot_type"
  return(out)
}

#
## Underlying data_ridge function
data_ridge = function(bw = "nrd0", adjust = 1, kernel = "gaussian", n = 512,
                      joint.bw = "mean",
                      scale = 1.5,
                      joint.max = "all",
                      gradient = FALSE,
                      breaks = NULL,
                      probs = NULL,
                      ylevels = NULL,
                      raster = FALSE,
                      col = NULL,
                      alpha = NULL
                      ) {
  fun = function(datapoints, yaxt = NULL, null_by, ...) {
    #  catch for special cases
    anyby = !null_by
    x_by = anyby && identical(datapoints$x, datapoints$by)
    y_by = anyby && identical(datapoints$y, datapoints$by)
    if (x_by) {
      gradient = TRUE
      datapoints$by = ""
    } else if (y_by) {
      datapoints$by = ""
    } else if (anyby && is.null(alpha)) {
      alpha = 0.6
    }
    # flag for (non-gradient) interior fill adjustment
    fill_by = anyby || y_by
    if (isTRUE(x_by)) fill_by = FALSE
    # if (isTRUE(anyby) && is.null(alpha)) alpha = 0.6

    ## reorder levels of y-variable if requested
    if (!is.null(ylevels)) {
      if (!is.factor(datapoints$y)) datapoints$y = factor(datapoints$y)
      datapoints$y = factor(datapoints$y, levels = if(is.numeric(ylevels)) levels(datapoints$y)[ylevels] else ylevels)
      if (y_by) datapoints$by = datapoints$y
    }

    ##
    datapoints = split(datapoints, list(datapoints$y, datapoints$by, datapoints$facet))

    if (joint.bw == "none" || is.numeric(bw)) {
        dens_bw = bw
    } else {
        if (joint.bw == "mean") {
            # Use weighted mean of subgroup bandwidths
            bws = sapply(datapoints, function(dat) bw_fun(kernel = bw, dat$x))
            ws = sapply(datapoints, nrow)
            dens_bw = weighted.mean(bws, ws)
        } else if (joint.bw == "full") {
            dens_bw = bw_fun(kernel = bw, unlist(sapply(datapoints, `[[`, "x")))
        }
    }

    datapoints = lapply(datapoints, function(dat) {
      dens = density(dat$x, bw = dens_bw, kernel = kernel, n = n)
      out = data.frame(
        by = dat$by[1], # already split
        facet = dat$facet[1], # already split
        x = dens$x,
        y = dat$y[1],
        ymin = 0L,
        ymax = dens$y
      )
      return(out)
    })
    datapoints = do.call(rbind, datapoints)

    if (is.character(joint.max)) {
      joint.max = match.arg(joint.max, c("all", "facet", "by"))
      joint.max = switch(joint.max,
        "all" = rep.int(1, nrow(datapoints)),
        "facet" = datapoints$facet,
        "by" = interaction(datapoints$facet, datapoints$y)
      )
      joint.max = ave(datapoints$ymax, joint.max, FUN = max)
    }
    datapoints$ymax = datapoints$ymax / joint.max * scale

    datapoints = split(datapoints, datapoints$facet)
    offset_z = function(k) {
      ksplit = split(k, k$y)
      for (idx in seq_along(ksplit)) {
        ksplit[[idx]]$ymax = ksplit[[idx]]$ymax + idx - 1
        ksplit[[idx]]$ymin = ksplit[[idx]]$ymin + idx - 1
      }
      k = do.call(rbind, ksplit)
      return(k)
    }
    datapoints = do.call(rbind, lapply(datapoints, offset_z))

    if (y_by) {
      datapoints$y = factor(datapoints$y)
      datapoints$by = factor(datapoints$y, levels = rev(levels(datapoints$y)))
    } else if (x_by) {
      datapoints$by = datapoints$x
    }

    # Manual breaks flag. Only used if gradient is on
    manbreaks = !is.null(breaks) || !is.null(probs)

    ## use color gradient?
    xlim = range(datapoints$x, na.rm = TRUE)
    if (!is.null(probs)) {
      if (!is.null(breaks)) {
        warning("only one of 'breaks' and 'quantile' must be specified")
        probs = NULL
      } else {
        if (probs[1L] > 0) probs = c(0, probs)
        if (probs[length(probs)] < 1) probs = c(probs, 1)
      }
    }
    if (!isFALSE(gradient)) {
      dotspal = list(...)[["palette"]]
      palette = if (!is.null(dotspal)) dotspal else gradient
      gradient = TRUE
      if (isTRUE(palette)) {
        palette = if (!is.null(.tpar[["palette.sequential"]])) .tpar[["palette.sequential"]] else "viridis"
      }

      if (length(palette) > 1L || !is.character(palette)) {
        ## color vector already given
        if (is.null(breaks) && is.null(probs)) {
          breaks = seq(from = xlim[1L], to = xlim[2L], length.out = length(palette) + 1L)
        } else {
          npal = pmax(length(breaks), length(probs)) - 1L
          if (length(palette) != npal) {
            warning("length of 'palette' does not match 'breaks'/'probs'")
            palette = rep_len(palette, npal)
          }
          if (isTRUE(raster)) raster = npal > 20L
        }
      } else {
        ## only palette name given
        npal = if (is.null(breaks) && is.null(probs)) 512L else pmax(length(breaks), length(probs)) - 1L
        palette = hcl.colors(npal, palette = palette)
        if (is.null(breaks) && is.null(probs)) breaks = seq(from = xlim[1L], to = xlim[2L], length.out = npal + 1L)
        if (isTRUE(raster)) raster = npal > 20L
      }
    } else {
      palette = NULL
      if (!is.null(breaks) || !is.null(probs)) gradient = TRUE
    }
    if (!is.null(breaks)) {
      breaks[1L] = pmin(breaks[1L], xlim[1L])
      breaks[length(breaks)] = pmax(breaks[length(breaks)], xlim[2L])
    }

    if (is.null(col) && (!anyby || x_by)) col = "black"

    out = list(
      datapoints = datapoints,
      yaxt = "n",
      ylim = c(min(datapoints$ymin), max(datapoints$ymax)),
      type_info = list(
        gradient = gradient,
        palette = palette,
        breaks = breaks,
        probs = probs,
        manbreaks = manbreaks,
        yaxt = yaxt,
        raster = raster,
        x_by = x_by,
        y_by = y_by,
        fill_by = fill_by,
        col = col,
        alpha = alpha
      )
    )
    return(out)
  }
  return(fun)
}

#
## Underlying draw_ridge function
draw_ridge = function() {
  fun = function(ix, iy, iz, ibg, icol, iymin, iymax, type_info, ...) {
    ridge_theme = identical(.tpar[["tinytheme"]], "ridge") || identical(.tpar[["tinytheme"]], "ridge2")
    d = data.frame(x = ix, y = iy, ymin = iymin, ymax = iymax)
    dsplit = split(d, d$y)
    if (is.null(ibg)) {
      default_bg = if (!ridge_theme && !is.null(.tpar[["palette.qualitative"]])) seq_palette(by_col(), n = 2)[2] else "gray"
      ibg = if (isTRUE(type_info[["fill_by"]])) seq_palette(icol, n = 2)[2] else default_bg
    }
    if (!is.null(type_info[["alpha"]]) && is.null(type_info[["palette"]])) {
      ibg = adjustcolor(ibg, alpha.f = type_info[["alpha"]])
    }
    if (!is.null(type_info[["col"]])) icol = type_info[["col"]]
    lab = if (is.factor(d$y)) levels(d$y) else unique(d$y)
    if (isTRUE(type_info[["y_by"]])) {
      # avoid duplicating the y-axis labs for the special y==by case
      # val = match(lab, levels(d$y)) - 1
      val = match(d$y[1], levels(d$y))
      lab = lab[val]
      val = val - 1
    } else {
      val = cumsum(rep(1, length(lab))) - 1
    }
    if (ridge_theme) abline(h = val, col = .tpar[["grid.col"]])
    draw_segments = if (type_info[["raster"]]) segmented_raster else segmented_polygon
    for (i in rev(seq_along(dsplit))) {
      if (type_info[["gradient"]]) {
        with(
          dsplit[[i]],
          draw_segments(
            x, ymax, ymin = ymin[1L],
            breaks = type_info[["breaks"]],
            probs = type_info[["probs"]],
            manbreaks = type_info[["manbreaks"]],
            col = if (is.null(type_info[["palette"]])) ibg else type_info[["palette"]],
            # border = if (is.null(type_info[["palette"]])) icol else "transparent",
            alpha = type_info[["alpha"]]
          )
        )
      }
      with(dsplit[[i]], polygon(x, ymax, col = if (type_info[["gradient"]]) "transparent" else ibg, border = NA))
      with(dsplit[[i]], lines(x, ymax, col = icol))
    }
    # tinyAxis(x = d$y, side = 2, at = val, labels = lab, type = type_info[["yaxt"]], padj = padj)
    if (ridge_theme) {
      tinyAxis(x = d$y, side = 2, at = val, labels = lab, type = type_info[["yaxt"]],
               padj = 0,
               mgp = c(3, 1, 0) - c(0.5, 0.5 + 0.3, 0),
               tcl = 0)
      if (identical(.tpar[["tinytheme"]], "ridge2")) axis(1, labels = FALSE)
    } else {
      tinyAxis(x = d$y, side = 2, at = val, labels = lab, type = type_info[["yaxt"]])
    }
  }
  return(fun)
}

#
## Auxiliary functions

## auxiliary function for drawing shaded segmented polygon
segmented_polygon = function(x, y, ymin = 0, breaks = range(x), probs = NULL, manbreaks = FALSE, col = "lightgray", border = "transparent", alpha = NULL) {

  if (!is.null(probs)) {
    ## map quantiles to breaks
    if (!(missing(breaks) || is.null(breaks))) stop("only one of 'breaks' and 'probs' must be specified")
    breaks = quantile.density(list(x = x, y = y - ymin), probs = probs)
  }

  ## sanity check
  if (breaks[1L] > x[1L] || breaks[length(breaks)] < x[length(x)]) stop("'breaks' do no span range of 'x'")

  # ## recycle color (if necessary) rather use colorRampPalette below
  # col = rep_len(col, length(breaks) - 1L)

  # Create individual polygons
  if (isFALSE(manbreaks)) {
    # Special case for length(breaks)==length(x). We can take a fully vectorised
    # shortcut
    xx = c(rbind(x[-length(x)], x[-1], x[-1], x[-length(x)], NA))
    yy = c(rbind(y[-length(y)], y[-1], ymin, ymin, NA))
  } else {
    # For other cases, we'll do a bit more work to make sure that the polygons
    # overlap
    bvals = do.call(c, sapply(seq_along(breaks[-1]), function(b) tail(x[x<breaks[b]], 1)))
    bidx = match(bvals, x)
    bidx = c(1, bidx, length(x))
    xx = do.call(c, sapply(
      seq_along(bidx[-1]),
      function(b) {
        xx = x[bidx[b]:bidx[b+1]]
        c(xx, rev(xx), NA)
      }
    ))
    yy = do.call(c, sapply(
      seq_along(bidx[-1]),
      function(b) {
        yy = y[bidx[b]:bidx[b+1]]
        c(yy, rep(ymin, length(yy)), NA)
      }
    ))
    # Catch for missing lower breaks if individual density doesn't span the full
    # range of x (and discrete color fills are supplied)
    # Aside: We only need to fix the lower missing breaks, since missing top
    # breaks will be ignored in the final polygon call anyway
    lwrmissings = breaks < x[bidx][1]
    if (any(lwrmissings[-1])) {
      lwrmissings = breaks[lwrmissings]
      xxtra = c(rbind(lwrmissings[-length(lwrmissings)], lwrmissings[-1], lwrmissings[-1], lwrmissings[-length(lwrmissings)], NA))
      yytra = c(rbind(rep(ymin, length(lwrmissings)-1), ymin, ymin, ymin, NA))
      xx = c(xxtra, xx)
      yy = c(yytra, yy)
    }
  }

  # Drop trailing NAs
  xx = xx[1:(length(xx)-1)]
  yy = yy[1:(length(yy)-1)]

  if (!is.null(alpha)) col = adjustcolor(col, alpha.f = alpha)

  # Color ramp for cases where the breaks don't match
  if (isFALSE(length(col)==1)) {
    col = rev(col) ## uncomment to make extreme cols dark
    if (isTRUE(manbreaks)) {
      if (!is.null(breaks) && length(breaks)-1 != length(col)) {
        xrange = range(xx, na.rm = TRUE)
        idx = which(breaks >= xrange[1] & breaks < xrange[2])
        idx = c(idx, length(idx)+1)
        col = col[idx]
        col = colorRampPalette(col, alpha = TRUE)(length(x)) # support alpha?
      }
    } else if (isFALSE(manbreaks) || length(col) > length(x) || length(x) %% length(col) != 0) {
      xrange = range(xx, na.rm = TRUE)
      idx = which(breaks >= xrange[1] & breaks < xrange[2])
      idx = c(idx, length(idx)+1)
      col = col[idx]
      col = colorRampPalette(col, alpha = TRUE)(length(x)) # support alpha?
    }
  }
  border = if (is.null(alpha)) col else adjustcolor(col = col, alpha.f = alpha/2)

  ## draw all polygons
  polygon(xx, yy, col = col, border = border, lwd = 0.5)
}

#' @importFrom graphics rasterImage
#' @importFrom grDevices as.raster
segmented_raster = function(x, y, ymin = 0, breaks = range(x), probs = NULL, manbreaks = FALSE, col = "lightgray", border = "transparent", alpha = NULL) {
  ## set up raster matrix on x-grid and 500 y-pixels
  n = length(x) - 1L
  m = 500L ## FIXME: hard-coded?
  r = matrix(1:n, ncol = n, nrow = m, byrow = TRUE)

  ## map quantiles to breaks
  if (!is.null(probs)) {
    if (!(missing(breaks) || is.null(breaks))) stop("only one of 'breaks' and 'probs' must be specified")
    breaks = quantile.density(list(x = x, y = y - ymin), probs = probs)
  }

  if (!is.null(alpha)) col = adjustcolor(col, alpha.f = alpha)
  col = rev(col) ## uncomment to make extreme cols dark
  ## map colors to intervals and fill colors by column
  col = col[cut(x, breaks = breaks, include.lowest = TRUE)]
  r[] = col[r]

  ## clip raster pixels above density line
  ymax = max(y)
  ix = cbind(as.vector(row(r)), as.vector(col(r)))
  ix = ix[seq(from = ymax, to = ymin, length.out = m)[row(r)] > y[col(r)], , drop = FALSE]
  r[ix] = NA

  ## plot density and add raster gradient
  rasterImage(as.raster(r), min(x), ymin, max(x), ymax, interpolate = length(breaks) >= 20L) ## FIXME: improve quality for "few" breaks?
}

## auxiliary function for determining quantiles based on density function

#' @importFrom stats median approx
quantile.density = function(x, probs = seq(0, 1, 0.25), ...) {
  ## sanity check for probabilities
  if (any(probs < 0 | probs > 1)) stop("'probs' outside [0,1]")

  ## probability density function, extrapolated to zero, use midpoints
  n = length(x$x)
  pdf = x$y
  pdf = c(0, pdf, 0)

  ## x variable, also extrapolated, use midpoints
  x = x$x
  delta = median(diff(x))
  x = c(x[1L] - delta, x, x[n] + delta)

  ## numerical integration of density
  cdf = c(0, cumsum(diff(x) * (pdf[-1L] + pdf[-(n + 2L)])/2))
  cdf = cdf/cdf[n + 2L]

  ## approximate quantiles
  approx(cdf, x, xout = probs, rule = 2)$y
}

#' Add straight lines to a plot
#' @description
#' These functions add straight line(s) through the current plot.
#' @details
#' While `type_abline`, `type_hline`, and `type_vline` can be called in a base
#' plot layer, we expect that they will typically be called as subsequent
#' layers via [`tinyplot_add`].
#' @section Recycling logic:
#' The recycling behaviour of the line parameters (i.e., `a`, `b`, `h`, or `v`)
#' is adaptive, depending on whether `by` or `facet` grouping is detected. While
#' this leads to different recycling scenarios, the underlying code logic
#' follows sensible heuristics designed to match user expectations.
#'
#' Parameter lengths must equal one of four options:
#'
#' 1. Single value (i.e., length = 1), i.e. simplest case where the same line is
#' applied uniformly across all groups and facets. Uses the default user colour
#' (e.g. `"black"`, or `tpar("palette.qualitative")[1]` if a theme is set).
#' 2. Number of `by` groups, i.e. one parameter per group. For example,
#' `tinyplot(mpg ~ wt | factor(cyl), data = mtcars, type = type_hline(h = 21:23))`
#' will give three horizontal lines, with colours matching the user's qualitative
#' palette.
#' 3. Number of `facet` groups, i.e. one parameter per facet panel. For example:
#' `tinyplot(mpg ~ wt, facet = ~am, data = mtcars, type = type_hline(h = c(20,30)))`
#' would give separate horizontal lines per facet, but both using the same
#' default color.
#' 4. Product of `by` and `facet` groups, i.e. one parameter for each unique
#' by-facet combination. Orders over facets first and then, within that, by
#' group. For example:
#' `tinyplot(mpg ~ wt | factor(cyl), facet = ~am, data = mtcars, type = type_hline(h = 21:26))`
#' will give six separate lines, with the first three (`21:23`) coloured by
#' group in the first facet, and second three (`24:26`) coloured by by group
#' in the second facet.
#'
#' Alongside these general rules, we also try to accomodate special cases when
#' other aesthetic parameters like `lwd` or `lty` are invoked by the user. See
#' Examples.
#'
#' @param a,b the intercept (default: `a` = 0) and slope (default: `b` = 1)
#'   terms. Numerics of length 1, or equal to the number of groups or number of
#'   facets (or the product thereof).
#' @examples
#' #
#' ## abline
#'
#' tinyplot(x = -10:10, y = rnorm(21) + -10:10, grid = TRUE)
#' tinyplot_add(type = "abline")
#' # same as...
#' # tinyplot_add(type = type_abline(a = 0, b = 1))
#'
#' # customize by passing bespoke intercept and slope values
#' tinyplot_add(type = type_abline(a = -1, b = -0.5))
#'
#' # note that calling as abline & co. as a base plot layer will still lead to
#' # axes limits that respect the range of the data
#' tinyplot(x = -10:10, y = -10:10, grid = TRUE, type = "abline")
#'
#' #
#' ## hline and vline
#'
#' # Base plot layer
#' tinyplot(mpg ~ hp | cyl, facet = "by", data = mtcars, ylim = c(0, 40))
#'
#' # Add horizontal lines at the (default) 0 y-intercept
#' tinyplot_add(type = "hline", col = "grey")
#'
#' # Note that group+facet aesthetics will be inherited. We can use this to
#' # add customized lines (here: the mean `mpg` for each `cyl` group)
#' tinyplot_add(type = type_hline(with(mtcars, tapply(mpg, cyl, mean))), lty = 2)
#'
#' # Similar idea for vline
#' tinyplot_add(type = type_vline(with(mtcars, tapply(hp, cyl, mean))), lty = 2)
#'
#' #
#' ## Recycling logic
#'
#' # length(h) == no. of groups
#' tinyplot(mpg ~ wt | factor(cyl), data = mtcars, type = type_hline(h = 21:23))
#'
#' # length(h) == no. of facets
#' tinyplot(mpg ~ wt, facet = ~am, data = mtcars, type = type_hline(h = c(20, 30)))
#'
#' # length(h) == no. of groups x no. of facets
#' tinyplot(mpg ~ wt | factor(cyl), facet = ~am, data = mtcars,
#'    type = type_hline(h = 21:26))
#'
#' # special adjustment case (here: lwd by group)
#' tinyplot(mpg ~ wt | factor(cyl), facet = ~am, data = mtcars,
#'    type = type_hline(c(20, 30)), lwd = c(21, 14, 7))
#'
#' @export
type_abline = function(a = 0, b = 1) {
  data_abline = function(datapoints, lwd, lty, col, ...) {
    if (nrow(datapoints) == 0) {
      msg = "`type_abline() only works on existing plots with x and y data points."
      stop(msg, call. = FALSE)
    }
    # keep track of unique lty and lwd (needed for group catch / escape hatch
    # later in draw_hline)
    ul_lwd = length(unique(lwd))
    ul_lty = length(unique(lty))
    ul_col = length(unique(col))
    return(list(type_info = list(ul_lty = ul_lty, ul_lwd = ul_lwd, ul_col = ul_col)))
  }
  draw_abline = function() {
    fun = function(
      ifacet, iby, data_facet, icol, ilty, ilwd,
      ngrps, nfacets, by_continuous, facet_by,
      type_info,
      ...
    ) {

      # flag for aesthetics by groups
      grp_aes = type_info[["ul_col"]] == 1 || type_info[["ul_lty"]] == ngrps || type_info[["ul_lwd"]] == ngrps

      if (length(a) != 1) {
        if (!length(a) %in% c(ngrps, nfacets, ngrps*nfacets)) {
          msg = "Length of 'a' must be 1, or equal to the number of facets or number of groups (or product thereof)."
          stop(msg, call. = FALSE)
        }
        if (!facet_by && length(a) == nfacets) {
          a = a[ifacet]
          if (!grp_aes && type_info[["ul_col"]]!=ngrps) {
            icol = 1
          } else if (by_continuous) {
            icol = 1
          }
        } else if (!by_continuous && length(a) == ngrps * nfacets) {
          a = a[ifacet * ngrps - c(ngrps - iby)]
        } else if (!by_continuous) {
          a = a[iby]
        }
      } else if (!grp_aes) {
        icol = 1
      }

      if (length(b) != 1) {
        if (!length(b) %in% c(ngrps, nfacets, ngrps*nfacets)) {
          msg = "Length of 'b' must be 1, or equal to the number of facets or number of groups (or product thereof)."
          stop(msg, call. = FALSE)
        }
        if (!facet_by && length(b) == nfacets) {
          b = b[ifacet]
          if (!grp_aes && type_info[["ul_col"]]!=ngrps) {
            icol = 1
          } else if (by_continuous) {
            icol = 1
          }
        } else if (!by_continuous && length(b) == ngrps * nfacets) {
          b = b[ifacet * ngrps - c(ngrps - iby)]
        } else if (!by_continuous) {
          b = b[iby]
        }
      } else if (!grp_aes) {
        icol = 1
      }

      if (type_info[["ul_col"]]!=1 && !(type_info[["ul_lty"]]==ngrps || type_info[["ul_lwd"]]==ngrps)) {
        icol = 1
      }

      abline(a = a, b = b, col = icol, lty = ilty, lwd = ilwd)
    }
    return(fun)
  }
  out = list(
    draw = draw_abline(),
    data = data_abline,
    name = "abline"
  )
  class(out) = "tinyplot_type"
  return(out)
}

#' Barplot type
#'
#' @description Type function for producing barplots. For formulas of type
#'   `~ x` (without left-hand side) the barplot visualizes the counts (absolute
#'   frequencies) of the levels of `x`. For formulas of type `y ~ x` the value
#'   of `y` within each level of `x` is visualized, if necessary aggregated
#'   using some function (default: mean).
#'
#' @param width numeric, optional vector of bar widths. (The distance between
#'   the midpoints of the bars is always 1.)
#' @param beside logical. In case of a `by` grouping variable, should bars be
#'   juxtaposed? Default is to use stacked bars instead.
#' @param center logical or numeric. In case of stacked barplots (`beside = FALSE`)
#'   should the bars be centered (or all start at zero, default)? If set to
#'   `TRUE` the center is at the mid-point of the middle category (in case of
#'   uneven number of categories) or between the two middle categories (in case
#'   of an even number). Additionally it is possible to set `center = 2` or
#'   `center = 2.5` to indicate that centering should be after the second category
#'   or the mid-way in the third category, respectively.
#' @param FUN a function to compute the summary statistic for `y` within each
#'   group of `x` in case of using a two-sided formula `y ~ x` (default: mean).
#' @param xlevels a character or numeric vector specifying the ordering of the
#'   levels of the `x` variable (if character) or the corresponding indexes
#'   (if numeric) for the plot.
#' @param xaxlabels a character vector with the axis labels for the `x` variable,
#'   defaulting to the levels of `x`.
#' @param drop.zeros logical. Should bars with zero height be dropped? If set
#'   to `FALSE` (default) a zero height bar is still drawn for which the border
#'   lines will still be visible.
#'
#' @examples
#' # Basic examples of frequency tables (without y variable)
#' tinyplot(~ cyl, data = mtcars, type = "barplot")
#' tinyplot(~ cyl | vs, data = mtcars, type = "barplot")
#' tinyplot(~ cyl | vs, data = mtcars, type = "barplot", beside = TRUE)
#' tinyplot(~ cyl | vs, data = mtcars, type = "barplot", beside = TRUE, fill = 0.2)
#'
#' # Reorder x variable categories either by their character levels or numeric indexes
#' tinyplot(~ cyl, data = mtcars, type = "barplot", xlevels = c("8", "6", "4"))
#' tinyplot(~ cyl, data = mtcars, type = "barplot", xlevels = 3:1)
#'
#' # Note: Above we used automatic argument passing for `beside`. But this
#' # wouldn't work for `width`, since it would conflict with the top-level
#' # `tinyplot(..., width = <width>)` argument. It's safer to pass these args
#' # through the `type_barplot()` functional equivalent.
#' tinyplot(~ cyl | vs, data = mtcars, fill = 0.2,
#'   type = type_barplot(beside = TRUE, drop.zeros = TRUE, width = 0.65))
#'
#' tinytheme("clean2")
#'
#' # Example for numeric y aggregated by x (default: FUN = mean) + facets
#' tinyplot(extra ~ ID | group, facet = "by", data = sleep,
#'   type = "barplot", fill = 0.6)
#'
#' # Fancy frequency table:
#' tinyplot(Freq ~ Sex | Survived, facet = ~ Class, data = as.data.frame(Titanic),
#'   type = "barplot", facet.args = list(nrow = 1), flip = TRUE, fill = 0.6)
#'
#' # Centered barplot for conditional proportions of hair color (black/brown vs.
#' # red/blond) given eye color and sex
#' tinytheme("clean2", palette.qualitative = c("black", "sienna", "indianred", "goldenrod"))
#' hec = as.data.frame(proportions(HairEyeColor, 2:3))
#' tinyplot(Freq ~ Eye | Hair, facet = ~ Sex, data = hec, type = "barplot",
#'   center = TRUE, flip = TRUE, facet.args = list(ncol = 1), yaxl = "percent")
#'
#' tinytheme()
#'
#' @export
type_barplot = function(width = 5/6, beside = FALSE, center = FALSE, FUN = NULL, xlevels = NULL, xaxlabels = NULL, drop.zeros = FALSE) {
  out = list(
    data = data_barplot(width = width, beside = beside, center = center, FUN = FUN, xlevels = xlevels, xaxlabels = xaxlabels, drop.zeros = drop.zeros),
    draw = draw_rect(),
    name = "barplot"
  )
  class(out) = "tinyplot_type"
  return(out)
}

#' @importFrom stats aggregate
data_barplot = function(width = 5/6, beside = FALSE, center = FALSE, FUN = NULL, xlevels = NULL, xaxlabels = NULL, drop.zeros = FALSE) {
    fun = function(datapoints, col, bg, lty, lwd, palette, xlab = NULL, ylab = NULL, xlim = NULL, ylim = NULL, xaxt = NULL, yaxl = NULL, yaxt = NULL, axes = TRUE, null_by, facet_by, ...) {

        ## tabulate/aggregate datapoints
        if (is.null(datapoints$y)) {
          xlab = ylab
          ylab = "Count"

          datapoints$y = numeric(nrow(datapoints))
          if (!is.null(FUN)) warning("without 'y' variable 'FUN' specification is ignored")
          FUN = length
        } else {
          if (is.null(FUN)) FUN = function(x, ...) mean(x, ..., na.rm = TRUE)
        }
        if (!is.factor(datapoints$x)) datapoints$x = factor(datapoints$x)
        if (!is.null(xlevels)) {
          xlevels = if(is.numeric(xlevels)) levels(datapoints$x)[xlevels] else xlevels
          if (any(is.na(xlevels)) || !all(xlevels %in% levels(datapoints$x))) warning("not all 'xlevels' correspond to levels of 'x'")
          datapoints$x = factor(datapoints$x, levels = xlevels)
        }
        if (!is.null(xaxlabels)) levels(datapoints$x) <- xaxlabels
        datapoints = aggregate(datapoints[, "y", drop = FALSE], datapoints[, c("x", "by", "facet")], FUN = FUN, drop = FALSE)
        datapoints$y[is.na(datapoints$y)] = 0 #FIXME: always?#
        if (!is.factor(datapoints$by)) datapoints$by = factor(datapoints$by)
        if (!is.factor(datapoints$facet)) datapoints$facet = factor(datapoints$facet)

        if (isFALSE(null_by) && isFALSE(facet_by) && !beside && any(datapoints$y < 0)) {
          warning("'beside' must be TRUE if there are negative 'y' values")
          beside = TRUE
        }
        if (beside & !isFALSE(center)) {
          warning("'center' is currently only supported for 'beside = FALSE'")
        }
        offset_sum = function(z, center = TRUE, na.rm = TRUE) {
          n = length(z)
          if (isFALSE(center) || n < 1L) return(0)
          mid = if (isTRUE(center)) n/2 else center
          z[floor(mid) + 1L] = (mid - floor(mid)) * z[floor(mid) + 1L]
          sum(z[0L:floor(mid) + 1L], na.rm = TRUE)
        }
        if (is.null(xlim)) xlim = c(1, length(levels(datapoints$x))) + c(-0.5, 0.5) * width
        if (is.null(ylim)) ylim = if (beside || length(unique(datapoints$by)) == 1L) {
          c(pmin(0, min(datapoints$y, na.rm = TRUE) * 1.02), pmax(0, max(datapoints$y, na.rm = TRUE) * 1.02))
        } else {
          range(unlist(tapply(
            datapoints$y,
            interaction(datapoints$x, datapoints$facet),
            function(z) c(0, sum(z, na.rm = TRUE)) - offset_sum(z, center = center)
          ))) * 1.02
        }

        ## default color palette
        ngrps = length(unique(datapoints$by))
        if (ngrps == 1L && is.null(palette)) {
          if (is.null(col)) col = par("fg")
          if (is.null(bg)) bg = "grey"
        } else {
          if (is.null(bg)) bg = "by"
        }

        ## calculate bar rectangles per facet
        sdat = split(datapoints, datapoints$facet)
        datapoints = lapply(sdat, function(df)  {

          df = df[order(df$x), , drop = FALSE]
          nx = length(levels(df$x))
          nb = length(levels(df$by))

          if (beside) {
            xl = as.numeric(df$x) - width/2 + (as.numeric(df$by) - 1) * width/nb * as.numeric(!facet_by)
            xr = if (facet_by) xl + width else xl + width/nb
            yb = 0
            yt = df$y
          } else {
            cs = tapply(df$y, df$x, function(z) cumsum(c(0, z)) - offset_sum(z, center = center))
            xl = as.numeric(df$x) - width/2
            xr = xl + width
            yb = if (facet_by) 0 else unlist(lapply(cs, `[`, -(nb + 1L)))
            yt = if (facet_by) df$y else unlist(lapply(cs, `[`, -1L))
          }

          df$xmin = xl
          df$xmax = xr
          df$ymin = yb
          df$ymax = yt
          df$nx = nx

          if (drop.zeros) {
            yb = rep_len(yb, length(yt))
            yok = abs(yt - yb) > 0
            df = df[yok,  , drop = FALSE]
          }

          return(df)
        })
        datapoints = do.call("rbind", datapoints)
        nx = datapoints$nx[1]
        datapoints$nx = NULL
        xlabs = 1L:nx
        names(xlabs) = levels(datapoints$x)

        if (!isFALSE(center)) {
          if (is.null(yaxl)) {
            yaxl = abs
          } else if (is.character(yaxl)) {
            yaxl = paste0("abs_", yaxl)
          }
        }

        out = list(
          datapoints = datapoints,
          xlab = xlab,
          ylab = ylab,
          xlim = xlim,
          ylim = ylim,
          axes = FALSE, #FIXME
          axes = TRUE,
          xlabs = xlabs,
          frame.plot = FALSE,
          xaxs = "r",
          xaxt = if (xaxt == "s") "l" else xaxt,
          yaxl = yaxl,
          yaxs = "i",
          col = col,
          bg = bg
        )
        return(out)
    }
    return(fun)
}

#' @title Set or query graphical parameters
#'
#' @description Extends \code{\link[graphics]{par}}, serving as a (near) drop-in
#'   replacement for setting or querying graphical parameters. The key
#'   differences is that, beyond supporting the standard group of R graphical
#'   parameters in \code{\link[graphics]{par}}, `tpar` also supports additional
#'   graphical parameters that are provided by `tinyplot`. Similar to
#'   \code{\link[graphics]{par}}, parameters are set by passing appropriate
#'   `key = value` argument pairs, and multiple parameters can be set or queried
#'   at the same time.
#'
#' @param ... arguments of the form `key = value`. This includes all of the
#'   parameters typically supported by \code{\link[graphics]{par}}, as well as
#'   the `tinyplot`-specific ones described in the 'Graphical Parameters'
#'   section below.
#' @param hook Logical. If `TRUE`, base graphical parameters persist across
#'   plots via a hook applied before each new plot (see `?setHook`).
#'
#' @md
#' @details The `tinyplot`-specific parameters are saved in an internal
#'   environment called `.tpar` for performance and safety reasons. However,
#'   they can also be set at package load time via \code{\link[base]{options}},
#'   which may prove convenient for users that want to enable different default
#'   behaviour at startup (e.g., through an `.Rprofile` file). These options all
#'   take a `tinyplot_*` prefix, e.g.
#'   `options(tinyplot_grid = TRUE, tinyplot_facet.bg = "grey90")`.
#'
#' For their part, any "base" graphical parameters are caught dynamically and
#'   passed on to \code{\link[graphics]{par}} as appropriate. Technically, only
#'   parameters that satisfy `par(..., no.readonly = TRUE)` are evaluated.
#'
#' However, note the important distinction: `tpar` only evaluates parameters
#'   from \code{\link[graphics]{par}} if they are passed _explicitly_ by the
#'   user. This means that `tpar` should not be used to capture the (invisible)
#'   state of a user's entire set of graphics parameters, i.e. `tpar()` !=
#'   `par()`. If you want to capture the _all_ existing graphics settings, then
#'   you should rather use `par()` instead.
#'
#' @returns When parameters are set, their previous values are returned in an
#'   invisible named list. Such a list can be passed as an argument to `tpar` to
#'   restore the parameter values.
#'
#'   When just one parameter is queried, the value of that parameter is returned
#'   as (atomic) vector. When two or more parameters are queried, their values
#'   are returned in a list, with the list names giving the parameters.
#'
#'   Note the inconsistency: setting one parameter returns a list, but querying
#'   one parameter returns a vector.
#'
#' @section Additional Graphical Parameters:
#'
#' * `adj.xlab`: Numeric value between 0 and 1 controlling the alignment of the x-axis label.
#' * `adj.ylab`: Numeric value between 0 and 1 controlling the alignment of the y-axis label.
#' * `cairo`: Logical indicating whether \code{\link[grDevices]{cairo_pdf}} should be used when writing plots to PDF. If `FALSE`, then \code{\link[grDevices]{pdf}} will be used instead, with implications for embedding (non-standard) fonts. Only used if `tinyplot(..., file = "<filename>.pdf")` is called. Defaults to the value of `capabilities("cairo")`.
#' * `dynmar`: Logical indicating whether `tinyplot` should attempt dynamic adjustment of margins to reduce whitespace and/or account for spacing of text elements (e.g., long horizontal y-axis labels). Note that this parameter is tightly coupled to internal `tinythemes()` logic and should _not_ be adjusted manually unless you really know what you are doing or don't mind risking unintended consequences to your plot.
#' * `facet.bg`: Character or integer specifying the facet background colour. If an integer, will correspond to the user's default colour palette (see `palette`). Passed to `rect`. Defaults to `NULL` (none).
#' * `facet.border`: Character or integer specifying the facet border colour. If an integer, will correspond to the user's default colour palette (see `palette`). Passed to `rect`. Defaults to `NA` (none).
#' * `facet.cex`: Expansion factor for facet titles. Defaults to `1`.
#' * `facet.col`: Character or integer specifying the facet text colour. If an integer, will correspond to the user's default global colour palette (see `palette`). Defaults to `NULL`, which is equivalent to "black".
#' * `facet.font`: An integer corresponding to the desired font face for facet titles. For most font families and graphics devices, one of four possible values: `1` (regular), `2` (bold), `3` (italic), or `4` (bold italic). Defaults to `NULL`, which is equivalent to `1` (i.e., regular).
#' * `file.height`: Numeric specifying the height (in inches) of any plot that is written to disk using the `tinyplot(..., file = X)` argument. Defaults to `7`.
#' * `file.res`: Numeric specifying the resolution (in dots per square inch) of any plot that is written to disk in bitmap format (i.e., PNG or JPEG) using the `tinyplot(..., file = X)` argument. Defaults to `300`.
#' * `file.width`: Numeric specifying the width (in inches) of any plot that is written to disk using the `tinyplot(..., file = X)` argument. Defaults to `7`.
#' * `fmar`: A numeric vector of form `c(b,l,t,r)` for controlling the (base) margin padding, in terms of lines, between the individual facets in a faceted plot. Defaults to `c(1,1,1,1)`. If more than three facets are detected, the `fmar` parameter is scaled by 0.75 to reduce excess whitespace. For 2x2 plots, the padding better matches the `cex` expansion logic of base graphics.
#' * `grid.col`: Character or (integer) numeric that specifies the color of the panel grid lines. Defaults to `"lightgray"`.
#' * `grid.lty`: Character or (integer) numeric that specifies the line type of the panel grid lines. Defaults to `"dotted"`.
#' * `grid.lwd`: Non-negative numeric giving the line width of the panel grid lines. Defaults to `1`.
#' * `grid`: Logical indicating whether a background panel grid should be added to plots automatically. Defaults to `NULL`, which is equivalent to `FALSE`.
#' * `lmar`: A numeric vector of form `c(inner, outer)` that gives the margin padding, in terms of lines, around the automatic `tinyplot` legend. Defaults to `c(1.0, 0.1)`. The inner margin is the gap between the legend and the plot region, and the outer margin is the gap between the legend and the edge of the graphics device.
#' * `palette.qualitative`: Palette for qualitative colors. See the `palette` argument in `?tinyplot`.
#' * `palette.sequential`: Palette for sequential colors. See the `palette` argument in `?tinyplot`.
#' * `ribbon.alpha`: Numeric factor in the range `[0,1]` for modifying the opacity alpha of "ribbon" and "area" type plots. Default value is `0.2`.
#'
#' @importFrom graphics par
#' @importFrom utils modifyList
#'
#' @seealso [`graphics::par`] which `tpar` builds on top of. [`get_saved_par`]
#' is a convenience function for retrieving graphical parameters at different
#' stages of a `tinyplot` call (and used for internal accounting purposes).
#' [`tinytheme`] allows users to easily set a group of graphics parameters
#' in a single function call, according to a variety of predefined themes.
#'
#' @examples
#' # Return a list of existing base and tinyplot graphic params
#' tpar("las", "pch", "facet.bg", "facet.cex", "grid")
#'
#' # Simple facet plot with these default values
#' tinyplot(mpg ~ wt, data = mtcars, facet = ~am)
#'
#' # Set params to something new. Similar to graphics::par(), note that we save
#' # the existing values at the same time by assigning to an object.
#' op = tpar(
#'   las       = 1,
#'   pch       = 2,
#'   facet.bg  = "grey90",
#'   facet.cex = 2,
#'   grid      = TRUE
#' )
#'
#' # Re-plot with these new params
#' tinyplot(mpg ~ wt, data = mtcars, facet = ~am)
#'
#' # Reset back to original values
#' tpar(op)
#'
#' # Important: tpar() only evalutes parameters that have been passed explicitly
#' #   by the user. So it it should not be used to query and set (restore)
#' #   parameters that weren't explicitly requested, i.e. tpar() != par().
#'
#' # Note: The tinyplot-specific parameters can also be be set via `options`
#' #   with a `tinyplot_*` prefix, which can be convenient for enabling
#' #   different default behaviour at startup time (e.g., via an .Rprofile
#' #   file). Example:
#' # options(tinyplot_grid = TRUE, tinyplot_facet.bg = "grey90")
#'
#' @export
tpar = function(..., hook = FALSE) {

  opts = list(...)
  if (length(opts) == 1 && is.null(names(opts))) {
    if (inherits(opts[[1]], "list") && !is.null(names(opts[[1]]))) {
      opts = opts[[1]]
    }
  }

  ###### Assign parameters

  # assign tinyplot-specific arguments with known names to .tpar
  assign_tpar(opts)

  # return informative error messages if the input is invalid
  assert_tpar(.tpar)

  # if tpar(...) includes arguments that are not known to be tinyplot-specific,
  # we set a hook to set them using par() when the graphic device is started
  nam = names(opts)
  if (!is.null(nam)) {
    base_par = setdiff(nam, known_tpar)
    base_par = opts[base_par]
    if (length(base_par) > 0) {
      if (isTRUE(hook)) {
        # append new hook to existing ones
        new_hooks = list("before.plot.new" = function() par(base_par))
        set_hooks(new_hooks, action = "append")
        # save new hook to tinyplot environment for later removal
        old_hooks = get_environment_variable(".tpar_hooks")
        set_environment_variable(".tpar_hooks", c(old_hooks, new_hooks))
      } else {
        par_names = names(par(no.readonly = TRUE))
        base_par = base_par[names(base_par) %in% par_names]
        base_par_old = par(base_par)
        par(base_par)
      }
    }
  }

  ###### Retrieve parameters

  # User didn't assign any new values, but may have requested explicit (print
  # of) some existing value(s)
  tpar_old = as.list(.tpar)
  if (is.null(nam)) {
    known_par = names(par(no.readonly = TRUE))
    if (!is.null(nam)) {
      used_par = intersect(nam, known_par)
    } else {
      used_par = intersect(opts, known_par)
    }
    if (length(used_par)) {
      if (!is.null(nam)) used_par = opts[used_par]
      used_par_old = par(used_par)
      tpar_old = modifyList(as.list(.tpar), used_par_old, keep.null = TRUE)
    }
    if (!is.null(opts) && length(opts) != 0) {
      # specific values requested
      opts = Filter(is.character, opts)
      ret = (`names<-`(lapply(opts, function(x) .tpar[[x]]), opts))
      if (length(used_par)) {
        ret_par = par(used_par)
        ret = modifyList(ret, ret_par, keep.null = TRUE)
      }
      if (length(ret) == 1) ret = ret[[1]]
      return(ret)
    } else {
      # no specific request; return all existing values invisibly
      return(invisible(tpar_old))
    }
    # assign new values, but still return old values for saving existing settings
    # a la `oldpar = par(param = new_value)`
  } else {
    `names<-`(lapply(nam, function(x) .tpar[[x]]), nam)
    if (length(base_par) > 0 && isFALSE(hook)) tpar_old = modifyList(tpar_old, base_par_old, keep.null = TRUE)
    return(invisible(tpar_old))
  }
}

# Two levels of priority: .tpar[["name"]] -> par("name")
get_tpar = function(opts, default = NULL) {
  # parameter priority
  # .tpar[["name"]] -> par("name")
  for (o in opts) {
    tp = .tpar[[o]]
    if (!is.null(tp)) {
      return(tp)
    } else {
      p = suppressWarnings(par(o))
      if (!is.null(p)) {
        return(p)
      }
    }

  }
  return(default)
}

known_tpar = c(
    "adj.main",
    "adj.sub",
    "adj.xlab",
    "adj.ylab",
    "cex.xlab",
    "cex.ylab",
    "col.xaxs",
    "col.yaxs",
    "cairo",
    "dynmar",
    "facet.bg",
    "facet.border",
    "facet.cex",
    "facet.col",
    "facet.font",
    "file.height",
    "file.res",
    "file.width",
    "fmar",
    "grid",
    "grid.bg",
    "grid.col",
    "grid.lty",
    "grid.lwd",
    "lmar",
    "lty.xaxs",
    "lty.yaxs",
    "lwd.xaxs",
    "lwd.yaxs",
    "lwd.axis",
    "pch",
    "palette.qualitative",
    "palette.sequential",
    "ribbon.alpha",
    "side.sub",
    "tinytheme",
    "xaxt",
    "yaxt"
)

assign_tpar = function(opts) {
  for (n in intersect(names(opts), known_tpar)) {
    .tpar[[n]] = opts[[n]]
  }
}

assert_tpar = function(.tpar) {
  assert_numeric(.tpar[["adj.main"]], len = 1, lower = 0, upper = 1, null.ok = TRUE, name = "adj.main")
  assert_numeric(.tpar[["adj.sub"]], len = 1, lower = 0, upper = 1, null.ok = TRUE, name = "adj.sub")
  assert_numeric(.tpar[["adj.xlab"]], len = 1, lower = 0, upper = 1, null.ok = TRUE, name = "adj.xlab")
  assert_numeric(.tpar[["adj.ylab"]], len = 1, lower = 0, upper = 1, null.ok = TRUE, name = "adj.ylab")
  assert_flag(.tpar[["cairo"]], name = "cairo")
  assert_flag(.tpar[["dynmar"]], null.ok = FALSE, name = "dynmar")
  assert_numeric(.tpar[["lmar"]], len = 2, null.ok = TRUE, name = "lmar")
  assert_numeric(.tpar[["ribbon.alpha"]], len = 1, lower = 0, upper = 1, null.ok = TRUE, name = "ribbon.alpha")
  assert_numeric(.tpar[["grid.lwd"]], len = 1, lower = 0, null.ok = TRUE, name = "grid.lwd")
  assert_flag(.tpar[["grid"]], null.ok = TRUE, name = "grid")
  assert_numeric(.tpar[["file.res"]], len = 1, lower = 0, null.ok = TRUE, name = "file.res")
  assert_numeric(.tpar[["file.height"]], len = 1, lower = 0, null.ok = TRUE, name = "file.height")
  assert_numeric(.tpar[["file.width"]], len = 1, lower = 0, null.ok = TRUE, name = "file.width")
  assert_numeric(.tpar[["facet.font"]], len = 1, null.ok = TRUE, name = "facet.font")
  assert_numeric(.tpar[["facet.cex"]], len = 1, null.ok = TRUE, name = "facet.cex")
  assert_numeric(.tpar[["side.sub"]], len = 1, null.ok = TRUE, name = "side.sub")
  assert_string(.tpar[["grid.bg"]], null.ok = TRUE, name = "grid.bg")
  assert_numeric(.tpar[["fmar"]], len = 4, null.ok = TRUE, name = "fmar")

  facet.col = .tpar[["facet.col"]]
  if (!is.null(facet.col)) {
    if (!is.null(facet.col) && !is.numeric(facet.col) && !is.character(facet.col)) {
      stop("facet.col needs to be NULL, or a numeric or character", call. = FALSE)
    }
    assert_true(length(facet.col) == 1, name = "length(facet.col)==1")
  }

  facet.bg = .tpar$facet.bg
  if (!is.null(facet.bg)) {
    if (!is.numeric(facet.bg) && !is.character(facet.bg)) {
      stop("facet.bg needs to be NULL, or a numeric or character", call. = FALSE)
    }
    assert_true(length(facet.bg) == 1, name = "length(facet.bg)==1")
  }

  facet.border = .tpar$facet.border
  if (!is.null(facet.border)) {
    if (!is.numeric(facet.border) && !is.character(facet.border) && !is.na(facet.border)) {
      stop("facet.border needs to be NULL, or a numeric, character, or NA", call. = FALSE)
    }
    assert_true(length(facet.border) == 1, name = "length(facet.border)==1")
  }
}

init_tpar = function(rm_hook = FALSE) {
  rm(list = names(.tpar), envir = .tpar)

  if (isTRUE(rm_hook)) {
    old_hooks = get_environment_variable(".tpar_hooks")
    if (length(old_hooks) > 0) {
      remove_hooks(old_hooks)
      set_environment_variable(".tpar_hooks", NULL)
    }
  }

  .tpar$cairo = if (is.null(getOption("tinyplot_cairo"))) capabilities("cairo") else as.logical(getOption("tinyplot_cairo"))

  .tpar$dynmar = if (is.null(getOption("tinyplot_dynmar"))) FALSE else as.logical(getOption("tinyplot_dynmar"))

  # Figure output options if written to file
  .tpar$file.width = if (is.null(getOption("tinyplot_file.width"))) 7 else as.numeric(getOption("tinyplot_file.width"))
  .tpar$file.height = if (is.null(getOption("tinyplot_file.height"))) 7 else as.numeric(getOption("tinyplot_file.height"))
  .tpar$file.res = if (is.null(getOption("tinyplot_file.res"))) 300 else as.numeric(getOption("tinyplot_file.res"))

  # Facet margin, i.e. gap between the individual facet windows
  .tpar$fmar = if (is.null(getOption("tinyplot_fmar"))) c(1, 1, 1, 1) else as.numeric(getOption("tinyplot_fmar"))

  # Other facet options
  .tpar$facet.cex = if (is.null(getOption("tinyplot_facet.cex"))) 1 else as.numeric(getOption("tinyplot_facet.cex"))
  .tpar$facet.font = if (is.null(getOption("tinyplot_facet.font"))) NULL else as.numeric(getOption("tinyplot_facet.font"))
  .tpar$facet.col = if (is.null(getOption("tinyplot_facet.col"))) NULL else getOption("tinyplot_facet.col")
  .tpar$facet.bg = if (is.null(getOption("tinyplot_facet.bg"))) NULL else getOption("tinyplot_facet.bg")
  .tpar$facet.border = if (is.null(getOption("tinyplot_facet.border"))) NA else getOption("tinyplot_facet.border")

  # Plot grid
  .tpar$grid = if (is.null(getOption("tinyplot_grid"))) FALSE else as.logical(getOption("tinyplot_grid"))
  .tpar$grid.col = if (is.null(getOption("tinyplot_grid.col"))) "lightgray" else getOption("tinyplot_grid.col")
  .tpar$grid.lty = if (is.null(getOption("tinyplot_grid.lty"))) "dotted" else getOption("tinyplot_grid.lty")
  .tpar$grid.lwd = if (is.null(getOption("tinyplot_grid.lwd"))) 1 else as.numeric(getOption("tinyplot_grid.lwd"))

  # Legend margin, i.e. gap between the legend and the plot elements
  .tpar$lmar = if (is.null(getOption("tinyplot_lmar"))) c(1.0, 0.1) else as.numeric(getOption("tinyplot_lmar"))

  # Alpha fill (transparency) default for ribbon and area plots
  .tpar$ribbon.alpha = if (is.null(getOption("tinyplot_ribbon.alpha"))) 0.2 else as.numeric(getOption("tinyplot_ribbon.alpha"))
}

#' Format labels
#'
#' @description Function for formatting label appearance, e.g. axis
#' ticks labels. This is what the top-level `xaxl` and `yaxl` arguments
#' from [`tinyplot`] ultimately get passed to.
#' @param x a numeric or character vector
#' @param labeller a formatting function to be applied to `x`, e.g. [`format`],
#'   [`toupper`], [`abs`], or other custom function (including from the popular
#'   **scales** package). Can also be one of the following convenience strings
#'   (symbols), for which common formatting transformations are provided:
#'   `"percent"` (`"%"`), `"comma"` (`","`), `"log"` (`"l"`), `"dollar"`
#'   (`"$"`), `"euro"` (`"€"`), or `"sterling"` (`"£"`).
#' @examples
#' x = 1e4
#' tinylabel(x, "comma")
#' tinylabel(x, ",") # same
#' tinylabel(x, "$") # or "dollar"
#'
#' # pass to xaxl/yaxl for adjusting axes tick labels in a tinyplot call
#' tinyplot(I(mpg/hp) ~ hp, data = mtcars, yaxl = "%")
#'
#' # log example (combined with axis scaling)
#' tinyplot(x = 10^c(10:0), y = 0:10, type = "b", log = "x", xaxl = "log")
#'
#' # combine with `x/yaxb` to adjust the actual tick marks ("break points")
#' # at the same time
#' tinyplot(x = 10^c(10:0), y = 0:10, type = "b", log = "x", xaxl = "log",
#'          xaxb = 10^c(1,3,5,7,9))
#'
#' #
#' ## custom function examples
#'
#' ## example I: date formatting
#'
#' dat = data.frame(
#'   date = seq(as.Date("2000/1/1"), by = "month", length.out = 12),
#'   trend = 1:12 + rnorm(12, sd = 1)
#' )
#'
#' tinyplot(trend ~ date, data = dat, xaxl = function(x) format(x, "%b, %Y"))
#'
#' ## example II: string wrapping
#'
#' # create a "vectorised" version of `base::strwrap` that breaks long
#' # strings into new lines every 18 characters
#' strwrap18 = function(x) sapply(
#'   strwrap(x, width = 18, simplify = FALSE),
#'   paste,
#'   collapse = "\n"
#' )
#'
#' # now demonstrate on a dataset with long y-tick labels
#' dat2 = data.frame(
#'   x = rep(rnorm(100), 3),
#'   y = c(
#'     "tinyplot is a lightweight extension of the base R graphics system.",
#'     "R is a language for statistical computing.",
#'     "Data visualization is an essential skill."
#'   )
#' )
#'
#' tinytheme("bw")
#' tinyplot(y ~ x, data = dat2, type = "j", yaxl = strwrap18)
#' tinytheme()
#' @export
tinylabel = function(x, labeller = NULL) {
  if (is.null(labeller)) return(x)
  if (is.character(labeller)) labeller = labeller_fun((labeller))
  return(labeller(x))
}

labeller_fun = function(label = "percent") {

  labels = c(
    "%"       = "percent",
    ","       = "comma",
    "$"       = "dollar",
    "\u20ac"  = "euro",
    "\u00a3"  = "sterling",
    "l"       = "log"
  )
  if (label %in% names(labels)) label = labels[label]

  ## all labels plus absolute value version
  # labels = c("percent", "comma", "dollar", "euro", "sterling")
  labels = c(labels, paste0("abs_", labels))

  ## match full label first, then store abs_ info separately
  label = match.arg(label, labels)
  abs_ = substr(label, 1L, 4L) == "abs_"
  if (abs_) label = substr(label, 5L, nchar(label))

  ## actual formatting function
  format_percent = function(x) {
    sprintf("%.0f%%", x * 100)
  }

  format_comma = function(x) {
    prettyNum(x, big.mark = ",", scientific = FALSE)
  }

  format_dollar = function(x) {
    paste0("$", prettyNum(x, big.mark = ",", scientific = FALSE))
  }

  format_euro = function(x) {
    paste0("\u20ac", prettyNum(x, big.mark = ",", scientific = FALSE))
  }

  format_sterling = function(x) {
    paste0("\u00a3", prettyNum(x, big.mark = ",", scientific = FALSE))
  }

  format_log = function(x) {
    parse(text = paste0(10, "^", format(log10(x), digits = 3)))
  }

  fun = switch(
    label,
    percent  = format_percent,
    comma    = format_comma,
    dollar   = format_dollar,
    euro     = format_euro,
    sterling = format_sterling,
    log      = format_log
  )

  ## combine with absolute value if necessary
  if (abs_) function(x) fun(abs(x)) else fun
}

#' Spineplot and spinogram types
#'
#' @description Type function(s) for producing spineplots and spinograms, which
#'   are modified versions of histograms or mosaic plots, and particularly
#'   useful for visualizing factor variables. Note that [`tinyplot`] defaults
#'   to `type_spineplot()` if `y` is a factor variable.
#' @param xlevels,ylevels a character or numeric vector specifying the ordering of the
#'   levels of the `x` and `y` variables (if character) or the corresponding indexes
#'   (if numeric) for the plot.
#' @inheritParams graphics::spineplot
#' @examples
#' # "spineplot" type convenience string
#' tinyplot(Species ~ Sepal.Width, data = iris, type = "spineplot")
#'
#' # Aside: specifying the type is redundant for this example, since tinyplot()
#' # defaults to "spineplot" if y is a factor (just like base plot).
#' tinyplot(Species ~ Sepal.Width, data = iris)
#'
#' # Use `type_spineplot()` to pass extra arguments for customization
#' tinyplot(Species ~ Sepal.Width, data = iris, type = type_spineplot(breaks = 4))
#'
#' p = palette.colors(3, "Pastel 1")
#' tinyplot(Species ~ Sepal.Width, data = iris, type = type_spineplot(breaks = 4, col = p))
#' rm(p)
#'
#' # More idiomatic tinyplot way of drawing the previous plot: use y == by
#' tinyplot(
#'   Species ~ Sepal.Width | Species, data = iris, type = type_spineplot(breaks = 4),
#'   palette = "Pastel 1", legend = FALSE
#' )
#'
#' # Grouped and faceted spineplots
#'
#' ttnc = as.data.frame(Titanic)
#'
#' tinyplot(
#'   Survived ~ Sex, facet = ~ Class, data = ttnc,
#'   type = type_spineplot(weights = ttnc$Freq)
#' )
#'
#' # For grouped "by" spineplots, it's better visually to facet as well
#' tinyplot(
#'   Survived ~ Sex | Class, facet = "by", data = ttnc,
#'   type = type_spineplot(weights = ttnc$Freq)
#' )
#'
#' # Fancier version. Note the smart inheritance of spacing etc.
#' tinyplot(
#'   Survived ~ Sex | Class, facet = "by", data = ttnc,
#'   type = type_spineplot(weights = ttnc$Freq),
#'   palette = "Dark 2", facet.args = list(nrow = 1), axes = "t"
#' )
#'
#' # Reorder x and y variable categories either by their character levels or numeric indexes
#' tinyplot(
#'   Survived ~ Sex, facet = ~ Class, data = ttnc,
#'   type = type_spineplot(weights = ttnc$Freq, xlevels = c("Female", "Male"), ylevels = 2:1)
#' )
#'
#' # Note: It's possible to use "by" on its own (without faceting), but the
#' # overlaid result isn't great. We will likely overhaul this behaviour in a
#' # future version of tinyplot...
#' tinyplot(Survived ~ Sex | Class, data = ttnc,
#'   type = type_spineplot(weights = ttnc$Freq), alpha = 0.3
#' )
#'
#' @export
type_spineplot = function(breaks = NULL, tol.ylab = 0.05, off = NULL, xlevels = NULL, ylevels = NULL, col = NULL, xaxlabels = NULL, yaxlabels = NULL, weights = NULL) {
  col = col
  out = list(
    data = data_spineplot(off = off, breaks = breaks, xlevels = xlevels, ylevels = ylevels, xaxlabels = xaxlabels, yaxlabels = yaxlabels, weights = weights),
    draw = draw_spineplot(tol.ylab = tol.ylab, off = off, col = col, xaxlabels = xaxlabels, yaxlabels = yaxlabels),
    name = "spineplot"
  )
  class(out) = "tinyplot_type"
  return(out)
}

#' @importFrom grDevices nclass.Sturges
data_spineplot = function(off = NULL, breaks = NULL, xlevels = xlevels, ylevels = ylevels, xaxlabels = NULL, yaxlabels = NULL, weights = NULL) {
    fun = function(
      datapoints,
      by = NULL, col = NULL, bg = NULL, palette = NULL,
      facet = NULL, facet.args = NULL,
      xlim = NULL, ylim = NULL,
      axes = TRUE, xaxt = NULL, yaxt = NULL, xaxb = NULL, yaxb = NULL,
      null_by, null_facet,
      ...
    ) {

        ## process weights
        if (!is.null(weights)) {
            ny = length(datapoints$y)
            if (length(weights) != ny && length(weights) != 1L) {
                stop(sprintf("'weights' must have either length 1 or %s", ny))
            }
        }
        datapoints$weights = weights

        ## process x variable
        if (is.factor(datapoints$x)) {
            breaks = NULL
            off = if(is.null(off)) 0.02 else off/100
            if (is.null(xlim)) xlim = c(0, 1 + (nlevels(datapoints$x) - 1L) * off)
        } else {
            off = 0
            if (is.null(xlim)) xlim = c(0, 1)
    	      x = as.numeric(datapoints$x)
            if (is.null(breaks)) {
              breaks = if (!is.null(xaxb)) xaxb else if (is.null(weights)) nclass.Sturges(x) else ceiling(log2(sum(weights)) + 1)
	    }
            breaks = as.numeric(breaks)
            if (length(breaks) == 1L) {
                if (!is.numeric(breaks) || !is.finite(breaks) || breaks < 1L) stop("invalid number of 'breaks'")
                if (breaks > 1e6) {
                    warning(gettextf("'breaks = %g' is too large and set to 1e6", breaks))
                    breaks = 1000000L
                }
                rg = if (is.null(weights)) range(x, na.rm = TRUE) else range(x[weights > 0], na.rm = TRUE)
                breaks = pretty(rg, n = breaks, min.n = 1L)
            }
        }

        ## process y variable
        if (!is.factor(datapoints$y)) datapoints$y = factor(datapoints$y)
        if (is.null(ylim)) ylim = c(0, 1)

        ## adjust facet margins
        if (!is.null(facet) && is.null(facet.args[["fmar"]])) {
          facet.args[["fmar"]] = c(2, 2, 2, 2)
        }

        x_by = identical(datapoints$x, datapoints$by)
        y_by = identical(datapoints$y, datapoints$by)

        x.categorical = is.factor(datapoints$x)
        if (!is.null(xlevels) && x.categorical) {
          xlevels = if(is.numeric(xlevels)) levels(datapoints$x)[xlevels] else xlevels
          if (any(is.na(xlevels)) || !all(xlevels %in% levels(datapoints$x))) warning("not all 'xlevels' correspond to levels of 'x'")
          datapoints$x = factor(datapoints$x, levels = xlevels)
          if (x_by) datapoints$by = datapoints$x
        }
        if (!is.null(ylevels)) {
          ylevels = if(is.numeric(ylevels)) levels(datapoints$y)[ylevels] else ylevels
          if (any(is.na(ylevels)) || !all(ylevels %in% levels(datapoints$y))) warning("not all 'ylevels' correspond to levels of 'y'")
          datapoints$y = factor(datapoints$y, levels = ylevels)
          if (y_by) datapoints$by = datapoints$y
        }

        x = datapoints$x
        y = datapoints$y

        # if either x_by or y_by are TRUE, we'll only split by facets and then
        # use some simple logic to assign colouring on the backend
        if (isTRUE(x_by) || isTRUE(y_by)) {
          datapoints = split(datapoints, list(datapoints$facet))
          datapoints = Filter(function(k) nrow(k) > 0, datapoints)
        } else {
          datapoints = split(datapoints, list(datapoints$by, datapoints$facet))
          datapoints = Filter(function(k) nrow(k) > 0, datapoints)
        }

        # construct spineplot rectangles and breaks points for each by-facet combo
        datapoints = Map(function(dat, x.categorical, off) {
          ## set up frequency table
          x = dat$x
          if(!x.categorical) {
            x = cut(as.numeric(x), breaks = breaks, include.lowest = TRUE)
          }
          ## TODO: process by grouping via: interaction + spacing + labeling
          ## (for now just do interaction)
          ## FIXME: data_facet only contains the first by group?
          ## if (any(dat$by != "")) x = interaction(dat$by, x)
          if(is.null(dat$weights)) {
            tab = table(x, dat$y)
          } else {
            tab = as.table(tapply(dat$weights, list(x, dat$y), FUN = sum, na.rm = TRUE))
            tab[is.na(tab)] = 0
          }
          nx = nrow(tab)
          ny = ncol(tab)

          ## compute coordinates
          ## cumulative proportions of x (plus off) vs. conditional cumulative proportions of y
          yat = rbind(0, apply(proportions(tab[, ny:1L, drop = FALSE], 1L), 1L, cumsum))
          yat[is.na(yat)] = 1
          xat = c(0, cumsum(proportions(marginSums(tab, 1L)) + off))

          ybottom = as.vector(yat[-(ny + 1L),])
          ytop = as.vector(yat[-1L,])
          xleft = rep(xat[1L:nx], rep(ny, nx))
          xright = rep(xat[2L:(nx+1L)] - off, rep(ny, nx))

          out = data.frame(
            by = dat$by[1], # already split
            facet = dat$facet[1], # already split
            ymin = ybottom,
            ymax = ytop,
            xmin = xleft,
            xmax = xright
          )

          attr(out, "nx") = nx
          attr(out, "ny") = ny
          attr(out, "xat") = xat
          attr(out, "yat") = yat
          return(out)
        },
        dat = datapoints,
        x.categorical = x.categorical,
        off = off
        )

        nx = attr(datapoints[[1]], "nx") ## should be the same for all by/facet groups
        ny = attr(datapoints[[1]], "ny") ## ditto
        xat = lapply(datapoints, attr, "xat")
        yat = lapply(datapoints, attr, "yat")
        datapoints = do.call(rbind, datapoints)

        if (is.null(yaxlabels)) yaxlabels = rev(levels(y))

        ## axis labels
        yaxlabels = if(is.null(yaxlabels)) levels(y) else rep_len(yaxlabels, ny)
        if (!is.null(yaxb)) {
          # yaxlabels = yaxlabels[yaxlabels %in% yaxb]
          ## rather use the "" assignment workaround below, since otherwise we
          ## get a mismatch between the label names and ticks
          yaxlabels[!(yaxlabels %in% yaxb)] = ""
        }
        if(x.categorical) {
          xaxlabels = if(is.null(xaxlabels)) {
            levels(x)
          } else {
            rep_len(xaxlabels, nx)
          }
        } else {
          xaxlabels = if(is.null(xaxlabels)) {
            if(is.numeric(x)) breaks else c(x[1L], x[c(diff(as.numeric(x)) > 0, TRUE)])
          } else {
            rep_len(xaxlabels, nx + 1L)
          }
        }

        # catch for x_by / y/by
        if (isTRUE(x_by)) datapoints$by = factor(rep(xaxlabels, each = ny)) # each x label extends over ny rows
        if (isTRUE(y_by)) datapoints$by = factor(rep(yaxlabels, length.out = nrow(datapoints)))

        ## grayscale flag
        grayscale = null_by && is.null(palette) && is.null(.tpar[["palette.qualitative"]])

        out = list(
          x = c(datapoints$xmin, datapoints$xmax),
          y = c(datapoints$ymin, datapoints$ymax),
          ymin = datapoints$ymin,
          ymax = datapoints$ymax,
          xmin = datapoints$xmin,
          xmax = datapoints$xmax,
          col = col,
          bg = bg,
          datapoints = datapoints,
          by = if (null_by) by else datapoints$by,
          facet = if (null_facet) facet else datapoints$facet,
          axes = FALSE,
          frame.plot = FALSE,
          xaxt = "n",
          yaxt = "n",
          xaxs = "i",
          yaxs = "i",
          ylabs = yaxlabels,
          type_info = list(
            off = off,
            x.categorical = x.categorical,
            nx = nx,
            ny = ny,
            xat = xat,
            yat = yat,
            xaxlabels = xaxlabels,
            yaxlabels = yaxlabels,
            breaks = breaks,
            axes = axes,
            xaxt = xaxt,
            yaxt = yaxt,
            grayscale = grayscale,
            x_by = x_by,
            y_by = y_by
          ),
          facet.args = facet.args
        )

        return(out)

    }
    return(fun)
}

#' @importFrom grDevices gray.colors
draw_spineplot = function(tol.ylab = 0.05, off = NULL, col = NULL, xaxlabels = NULL, yaxlabels = NULL) {
    fun = function(ixmin, iymin, ixmax, iymax, ilty, ilwd, icol, ibg,
                   flip,
                   facet_window_args,
                   type_info,
                   ifacet,
                   ...) {

      if (is.null(off)) off = type_info[["off"]]
      if (is.null(xaxlabels)) xaxlabels = type_info[["xaxlabels"]]
      if (is.null(yaxlabels)) yaxlabels = type_info[["yaxlabels"]]
      xat = type_info[["xat"]][[ifacet]]
      yat = type_info[["yat"]][[ifacet]]
      nx = type_info[["nx"]]
      ny = type_info[["ny"]]
      x.categorical = type_info[["x.categorical"]]
      grayscale = type_info[["grayscale"]]
      x_by = type_info[["x_by"]]
      y_by = type_info[["y_by"]]

      ## graphical parameters
      if (is.null(col)) {
        if (is.null(ibg)) ibg = icol
        if (isFALSE(y_by)) {
          ibg = if (isTRUE(grayscale)) gray.colors(ny) else seq_palette(ibg, ny)
        }
        ibg = rep_len(ibg, ny)
      } else {
        ibg = col
      }

      if (type_info[["xaxt"]] %in% c("l", "t", "n") &&
          type_info[["yaxt"]] %in% c("l", "t", "n") &&
          !all(c(type_info[["xaxt"]], type_info[["yaxt"]]) == "n")) ilwd = 0

      rect(
          xleft = ixmin, ybottom = iymin, xright = ixmax, ytop = iymax,
          lty = ilty,
          lwd = ilwd,
          border = par("fg"), #icol,
          col = ibg
      )

      ## axes
      ## - standard categorical axes (xaxt/yaxt == "s") _without_ ticks
      ## - never draw additional axis lines, box always for spinogram
      if(type_info[["axes"]]) {
          if (x.categorical) {
              spine_axis(if (flip) 2 else 1, at = (xat[1L:nx] + xat[2L:(nx+1L)] - off)/2, labels = xaxlabels,
                  type = type_info[["xaxt"]], categorical = TRUE)
          } else {
              spine_axis(if (flip) 2 else 1, at = xat, labels = xaxlabels,
                  type = type_info[["xaxt"]], categorical = FALSE)
          }
          yat = yat[, if(flip) ncol(yat) else 1L]
          equidist = any(diff(yat) < tol.ylab)
          yat = if(equidist) seq.int(1/(2*ny), 1-1/(2*ny), by = 1/ny) else (yat[-1L] + yat[-length(yat)])/2
          spine_axis(if (flip) 3 else 2, at = yat, labels = yaxlabels,
              type = type_info[["yaxt"]], categorical = TRUE)
          if (is_facet_position(if(flip) "bottom" else "right", ifacet, facet_window_args)) spine_axis(if (flip) 1 else 4,
              type = type_info[["yaxt"]], categorical = FALSE)
      }
      if(!x.categorical && (is.null(ilwd) || ilwd > 0)) box()

    }
    return(fun)
}

spine_axis = function(side, ..., type = "standard", categorical = TRUE) {
    type = match.arg(type, c("standard", "none", "labels", "ticks", "axis"))
    ## standard: with axis, ticks (unless categorical), and labels
    ## none: no axes
    ## labels: only labels without ticks and axis line
    ## ticks: only ticks and labels without axis line
    ## axis: only axis line and labels but no ticks

    if (type == "none") {
        invisible(numeric(0L))
    } else {
        args = list(side = side, ...)
        if (type == "labels") {
            args$tick = FALSE
        } else if (type == "ticks") {
            args$lwd = 0
            if (!("lwd.ticks" %in% names(args))) args$lwd.ticks = if (categorical) 0 else 1
        } else if (type == "axis") {
            if (categorical) {
                args$tick = FALSE
            } else {
                args$lwd.ticks = 0
            }
        } else {
            args$tick = !categorical
        }
        do.call("axis", args)
    }
}

#' @importFrom grDevices col2rgb convertColor hcl
to_hcl = function(x) {
    x = t(col2rgb(x, alpha = TRUE)/255)
    alpha = x[, 4]
    x = x[, 1:3]
    x = convertColor(x, from = "sRGB", to = "Luv")
    x = cbind(H = atan2(x[, 3L], x[, 2L]) * 180/pi, C = sqrt(x[, 2L]^2 + x[, 3L]^2), L = x[, 1L])
    x[is.na(x[, 1L]), 1L] = 0
    x[x[, 1L] < 0, 1L] = x[x[, 1L] < 0, 1L] + 360
    attr(x, "alpha") = alpha
    return(x)
}

seq_palette = function(x, n, power = 1.5) {
    x = drop(to_hcl(x[1L]))
    alpha = attr(x, "alpha")
    hcl(
      h = x[1L],
      c = seq.int(from = x[2L]^(1/power), to = 0, length.out = n + 1)[1L:n]^power,
      l = 100 - seq.int(from = (100 - x[3L])^(1/power), to = pmin(8, (100 - x[3L])/2)^(1/power), length.out = n)^power,
      alpha = alpha
    )[1L:n]
}

#' Add a rug to a plot
#'
#' @description
#' Adds a rug representation (1-d plot) of the data to the plot.
#'
#' @details
#' This function should only be used as part of [`tinyplot_add()`], i.e. adding
#' to an existing plot.
#'
#' In most cases, determining which variable receives the rug representation
#' will be based on the `side` argument (i.e., x-variable if side is 1 or 3, and
#' y-variable if side is 2 or 4). An exception is if the preceding plot type was
#' either `"density"` or `"histogram"`; for these latter cases, the x-variable
#' will always be used. See Examples.
#'
#' @inheritParams graphics::rug
#' @param jitter Logical. Add jittering to separate ties? Default is `FALSE`.
#' @param amount Numeric. Amount of jittering (see \code{\link[base]{jitter}}).
#'   Only used if `jitter` is `TRUE`.
#' @examples
#' tinyplot(~wt | am, data = mtcars, type = "density", facet = "by", fill = "by")
#' tinyplot_add(type = "rug")
#' # use type_rug() to pass extra options
#' tinyplot_add(type = type_rug(side = 3, ticksize = 0.05))
#'
#' # For ties, use jittering
#' tinyplot(eruptions ~ waiting, data = faithful, type = "lm")
#' tinyplot_add(type = type_rug(jitter = TRUE, amount = 0.3))
#' tinyplot_add(type = type_rug(jitter = TRUE, amount = 0.1, side = 2))
#' # Add original points just for reference
#' tinyplot_add(type = "p")
#'
#' @importFrom graphics rug
#' @export
type_rug = function(ticksize = 0.03, side = 1, quiet = getOption("warn") < 0, jitter = FALSE, amount = NULL) {
  data_rug = function(datapoints, ...) {
    if (nrow(datapoints) == 0) {
      msg = "`type_rug() only works on existing plots with x and y data points."
      stop(msg, call. = FALSE)
    }
    return(datapoints)
  }
  draw_rug = function(.ticksize = ticksize, .side = side, .quiet = quiet, .jitter = jitter, .amount = amount) {
      fun = function(ix, iy, icol, ilwd, ...) {
        lc = getOption("tinyplot_last_call", default = NULL)
        swapy = !is.null(lc$type) && lc$type %in% c("density", "hist", "histogram")
        rugx = if (swapy) iy else if (side %in% c(1, 3)) ix else iy
        if (isTRUE(jitter)) rugx = jitter(rugx, amount = .amount)
        rug(
          x = rugx,
          col = icol,
          lwd = ilwd,
          ticksize = .ticksize,
          side = .side,
          quiet = .quiet
        )
      }
      return(fun)
  }

  out = list(
    draw = draw_rug(),
    data = data_rug,
    name = "rug"
  )
  class(out) = "tinyplot_type"
  return(out)
}

#' Violin plot type
#'
#' @md
#' @description Type function for violin plots, which are an alternative to box
#'   plots for visualizing continuous distributions (by group) in the form of
#'   mirrored densities.
#' @inheritParams type_density
#' @param  trim logical indicating whether the violins should be trimmed to the
#'   range of the data. Default is `FALSE`.
#' @param width numeric (ideally in the range `[0, 1]`, although this isn't
#'   enforced) giving the normalized width of the individual violins.
#' @inherit stats::density details
#' @details See [`type_density`] for more details and considerations related to
#'   bandwidth selection and kernel types.
#'
#' @examples
#' # "violin" type convenience string
#' tinyplot(count ~ spray, data = InsectSprays, type = "violin")
#'
#' # aside: to match the defaults of `ggplot2::geom_violin()`, use `trim = TRUE`
#' # and `joint.bw = FALSE`
#' tinyplot(count ~ spray, data = InsectSprays, type = "violin",
#'     trim = TRUE, joint.bw = FALSE)
#'
#' # use flip = TRUE to reorient the axes
#' tinyplot(count ~ spray, data = InsectSprays, type = "violin", flip = TRUE)
#'
#' # for flipped plots with long group labels, it's better to use a theme for
#' # dynamic plot resizing
#' tinytheme("clean")
#' tinyplot(weight ~ feed, data = chickwts, type = "violin", flip = TRUE)
#'
#' # you can group by the x var to add colour (here with the original orientation)
#' tinyplot(weight ~ feed | feed, data = chickwts, type = "violin", legend = FALSE)
#'
#' # dodged grouped violin plot example (different dataset)
#' tinyplot(len ~ dose | supp, data = ToothGrowth, type = "violin", fill = 0.2)
#'
#' # note: above we relied on `...` argument passing alongside the "violin"
#' # type convenience string. But this won't work for `width`, since it will
#' # clash with the top-level `tinyplot(..., width = <width>)` arg. To ensure
#' # correct arg passing, it's safer to use the formal `type_violin()` option.
#' tinyplot(len ~ dose | supp, data = ToothGrowth, fill = 0.2,
#'     type = type_violin(width = 0.8))
#'
#' # reset theme
#' tinytheme()
#'
#' @importFrom stats density weighted.mean
#' @importFrom stats bw.SJ bw.bcv bw.nrd bw.nrd0 bw.ucv
#' @export
type_violin = function(
        bw = "nrd0",
        joint.bw =  c("mean", "full", "none"),
        adjust = 1,
        kernel = c("gaussian", "epanechnikov", "rectangular", "triangular", "biweight", "cosine", "optcosine"),
        n = 512,
        # more args from density here?
        trim = FALSE,
        width = 0.9
    ) {
    kernel = match.arg(kernel, c("gaussian", "epanechnikov", "rectangular", "triangular", "biweight", "cosine", "optcosine"))
    if (is.logical(joint.bw)) {
        joint.bw = ifelse(joint.bw, "mean", "none")
    }
    joint.bw = match.arg(joint.bw, c("mean", "full", "none"))
    out = list(
        data = data_violin(bw = bw, adjust = adjust, kernel = kernel, n = n,
                            joint.bw = joint.bw, trim = trim, width = width),
        # draw = NULL,
        # name = "polygon"
        draw = draw_polygon(density = NULL),
        name = "violin"
    )
    class(out) = "tinyplot_type"
    return(out)
}

data_violin = function(bw = "nrd0", adjust = 1, kernel = "gaussian", n = 512,
                        joint.bw = "none", trim = FALSE, width = 0.9) {
    fun = function(datapoints,  by, facet, ylab, col, bg, palette, log, null_by, null_facet, ...) {

        # Handle ordering based on by and facet variables
        ngrps = if (null_by) 1 else length(unique(datapoints$by))
        nfacets = if (null_facet) 1 else length(unique(datapoints$facet))

        #  catch for special cases
        x_by = y_by = facet_by = FALSE
        if (!null_by) {
            x_by = identical(datapoints$x, datapoints$by)
            y_by = identical(datapoints$y, datapoints$by)
            if (!null_facet) facet_by = identical(datapoints$facet, datapoints$by)
        }

        # FIXME (once we add support for gradient fill to draw_polygon)
        if (y_by) {
            warning("\n`y` == `by` is not currently supported for `type_violin`. We hope to support this in a future release, but for now `y` grouping will be turned off automatically.\n")
            by = NULL
            datapoints$by = ""
            ngrps = 1
            null_by = TRUE
        }

        # Convert x to factor if it's not already
        datapoints$x = as.factor(datapoints$x)
        if (x_by) datapoints$by = datapoints$x

        # Handle factor levels and maintain order
        xlvls = levels(datapoints$x)
        xlabs = seq_along(xlvls)
        names(xlabs) = xlvls
        # xlabs = levels(datapoints$x)
        datapoints$x = as.integer(datapoints$x)

        if (null_by && null_facet) {
            xord = order(datapoints$x)
        } else if (null_facet) {
            xord = order(datapoints$by, datapoints$x)
        } else if (null_by) {
            xord = order(datapoints$facet, datapoints$x)
        } else {
            xord = order(datapoints$by, datapoints$facet, datapoints$x)
        }

        if (length(unique(datapoints[["by"]])) == 1 && is.null(palette)) {
            if (is.null(col)) col = par("fg")
            if (is.null(bg)) bg = "lightgray"
        } else if (is.null(bg)) {
            bg = "by"
        }

        # Reorder x, y, ymin, and ymax based on the order determined
        datapoints = datapoints[xord,]

        datapoints = split(datapoints, list(datapoints$x, datapoints$by, datapoints$facet))
        datapoints = Filter(function(k) nrow(k) > 0, datapoints)

        if (joint.bw == "none" || is.numeric(bw)) {
            dens_bw = bw
        } else {
            if (joint.bw == "mean") {
                # Use weighted mean of subgroup bandwidths
                bws = sapply(datapoints, function(dat) bw_fun(kernel = bw, dat$y))
                ws = sapply(datapoints, nrow)
                dens_bw = weighted.mean(bws, ws)
            } else if (joint.bw == "full") {
                dens_bw = bw_fun(kernel = bw, unlist(sapply(datapoints, `[[`, "x")))
            }
        }

        datapoints = lapply(seq_along(datapoints), function(d) {
            dat = datapoints[[d]]
            if (trim) {
                yrng = range(dat$y)
                dens = density(dat$y, bw = dens_bw, kernel = kernel, n = n, from = yrng[1], to = yrng[2])
            } else {
                dens = density(dat$y, bw = dens_bw, kernel = kernel, n = n)
            }

            x = dens$y
            y = dens$x

            if (log %in% c("y", "xy")) {
                if (x[1] <= 0) {
                    warning("\nNon-positive density values have been trimmed as part of the logarthmic transformation.\n")
                    xidx = x > 0
                    x = x[xidx]
                    y = y[xidx]
                }
            }

            x = c(x, rev(-x))
            y = c(y, rev(y))

            xwidth = xwidth_orig = width
            # dodge groups (if any)
            if ((ngrps > 1)  && isFALSE(x_by) && isFALSE(facet_by)) {
                xwidth = xwidth_orig / ngrps - 0.01
                x = rescale_num(x, to = c(0, xwidth))
                x = x + as.numeric(sub("^([0-9]+)\\..*", "\\1", names(datapoints)[d])) - xwidth/2
                x = x + seq(-((xwidth_orig - xwidth) / 2), ((xwidth_orig - xwidth) / 2), length.out = ngrps)[dat$by[1]]
            } else if (nfacets > 1) {
                x = rescale_num(x, to = c(0, xwidth))
                x = x + as.numeric(sub("^([0-9]+)\\..*", "\\1", names(datapoints)[d])) - xwidth/2
            } else {
                x = rescale_num(x, to = c(0, xwidth))
                x = x + d - xwidth/2
            }

            x = c(x, NA)
            y = c(y, NA)

            out = data.frame(
                by = dat$by[1], # already split
                facet = dat$facet[1], # already split
                y = y,
                x = x
            )
            return(out)
        })
        datapoints = do.call(rbind, datapoints)
        datapoints = datapoints[1:(nrow(datapoints)-1), ]

        out = list(
            datapoints = datapoints,
            by = if (length(unique(datapoints$by)) == 1) by else datapoints$by,
            facet = if (length(unique(datapoints$facet)) == 1) facet else datapoints$facet,
            ylab = ylab,
            xlabs = xlabs,
            col = col,
            bg = bg
        )
        return(out)
    }
    return(fun)
}

#' Density plot type
#'
#' @md
#' @description Type function for density plots.
#' @inheritParams stats::density
#' @param kernel a character string giving the smoothing kernel to be used. This
#'   must partially match one of `"gaussian"`, `"rectangular"`, `"triangular"`,
#'   `"epanechnikov"`, `"biweight"`, `"cosine"` or `"optcosine"`, with default
#'   `"gaussian"`, and may be abbreviated to a unique prefix (single letter).
#'
#'   `"cosine"` is smoother than `"optcosine"`, which is the usual 'cosine'
#'   kernel in the literature and almost MSE-efficient. However, `"cosine"` is
#'   the version used by S.
#' @inheritParams type_ribbon
#' @param joint.bw character string indicating whether (and how) the smoothing
#'   bandwidth should be computed from the joint data distribution when there
#'   are multiple subgroups. The options are `"mean"` (the default), `"full"`,
#'   and `"none"`. Also accepts a logical argument, where `TRUE` maps to
#'   `"mean"` and `FALSE` maps to `"none"`. See the "Bandwidth selection"
#'   section below for a discussion of practical considerations.
#' @inherit stats::density details
#' @section Bandwidth selection: While the choice of smoothing bandwidth will
#'   always stand to affect a density visualization, it gains an added
#'   importance when multiple densities are drawn simultaneously (e.g., for
#'   subgroups with respect to `by` or `facet`). Allowing each subgroup to
#'   compute its own separate bandwidth independently offers greater flexibility
#'   in capturing the unique characteristics of each subgroup, particularly when
#'   distributions differ substantially in location and/or scale. However, this
#'   approach may overemphasize small random variations and make it harder to
#'   visually compare densities across subgroups. Hence, it is often useful to
#'   employ the same ("joint") bandwidth across all subgroups. The following
#'   strategies are available via the `joint.bw` argument:
#'
#'   - The default `joint.bw = "mean"` first computes the individual bandwidths
#'   for each group but then computes their mean, weighted by the number of
#'   observations in each group. This will work well when all groups have
#'   similar amounts of scatter (similar variances), even when they have
#'   potentially rather different locations. The weighted averaging stabilizes
#'   potential fluctuations in the individual bandwidths, especially when some
#'   subgroups are rather small.
#'
#'   - Alternatively, `joint.bw = "full"` can be used to compute the joint
#'   bandwidth from the full joint distribution (merging all groups). This will
#'   yield an even more robust bandwidth, especially when the groups overlap
#'   substantially (i.e., have similar locations and scales). However, it may
#'   lead to too large bandwidths and thus too much smoothing, especially when
#'   the locations of the groups differ substantially.
#'
#'   - Finally, `joint.bw = "none"` disables the joint bandwidth so that each
#'   group just employs its individual bandwidth. This is often the best choice
#'   if the amounts of scatter differ substantially between the groups, thus
#'   necessitating different amounts of smoothing.
#' @section Titles: This tinyplot method for density plots differs from the base
#'   \code{\link[stats]{plot.density}} function in its treatment of titles. The
#'   x-axis title displays only the variable name, omitting details about the
#'   number of observations and smoothing bandwidth. Additionally, the main
#'   title is left blank by default for a cleaner appearance.
#' @examples
#' # "density" type convenience string
#' tinyplot(~Sepal.Length, data = iris, type = "density")
#'
#' # grouped density example
#' tinyplot(~Sepal.Length | Species, data = iris, type = "density")
#'
#' # use `bg = "by"` (or, equivalent `fill = "by"`) to get filled densities
#' tinyplot(~Sepal.Length | Species, data = iris, type = "density", fill = "by")
#'
#' # use `type_density()` to pass extra arguments for customization
#' tinyplot(
#'   ~Sepal.Length | Species, data = iris,
#'   type = type_density(bw = "SJ"),
#'   main = "Bandwidth computed using Sheather & Jones (1991)"
#' )
#'
#' # The default for grouped density plots is to use the mean of the
#' # individual subgroup bandwidths (weighted by group size) as the
#' # joint bandwidth. Alternatively, the bandwidth from the "full"
#' # data or separate individual bandwidths ("none") can be used.
#' tinyplot(~Sepal.Length | Species, data = iris,
#'     ylim = c(0, 1.25), type = "density")        # mean (default)
#' tinyplot_add(joint.bw = "full", lty = 2)        # full data
#' tinyplot_add(joint.bw = "none", lty = 3)        # none (individual)
#' legend("topright", c("Mean", "Full", "None"), lty = 1:3, bty = "n", title = "Joint BW")
#'
#' @importFrom stats density weighted.mean
#' @importFrom stats bw.SJ bw.bcv bw.nrd bw.nrd0 bw.ucv
#' @export
type_density = function(
        bw = "nrd0",
        joint.bw =  c("mean", "full", "none"),
        adjust = 1,
        kernel = c("gaussian", "epanechnikov", "rectangular", "triangular", "biweight", "cosine", "optcosine"),
        n = 512,
        # more args from density here?
        alpha = NULL
    ) {
    kernel = match.arg(kernel, c("gaussian", "epanechnikov", "rectangular", "triangular", "biweight", "cosine", "optcosine"))
    if (is.logical(joint.bw)) {
        joint.bw = ifelse(joint.bw, "mean", "none")
    }
    joint.bw = match.arg(joint.bw, c("mean", "full", "none"))
    out = list(
        data = data_density(bw = bw, adjust = adjust, kernel = kernel, n = n,
                            joint.bw = joint.bw, alpha = alpha),
        draw = NULL,
        name = "density"
    )
    class(out) = "tinyplot_type"
    return(out)
}

data_density = function(bw = "nrd0", adjust = 1, kernel = "gaussian", n = 512,
                        joint.bw = "none", alpha = NULL) {
    fun = function(by, facet, ylab, col, bg, ribbon.alpha, datapoints,  ...) {

        ribbon.alpha = if (is.null(alpha)) .tpar[["ribbon.alpha"]] else (alpha)

        if (is.null(ylab)) ylab = "Density"

        datapoints = split(datapoints, list(datapoints$by, datapoints$facet))
        datapoints = Filter(function(k) nrow(k) > 0, datapoints)

        if (joint.bw == "none" || is.numeric(bw)) {
            dens_bw = bw
        } else {
            if (joint.bw == "mean") {
                # Use weighted mean of subgroup bandwidths
                bws = sapply(datapoints, function(dat) bw_fun(kernel = bw, dat$x))
                ws = sapply(datapoints, nrow)
                dens_bw = weighted.mean(bws, ws)
            } else if (joint.bw == "full") {
                dens_bw = bw_fun(kernel = bw, unlist(sapply(datapoints, `[[`, "x")))
            }
        }

        datapoints = lapply(datapoints, function(dat) {
            d = density(dat$x, bw = dens_bw, kernel = kernel, n = n)
            out = data.frame(
                by = dat$by[1], # already split
                facet = dat$facet[1], # already split
                y = d$y,
                x = d$x
            )
            return(out)
        })
        datapoints = do.call(rbind, datapoints)
        datapoints$ymax = datapoints$y
        datapoints$ymin = rep.int(0, nrow(datapoints))

        # flags for legend and fill
        dtype = if (!is.null(bg)) "ribbon" else "l"
        dwas_area_type = !is.null(bg)

        out = list(
            ylab = ylab,
            type = dtype,
            was_area_type = dwas_area_type,
            ribbon.alpha = ribbon.alpha,
            datapoints = datapoints,
            by = if (length(unique(datapoints$by)) == 1) by else datapoints$by,
            facet = if (length(unique(datapoints$facet)) == 1) facet else datapoints$facet
        )
        return(out)
    }
    return(fun)
}

#' Boxplot type
#'
#' @description Type function for producing box-and-whisker plots.
#' Arguments are passed to \code{\link[graphics]{boxplot}}, although `tinyplot`
#' scaffolding allows added functionality such as grouping and faceting.
#' Box-and-whisker plots are the default plot type if `x` is a factor and `y` is
#' numeric.
#'
#' @inheritParams graphics::boxplot
#' @examples
#' # "boxplot" type convenience string
#' tinyplot(count ~ spray, data = InsectSprays, type = "boxplot")
#'
#' # Note: Specifying the type here is redundant. Like base plot, tinyplot
#' # automatically produces a boxplot if x is a factor and y is numeric
#' tinyplot(count ~ spray, data = InsectSprays)
#'
#' # Grouped boxplot example
#' tinyplot(len ~ dose | supp, data = ToothGrowth, type = "boxplot")
#'
#' # Use `type_boxplot()` to pass extra arguments for customization
#' tinyplot(
#'   len ~ dose | supp, data = ToothGrowth, lty = 1,
#'   type = type_boxplot(boxwex = 0.3, staplewex = 0, outline = FALSE)
#' )
#' @export
type_boxplot = function(
    range = 1.5,
    width = NULL,
    varwidth = FALSE,
    notch = FALSE,
    outline = TRUE,
    boxwex = 0.8,
    staplewex = 0.5,
    outwex = 0.5) {
  out = list(
    draw = draw_boxplot(
      range = range,
      width = width,
      varwidth = varwidth,
      notch = notch,
      outline = outline,
      boxwex = boxwex,
      staplewex = staplewex,
      outwex = outwex),
    data = data_boxplot(),
    name = "boxplot"
  )
  class(out) = "tinyplot_type"
  return(out)
}

draw_boxplot = function(range, width, varwidth, notch, outline, boxwex, staplewex, outwex) {
    fun = function(iby, ix, iy, ipch, ilty, icol, ibg, x_by = FALSE, facet_by = FALSE, ngrps = 1, flip, ...) {

        at_ix = unique(ix)
        if (isTRUE(x_by)) boxwex = boxwex * 2

        # Handle multiple groups
        if (ngrps > 1 && isFALSE(x_by) && isFALSE(facet_by)) {
            boxwex_orig = boxwex
            boxwex = boxwex / ngrps - 0.01
            at_ix = at_ix + seq(
              -((boxwex_orig - boxwex) / 2),
              ((boxwex_orig - boxwex) / 2),
              length.out = ngrps
            )[iby]
        }

        boxplot(
            formula = iy ~ ix,
            pch = ipch,
            lty = ilty,
            border = icol,
            col = ibg,
            horizontal = flip,
            add = TRUE, axes = FALSE,
            at = at_ix,
            range = range,
            width = width,
            varwidth = varwidth,
            notch = notch,
            outline = outline,
            boxwex = boxwex,
            staplewex = staplewex,
            outwex = outwex
        )
    }
    return(fun)
}

data_boxplot = function() {
    fun = function(datapoints, bg, col, palette, null_by, null_facet, ...) {
        # Convert x to factor if it's not already
        datapoints$x = as.factor(datapoints$x)

        # Handle factor levels and maintain order
        xlvls = levels(datapoints$x)
        xlabs = seq_along(xlvls)
        names(xlabs) = xlvls
        datapoints$x = as.integer(datapoints$x)

        if (null_by && null_facet) {
            xord = order(datapoints$x)
        } else if (null_facet) {
            xord = order(datapoints$by, datapoints$x)
        } else if (null_by) {
            xord = order(datapoints$facet, datapoints$x)
        } else {
            xord = order(datapoints$by, datapoints$facet, datapoints$x)
        }

        if (length(unique(datapoints[["by"]])) == 1 && is.null(palette)) {
            if (is.null(col)) col = par("fg")
            if (is.null(bg)) bg = "lightgray"
        } else {
            bg = "by"
        }

        # Reorder x, y, ymin, and ymax based on the order determined
        datapoints = datapoints[xord,]

        # Return the result as a list called 'out'
        out = list(
            x = datapoints$x,
            y = datapoints$y,
            ymin = datapoints$ymin,
            ymax = datapoints$ymax,
            xlabs = xlabs,
            datapoints = datapoints,
            col = col,
            bg = bg)

        if (length(unique(datapoints$by)) > 1) out[["by"]] = datapoints$by
        if (length(unique(datapoints$facet)) > 1) out[["facet"]] = datapoints$facet

        return(out)
    }
    return(fun)
}

#' Histogram plot type
#'
#' @md
#' @description Type function for histogram plots. `type_hist` is an alias for
#'   `type_histogram`.
#' @param breaks Passed to \code{\link[graphics]{hist}}. One of:
#' - a vector giving the breakpoints between histogram cells,
#' - a function to compute the vector of breakpoints,
#' - a single number giving the number of cells for the histogram,
#' - a character string naming an algorithm to compute the number of cells (see ‘Details’ of \code{\link[graphics]{hist}}),
#' - a function to compute the number of cells.
#' In the last three cases the number is a suggestion only; as the breakpoints
#' will be set to pretty values, the number is limited to 1e6 (with a warning if
#' it was larger). If breaks is a function, the x vector is supplied to it as
#' the only argument (and the number of breaks is only limited by the amount of
#' available memory).
#' @param free.breaks Logical indicating whether the breakpoints should be
#'   computed separately for each group or facet? Default is `FALSE`, meaning
#'   that the breakpoints are computed from the full dataset; thus ensuring
#'   common bin widths across each group/facet. Can also use `free` as an
#'   acceptable argument alias. Ignored if there are no groups and/or facets.
#' @param drop.zeros Logical indicating whether bins with zero counts should be
#'   dropped before plotting. Default is `TRUE`. Note that switching to `FALSE`
#'   may interfere with faceted plot behaviour if `facet.args = list(free)`,
#'   since the `x` variable is effectively recorded over the full range of the
#'   x-axis (even if it does not extend over this range for every group).
#' @inheritParams graphics::hist
#' @examples
#' # "histogram"/"hist" type convenience string(s)
#' tinyplot(Nile, type = "histogram")
#'
#' # Use `type_histogram()` to pass extra arguments for customization
#' tinyplot(Nile, type = type_histogram(breaks = 30))
#' tinyplot(Nile, type = type_histogram(breaks = 30, freq = FALSE))
#' # etc.
#'
#' # Grouped histogram example
#' tinyplot(
#'     ~Petal.Width | Species,
#'     type = "histogram",
#'     data = iris
#' )
#'
#' # Faceted version
#' tinyplot(
#'     ~Petal.Width, facet = ~Species,
#'     type = "histogram",
#'     data = iris
#' )
#'
#' # For visualizing faceted histograms across varying scales, you may also wish
#' # to impose free histogram breaks too (i.e., calculate breaks separately for
#' # each group). Compare:
#'
#' # free facet scales + shared histogram breaks, versus...
#' tinyplot(
#'     ~Petal.Width, facet = ~Species,
#'     facet.args = list(free = TRUE),
#'     type = type_histogram(),
#'     data = iris
#' )
#' # ... free facet scales + free histogram breaks
#' tinyplot(
#'     ~Petal.Width, facet = ~Species,
#'     facet.args = list(free = TRUE),
#'     type = type_histogram(free = TRUE),
#'     data = iris
#' )
#'
#' @export
type_histogram = function(breaks = "Sturges",
                          freq = NULL, right = TRUE,
                          free.breaks = FALSE, drop.zeros = TRUE) {
    out = list(
        data = data_histogram(breaks = breaks,
                              free.breaks = free.breaks, drop.zeros = drop.zeros,
                              freq = freq, right = right),
        draw = draw_rect(),
        name = "histogram"
    )
    class(out) = "tinyplot_type"
    return(out)
}
#' @export
#' @name type_hist
#' @rdname type_histogram
type_hist = type_histogram

data_histogram = function(breaks = "Sturges",
                          free.breaks = FALSE, drop.zeros = TRUE,
                          freq = NULL, right = TRUE) {

    hbreaks = breaks
    hfree.breaks = free.breaks
    hdrop.zeros = drop.zeros
    hfreq = freq
    hright = right

    fun = function(by, facet, ylab, col, bg, ribbon.alpha, datapoints, .breaks = hbreaks, .freebreaks = hfree.breaks, .freq = hfreq, .right = hright, .drop.zeros = hdrop.zeros, ...) {

        hbreaks = ifelse(!sapply(.breaks, is.null), .breaks, "Sturges")

        if (is.null(by) && is.null(palette)) {
            if (is.null(col)) col = par("fg")
            if (is.null(bg)) bg = "lightgray"
        } else {
            if (is.null(bg)) bg = ribbon.alpha
        }

        if (!.freebreaks) xbreaks = hist(datapoints$x, breaks = hbreaks, right = .right, plot = FALSE)$breaks
        datapoints = split(datapoints, list(datapoints$by, datapoints$facet))
        datapoints = Filter(function(k) nrow(k) > 0, datapoints)

        datapoints = lapply(datapoints, function(k) {
            if (.freebreaks) xbreaks = breaks
            h = hist(k$x, breaks = xbreaks, right = .right, plot = FALSE)
            # zero count cases
            if (.drop.zeros) {
                nzidx = which(h$counts > 0)
                h$density = h$density[nzidx]
                h$counts = h$counts[nzidx]
                h$breaks = h$breaks[c(1, nzidx+1)]
                h$mids = h$mids[nzidx]
            }
            freq = if(!is.null(.freq)) .freq else is.null(.freq) && h$equidist
            out = data.frame(
                by = k$by[1], # already split
                facet = k$facet[1], # already split
                ymin = 0,
                ymax = if (freq) h$counts else h$density,
                xmin = h$breaks[-1],
                xmax = h$mids + (h$mids - h$breaks[-1]),
                freq = freq
            )
            return(out)
        })
        datapoints = do.call(rbind, datapoints)

        if (is.null(ylab)) {
            ylab = ifelse(datapoints$freq[1], "Frequency", "Density")
        }

        out = list(
            x = c(datapoints$xmin, datapoints$xmax),
            y = c(datapoints$ymin, datapoints$ymax),
            ymin = datapoints$ymin,
            ymax = datapoints$ymax,
            xmin = datapoints$xmin,
            xmax = datapoints$xmax,
            ylab = ylab,
            col = col,
            bg = bg,
            datapoints = datapoints,
            by = if (length(unique(datapoints$by)) == 1) by else datapoints$by,
            facet = if (length(unique(datapoints$facet)) == 1) facet else datapoints$facet
        )
        return(out)
    }
    return(fun)
}

#' Quantile-Quantile plot (QQ)
#'
#' @description Plots the theoretical quantiles of `x` on the horizontal axis
#' against observed values of `x` on the vertical axis.
#'
#' @param distribution Distribution function to use.
#' @examples
#' tinyplot(~mpg, data = mtcars, type = type_qq())
#'
#' # suppress the line
#' tinyplot(~mpg, data = mtcars, lty = 0, type = type_qq())
#' @importFrom stats qnorm ppoints quantile
#' @export
type_qq = function(distribution = qnorm) {
  data_qq = function(distribution) {
    fun = function(datapoints, ...) {
      y = sort(datapoints$y)
      x = datapoints$x
      x = distribution(ppoints(x))
      datapoints$x = x
      datapoints$y = y
      out = list(datapoints = datapoints)
      return(out)
    }
  }

  draw_qq = function() {
    fun = function(ix, iy, icol, ibg, ipch, ilwd, ilty, cex, xlab, ...) {
      points(
        x = ix,
        y = iy,
        col = icol,
        bg = ibg,
        type = "p",
        pch = ipch,
        lwd = ilwd,
        cex = cex
      )

      if (!is.null(ilty)) {
        iy <- quantile(iy, c(0.25, 0.75))
        ix <- quantile(ix, c(0.25, 0.75))
        slope <- diff(iy) / diff(ix)
        intercept <- iy[1] - slope * ix[1]
        abline(a = intercept, b = slope, lty = ilty, col = icol, lwd = ilwd)
      }
    }
    return(fun)
  }

  out = list(
    draw = draw_qq(),
    data = data_qq(distribution = distribution),
    name = "qq"
  )
  class(out) = "tinyplot_type"
  return(out)
}

#' @param v x-value(s) for vertical line(s). Numeric of length 1, or equal to
#'   the number of groups or number of facets (or the product thereof).
#' @rdname type_abline
#' @export
type_vline = function(v = 0) {
  assert_numeric(v)
  data_vline = function(datapoints, lwd, lty, col, ...) {
    if (nrow(datapoints) == 0) {
      msg = "`type_vline() only works on existing plots with x and y data points."
      stop(msg, call. = FALSE)
    }
    # keep track of unique lty and lwd (needed for group catch / escape hatch
    # later in draw_hline)
    ul_lwd = length(unique(lwd))
    ul_lty = length(unique(lty))
    ul_col = length(unique(col))
    return(list(type_info = list(ul_lty = ul_lty, ul_lwd = ul_lwd, ul_col = ul_col)))
  }
  draw_vline = function() {
    fun = function(
      ifacet, iby, data_facet, icol, ilty, ilwd,
      ngrps, nfacets, by_continuous, facet_by,
      type_info,
      ...
    ) {

      # flag for aesthetics by groups
      grp_aes = type_info[["ul_col"]] == 1 || type_info[["ul_lty"]] == ngrps || type_info[["ul_lwd"]] == ngrps

      if (length(v) != 1) {
        if (!length(v) %in% c(ngrps, nfacets, ngrps*nfacets)) {
          msg = "Length of 'v' must be 1, or equal to the number of facets or number of groups (or product thereof)."
          stop(msg, call. = FALSE)
        }
        if (!facet_by && length(v) == nfacets) {
          v = v[ifacet]
          if (!grp_aes && type_info[["ul_col"]]!=ngrps) {
            icol = 1
          } else if (by_continuous) {
            icol = 1
          }
        } else if (!by_continuous && length(v) == ngrps * nfacets) {
          v = v[ifacet * ngrps - c(ngrps - iby)]
        } else if (!by_continuous) {
          v = v[iby]
        }
      } else if (!grp_aes) {
        icol = 1
      }

      abline(v = v, col = icol, lty = ilty, lwd = ilwd)
    }
    return(fun)
  }
  out = list(
    draw = draw_vline(),
    data = data_vline,
    name = "vline"
  )
  class(out) = "tinyplot_type"
  return(out)
}

#' Ribbon and area plot types
#'
#' @param alpha numeric value between 0 and 1 specifying the opacity of ribbon shading
#'   If no `alpha` value is provided, then will default to `tpar("ribbon.alpha")`
#'   (i.e., probably `0.2` unless this has been overridden by the user in their global
#'   settings.)
#'
#' @description Type constructor functions for producing polygon ribbons, which
#' define a `y` interval (usually spanning from `ymin` to `ymax`) for each
#' `x` value. Area plots are a special case of ribbon plot where `ymin` is
#' set to 0 and `ymax` is set to `y`.
#'
#' @examples
#' x = 1:100/10
#' y = sin(x)
#'
#' #
#' ## Ribbon plots
#'
#' # "ribbon" convenience string
#' tinyplot(x = x, ymin = y-1, ymax = y+1, type = "ribbon")

#' # Same result with type_ribbon()
#' tinyplot(x = x, ymin = y-1, ymax = y+1, type = type_ribbon())
#'
#' # y will be added as a line if it is specified
#' tinyplot(x = x, y = y, ymin = y-1, ymax = y+1, type = "ribbon")
#'
#' #
#' ## Area plots
#'
#' # "area" type convenience string
#' tinyplot(x, y, type = "area")
#'
#' # Same result with type_area()
#' tinyplot(x, y, type = type_area())
#'
#' # Area plots are often used for time series charts
#' tinyplot(AirPassengers, type = "area")
#' @export
type_ribbon = function(alpha = NULL) {
  out = list(
    draw = draw_ribbon(),
    data = data_ribbon(ribbon.alpha = alpha),
    name = "ribbon"
  )
  class(out) = "tinyplot_type"
  return(out)
}

draw_ribbon = function() {
    fun = function(ix, iy, ixmin, ixmax, iymin, iymax, ibg, ilty, ilwd, icol, ipch, i, flip = FALSE, ...) {
        polyg = type_polygon()$draw
        lin = type_lines()$draw
        if (isFALSE(flip)) {
            polyg(ix = c(ix, rev(ix)), iy = c(iymin, rev(iymax)), icol = NA, ibg = ibg)
        } else {
            polyg(c(ixmin, rev(ixmax)), iy = c(iy, rev(iy)), icol = NA, ibg = ibg)
        }
        lin(ix = ix, iy = iy, icol = icol, ipch = ipch, ibg = ibg, ilty = ilty, ilwd = ilwd, type = "l")
    }
    return(fun)
}

data_ribbon = function(ribbon.alpha = NULL) {
    ribbon.alpha = sanitize_ribbon.alpha(ribbon.alpha)
    fun = function(datapoints, xlabs, null_by, null_facet, ...) {
        # Convert x to factor if it's not already
        if (is.character(datapoints$x)) {
            datapoints$x = as.factor(datapoints$x)
        }

        if (is.factor(datapoints$x)) {
            xlvls = levels(datapoints$x)
            xlabs = seq_along(xlvls)
            names(xlabs) = xlvls
            datapoints$x = as.integer(datapoints$x)
        } else {
            xlabs = NULL
        }

        if (null_by && null_facet) {
            xord = order(datapoints$x)
        } else if (null_facet) {
            xord = order(datapoints$by, datapoints$x)
        } else if (null_by) {
            xord = order(datapoints$facet, datapoints$x)
        } else {
            xord = order(datapoints$by, datapoints$facet, datapoints$x)
        }

        # Reorder x, y, ymin, and ymax based on the order determined
        datapoints = datapoints[xord,]

        # Catch for missing ymin and ymax
        if (is.null(datapoints$ymin)) datapoints$ymin = datapoints$y
        if (is.null(datapoints$ymax)) datapoints$ymax = datapoints$y

        out = list(
            x = datapoints$x,
            y = datapoints$y,
            ymin = datapoints$ymin,
            ymax = datapoints$ymax,
            xlabs = xlabs,
            datapoints = datapoints,
            ribbon.alpha = ribbon.alpha)

        if (length(unique(datapoints$by)) > 1) out[["by"]] = datapoints$by
        if (length(unique(datapoints$facet)) > 1) out[["facet"]] = datapoints$facet

        return(out)
    }
    return(fun)
}

#' Plot a function
#'
#' @details
#' When using `type_function()` in a `tinyplot()` call, the `x` value indicates
#' the range of values to plot on the x-axis.
#'
#' @param fun Function of `x` to plot. Defaults to \code{\link[stats]{dnorm}}.
#' @param args List of additional arguments to be passed to `fun`.
#' @param n Number of points to interpolate on the x axis.
#' @param ... Additional arguments are passed to the `lines()` function,
#' ex: `type="p"`, `col="pink"`.
#' @importFrom stats dnorm
#'
#' @examples
#' # Plot the normal density (default function)
#' tinyplot(x = -4:4, type = "function")
#' # tinyplot(x = -4:4, type = type_function()) # same
#'
#' # Customize by passing explicit arguments to your function
#' tinyplot(x = -1:10, type = type_function(
#'   fun = dnorm, args = list(mean = 3)
#' ))
#'
#' # Additional arguments are passed to the `lines()` function.
#' tinyplot(x = -4:4, type = type_function(
#'   fun = dnorm,
#'   col = "pink", type = "p", pch = 3
#' ))
#'
#' # Custom function example
#' ## (Here using `function(x)`, but you could also use the shorter `\(x)`
#' ## anonymous function syntax introduced in R 4.1.0)
#' tinyplot(x = -4:4, type = type_function(fun = function(x) 0.5 * exp(-abs(x))))
#'
#' @export
type_function = function(fun = dnorm, args = list(), n = 101, ...) {
  assert_function(fun)
  lines_args = list(...)
  data_function = function(args, fun) {
    funky = function(xlim, ylim, datapoints, ...) {
      if (nrow(datapoints) == 0 || !"x" %in% names(datapoints)) {
        stop("Need to provide x values to plot the function.", call. = FALSE)
      }
      if (is.null(xlim)) {
        xlim = range(datapoints[["x"]])
      }
      if (is.null(ylim)) {
        tmp = c(list(datapoints[["x"]]), args)
        tmp = range(tmp)
        tmp = seq(tmp[1], tmp[2], length.out = n)
        tmp = c(list(tmp), args)
        tmp = do.call(fun, tmp)
        ylim = c(min(tmp), max(tmp))
      }
      out = list(xlim = xlim, ylim = ylim)
      return(out)
    }
  }
  draw_function = function() {
    funky = function(ifacet, data_facet, ...) {
      xrange = range(data_facet[[ifacet]][["x"]])
      x = seq(xrange[1], xrange[2], length.out = n)
      y = do.call(fun, c(list(x), args))
      tmp = c(list(x, y), lines_args)
      do.call(lines, tmp)
    }
    return(funky)
  }
  out = list(
    draw = draw_function(),
    data = data_function(args = args, fun = fun),
    name = "function"
  )
  class(out) = "tinyplot_type"
  return(out)
}

#' @title Retrieve the saved graphical parameters
#'
#' @description Convenience function for retrieving the graphical parameters
#'   (i.e., the full list of `tag = value` pairs held in
#'   \code{\link[graphics]{par}}) from either immediately before or
#'   immediately after the most recent [tinyplot] call.
#'
#' @param when character. From when should the saved parameters be retrieved?
#'   Either "before" (the default) or "after" the preceding `tinyplot` call.
#'
#' @details A potential side-effect of [tinyplot] is that it can change a user's
#'   \code{\link[graphics]{par}} settings. For example, it may adjust the inner
#'   and outer plot margins to make space for an automatic legend; see
#'   [draw_legend]. While it is possible to immediately restore the original
#'   \code{\link[graphics]{par}} settings upon exit via the
#'   `tinyplot(..., restore.par = TRUE)` argument, this is not the default
#'   behaviour. The reason being that we need to preserve the adjusted parameter
#'   settings in case users want to add further graphical annotations to their
#'   plot (e.g., \code{\link[graphics]{abline}}, \code{\link[graphics]{text}},
#'   etc.) Nevertheless, it may still prove desirable to recall and reset these
#'   original graphical parameters after the fact (e.g., once all these extra
#'   annotations have been added). That is the purpose of this [get_saved_par]
#'   function.
#'
#'   Of course, users may prefer to manually capture and reset graphical
#'   parameters, as per the standard method described in the
#'   \code{\link[graphics]{par}} documentation. For example:
#'
#'   ```
#'   op = par(no.readonly = TRUE)  # save current par settings
#'   # <do lots of (tiny)plotting>
#'   par(op)                       # reset original pars
#'   ```
#'
#'   This standard manual approach may be safer than [get_saved_par] because it
#'   offers more precise control. Specifically, the value of [get_saved_par]
#'   itself will be reset after ever new [tinyplot] call; i.e. it may inherit an
#'   already-changed set of parameters. Users should bear these trade-offs in
#'   mind when deciding which approach to use. As a general rule,
#'   [get_saved_par] offers the convenience of resetting the original
#'   \code{\link[graphics]{par}} settings even if a user forgot to save them
#'   beforehand. But one should avoid invoking it after a series of consecutive
#'   [tinyplot] calls.
#'
#'   Finally, note that users can always call \code{\link[grDevices]{dev.off}}
#'   to reset all \code{\link[graphics]{par}} settings to their defaults.
#'
#' @returns A list of \code{\link[graphics]{par}} settings.
#'
#' @examples
#' #
#' # Contrived example where we draw a grouped scatterplot with a legend and
#' # manually add corresponding best fit lines for each group...
#' #
#'
#' # First draw the grouped scatterplot
#' tinyplot(Sepal.Length ~ Petal.Length | Species, iris)
#'
#' # Preserving adjusted par settings is good for adding elements to our plot
#' for (s in levels(iris$Species)) {
#'   abline(
#'     lm(Sepal.Length ~ Petal.Length, iris, subset = Species==s),
#'     col = which(levels(iris$Species)==s)
#'   )
#' }
#'
#' # Get saved par from before the preceding tinyplot call (but don't use yet)
#' sp = get_saved_par("before")
#'
#' # Note the changed margins will affect regular plots too, which is probably
#' # not desirable
#' plot(1:10)
#'
#' # Reset the original parameters (could use `par(sp)` here)
#' tpar(sp)
#' # Redraw our simple plot with our corrected right margin
#' plot(1:10)
#'
#' #
#' # Quick example going the other way, "correcting" for par.restore = TRUE...
#' #
#'
#' tinyplot(Sepal.Length ~ Petal.Length | Species, iris, restore.par = TRUE)
#' # Our added best lines will be wrong b/c of misaligned par
#' for (s in levels(iris$Species)) {
#'   abline(
#'     lm(Sepal.Length ~ Petal.Length, iris, subset = Species==s),
#'     col = which(levels(iris$Species)==s), lty = 2
#'   )
#' }
#' # grab the par settings from the _end_ of the preceding tinyplot call to fix
#' tpar(get_saved_par("after"))
#' # now the best lines are correct
#' for (s in levels(iris$Species)) {
#'   abline(
#'     lm(Sepal.Length ~ Petal.Length, iris, subset = Species==s),
#'     col = which(levels(iris$Species)==s)
#'   )
#' }
#'
#' # reset again to original saved par settings before exit
#' tpar(sp)
#'
#' @export
get_saved_par = function(when = c("before", "after", "first")) {
  when = match.arg(when)
  par_env_name = paste0(".saved_par_", when)
  return(get(par_env_name, envir = get(".tinyplot_env", envir = parent.env(environment()))))
}

# (non-exported) companion function(s) for setting the original pars
set_saved_par = function(when = c("before", "after", "first"), value) {
  when = match.arg(when)
  par_env_name = paste0(".saved_par_", when)
  assign(par_env_name, value, envir = get(".tinyplot_env", envir = parent.env(environment())))
}

#' Error bar and pointrange plot types
#'
#' @description Type function(s) for producing error bar and pointrange plots.
#'
#' @inheritParams graphics::arrows
#' @examples
#' mod = lm(mpg ~ wt * factor(am), mtcars)
#' coefs = data.frame(names(coef(mod)), coef(mod), confint(mod))
#' colnames(coefs) = c("term", "est", "lwr", "upr")
#'
#' op = tpar(pch = 19)
#'
#' # "errorbar" and "pointrange" type convenience strings
#' tinyplot(est ~ term, ymin = lwr, ymax = upr, data = coefs, type = "errorbar")
#' tinyplot(est ~ term, ymin = lwr, ymax = upr, data = coefs, type = "pointrange")
#'
#' # Use `type_errorbar()` to pass extra arguments for customization
#' tinyplot(est ~ term, ymin = lwr, ymax = upr, data = coefs, type = type_errorbar(length = 0.2))
#'
#' tpar(op)
#'
#' @export
type_errorbar = function(length = 0.05) {
  out = list(
    draw = draw_errorbar(length = length),
    data = data_pointrange(),
    name = "p"
  )
  class(out) = "tinyplot_type"
  return(out)
}

draw_errorbar = function(length = 0.05) {
    fun = function(ix, iy, ixmin, iymin, ixmax, iymax, icol, ibg, ipch, ilwd, cex, ...) {
        arrows(
            x0 = ixmin,
            y0 = iymin,
            x1 = ixmax,
            y1 = iymax,
            col = icol,
            lwd = ilwd,
            length = length,
            angle = 90,
            code = 3
        )
        draw_points()(ix = ix, iy = iy, icol = icol, ibg = ibg, ipch = ipch, ilwd = ilwd, cex = cex)
    }
    return(fun)
}

#' Points plot type
#'
#' @description Type function for plotting points, i.e. a scatter plot.
#'
#' @examples
#' # "p" type convenience character string
#' tinyplot(Sepal.Length ~ Petal.Length, data = iris, type = "p")
#'
#' # Same result with type_points()
#' tinyplot(Sepal.Length ~ Petal.Length, data = iris, type = type_points())
#'
#' # Note: Specifying the type here is redundant. Like base plot, tinyplot
#' # automatically produces a scatter plot if x and y are numeric
#' tinyplot(Sepal.Length ~ Petal.Length, data = iris)
#'
#' # Grouped scatter plot example
#' tinyplot(Sepal.Length ~ Petal.Length | Species, data = iris)
#'
#' # Continuous grouping (with gradient legend)
#' tinyplot(Sepal.Length ~ Petal.Length | Sepal.Width, data = iris, pch = 19)
#'
#' @export
type_points = function() {
  out = list(
    draw = draw_points(),
    data = data_points(),
    name = "p"
  )
  class(out) = "tinyplot_type"
  return(out)
}

data_points = function() {
  fun = function(datapoints, ...) {
    # catch for factors (we should still be able to "force" plot these with points)
    if (is.factor(datapoints$x)) {
      xlvls = levels(datapoints$x)
      xlabs = seq_along(xlvls)
      names(xlabs) = xlvls
      datapoints$x = as.integer(datapoints$x)
    } else {
      xlabs = NULL
    }
    if (is.factor(datapoints$y)) {
      ylvls = levels(datapoints$y)
      ylabs = seq_along(ylvls)
      names(ylabs) = ylvls
      datapoints$y = as.integer(datapoints$y)
    } else {
      ylabs = NULL
    }

    out = list(
      datapoints = datapoints,
      xlabs = xlabs,
      ylabs = ylabs
    )
    return(out)
  }
}

draw_points = function() {
    fun = function(ix, iy, icol, ibg, ipch, ilwd, cex, ...) {
        points(
            x = ix,
            y = iy,
            col = icol,
            bg = ibg,
            type = "p",
            pch = ipch,
            lwd = ilwd,
            cex = cex
        )
    }
    return(fun)
}

#' @title Generic function for adding an axis to a (tiny)plot
#'
#' @description Internal function used for adding an axis to a [`tinyplot`]
#'   call.
#' @details `tinyAxis` provides a thin(ish) wrapper around
#'   \code{\link[graphics]{Axis}}, but with enhanced flexibility to (i) match
#'   parameter combinations based on the axis type and plotting theme, (ii)
#'   provide better support for date-time variables, and (iii) enable convenient
#'   formatting of axis tick labels.
#' @inheritParams graphics::Axis
#' @param type the type of axis to be drawn; inherited from the `xaxt` or `yaxt`
#'   arguments of the parent [`tinyplot()`] call. One of either: `"standard"`
#'   (default that draws the axis, ticks, and labels), `"none"` (no axes),
#'   `"ticks"` (only ticks and labels without axis line), `"labels"` (only
#'   labels without ticks and axis line), or `"axis"` (only axis line and labels
#'   but no ticks). Partial matching is allowed, e.g. `type = "s"`.
#' @inheritParams tinylabel
#' @examples
#' \dontrun{
#'
#' # plot without axes
#' tinyplot(0:10, axes = "n")
#' # add x-axis (labels only)
#' tinyplot:::tinyAxis(x = 0:10, side = 1, type = "l")
#' # add y-axis (with custom label formatting)
#' tinyplot:::tinyAxis(x = 0:10, side = 2, type = "s", labeller = "$")
#' }
#' @keywords internal
tinyAxis = function(x = NULL, ..., type = "standard", labeller = NULL) {
  type = match.arg(type, c("standard", "none", "labels", "ticks", "axis"))
  if (type == "none") {
    invisible(numeric(0L))
  } else {
    args = list(x = x, ...)
    if (type == "labels") {
      args$tick = FALSE
    } else if (type == "ticks") {
      args$lwd = 0
      if (!("lwd.ticks" %in% names(args))) args$lwd.ticks = 1
    } else if (type == "axis") {
      args$lwd.ticks = 0
    } else {
      args$tick = TRUE
    }
    if (!is.null(labeller)) {
      if (!is.null(args$at)) {
        args$labels = if (!is.null(args$labels)) tinylabel(args$labels, labeller) else tinylabel(args$at, labeller)
      } else {
        args$at = if (!inherits(x, c("POSIXt", "Date"))) axTicks(args$side) else axTicksDateTime(args$side, x = x)
        args$labels = tinylabel(args$at, labeller)
      }
    }
    do.call("Axis", args)
  }
}

# Special case for Date-Time, adapted/simplified from axis.date()
axTicksDateTime = function(side, x, ...) {
  if (inherits(x, "POSIXt")) {
    tz = attr(x, "tz")
    range = extendrange(x)
    rangeDateTime = .POSIXct(range, tz = tz)
  } else {
    range = sort(par("usr")[if (side%%2)  1L:2L else 3:4L])
    range[1L] = ceiling(range[1L])
    range[2L] = floor(range[2L])
    rangeDateTime = range
    class(rangeDateTime) = "Date"
  }
  z = pretty(rangeDateTime, n = par("lab")[2 - side%%2])
  keep = z >= range[1L] & z <= range[2L]
  z = z[keep]
  return(z)
}

#' @rdname type_abline
#' @param h y-value(s) for horizontal line(s). Numeric of length 1, or equal to
#'   the number of groups or number of facets (or the product thereof).
#' @export
type_hline = function(h = 0) {
  assert_numeric(h)
  data_hline = function(datapoints, lwd, lty, col, ...) {
    if (nrow(datapoints) == 0) {
      msg = "`type_hline() only works on existing plots with x and y data points."
      stop(msg, call. = FALSE)
    }
    # keep track of unique lty and lwd (needed for group catch / escape hatch
    # later in draw_hline)
    ul_lwd = length(unique(lwd))
    ul_lty = length(unique(lty))
    ul_col = length(unique(col))
    return(list(type_info = list(ul_lty = ul_lty, ul_lwd = ul_lwd, ul_col = ul_col)))
  }
  draw_hline = function() {
    fun = function(
      ifacet, iby, data_facet, icol, ilty, ilwd,
      ngrps, nfacets, by_continuous, facet_by,
      type_info,
      ...
    ) {

      # flag for aesthetics by groups
      grp_aes = type_info[["ul_col"]] == 1 || type_info[["ul_lty"]] == ngrps || type_info[["ul_lwd"]] == ngrps

      if (length(h) != 1) {
        if (!length(h) %in% c(ngrps, nfacets, ngrps*nfacets)) {
          msg = "Length of 'h' must be 1, or equal to the number of facets or number of groups (or product thereof)."
          stop(msg, call. = FALSE)
        }
        if (!facet_by && length(h) == nfacets) {
          h = h[ifacet]
          if (!grp_aes && type_info[["ul_col"]]!=ngrps) {
            icol = 1
          } else if (by_continuous) {
            icol = 1
          }
        } else if (!by_continuous && length(h) == ngrps * nfacets) {
          h = h[ifacet * ngrps - c(ngrps - iby)]
        } else if (!by_continuous) {
          h = h[iby]
        }
      } else if (!grp_aes) {
        icol = 1
      }

      abline(h = h, col = icol, lty = ilty, lwd = ilwd)
    }
    return(fun)
  }
  out = list(
    draw = draw_hline(),
    data = data_hline,
    name = "hline"
  )
  class(out) = "tinyplot_type"
  return(out)
}

#' Generalized linear model plot type
#'
#' @description Type function for plotting a generalized model fit.
#' Arguments are passed to \code{\link[stats]{glm}}.
#'
#' @param se logical. If TRUE, confidence intervals are drawn.
#' @inheritParams stats::glm
#' @inheritParams stats::predict.glm
#' @inheritParams stats::confint
#' @importFrom stats glm predict
#' @examples
#' # "glm" type convenience string
#' tinyplot(am ~ mpg, data = mtcars, type = "glm")
#'
#' # Use `type_glm()` to pass extra arguments for customization
#' tinyplot(am ~ mpg, data = mtcars, type = type_glm(family = "binomial"))
#' @export
type_glm = function(family = "gaussian", se = TRUE, level = 0.95, type = "response") {
    assert_flag(se)
    out = list(
        draw = draw_ribbon(),
        data = data_glm(family = family, se = se, level = level, type = type),
        name = if (isTRUE(se)) "ribbon" else "l"
    )
    class(out) = "tinyplot_type"
    return(out)
}

data_glm = function(family, se, level, type, ...) {
    fun = function(datapoints, ...) {
        dat = split(datapoints, list(datapoints$facet, datapoints$by))
        dat = lapply(dat, function(x) {
            if (nrow(x) == 0) return(x)
            if (nrow(x) < 3) {
                x$y = NA
                return(x)
            }
            fit = glm(y ~ x, data = x, family = family)
            nd = data.frame(x = seq(min(x$x, na.rm = TRUE), max(x$x, na.rm = TRUE), length.out = 100))
            nd$by = x$by[1]
            nd$facet = x$facet[1]
            if (se == TRUE) {
                if (identical(type, "response")) {
                    p = predict(fit, newdata = nd, type = "link", se.fit = TRUE)
                    p = ci(p$fit, p$se.fit, conf.level = level, fit$df.residual, backtransform = stats::family(fit)$linkinv)
                    nd$y = p$estimate
                    nd$ymax = p$conf.high
                    nd$ymin = p$conf.low

                } else {
                    nd$y = predict(fit, newdata = nd, type = type)
                    nd = ci(nd$y, nd$se, level, fit$df.residual, backtransform = stats::family(fit)$linkinv)
                }
            } else {
                nd$y = predict(fit, nd, type = type)
            }
            nd
        })
        datapoints = do.call(rbind, dat)
        datapoints = datapoints[order(datapoints$facet, datapoints$by, datapoints$x), ]
        out = list(datapoints = datapoints)
        return(out)
    }
    return(fun)
}

#' Calculate confidence intervals
#' @importFrom stats qt
#' @keywords internal
ci = function(estimate, std.error, conf.level, df, backtransform = identity) {
    crit = qt(1 - (1 - conf.level) / 2, df)
    out = list(
        estimate = backtransform(estimate),
        conf.low = backtransform(estimate - crit * std.error),
        conf.high = backtransform(estimate + crit * std.error)
    )
    return(out)
}

#' Plot summary values of `y` at unique values of `x`
#'
#' @md
#' @description
#' Applies a summary function to `y` along unique values of `x`. For example,
#' plot the mean `y` value for each `x` value. Internally,
#' `type_summary()` applies a thin wrapper around \code{\link[stats]{ave}} and
#' then passes the result to [`type_lines`] for drawing.
#'
#' @param fun summarizing function. Should be compatible with
#'   \code{\link[stats]{ave}}. Defaults to \code{\link[base]{mean}}.
#' @param ... Additional arguments are passed to the `lines()` function,
#' ex: `type="p"`, `col="pink"`.
#' @seealso [`ave`] which performs the summarizing (averaging) behind the
#'   scenes.
#' @examples
#' # Plot the mean chick weight over time
#' tinyplot(weight ~ Time, data = ChickWeight, type = "summary")
#'
#' # Note: "mean" is the default function, so these are also equivalent:
#' # tinyplot(weight ~ Time, data = ChickWeight, type = type_summary())
#' # tinyplot(weight ~ Time, data = ChickWeight, type = type_summary(mean))
#'
#' # Plot the median instead
#' tinyplot(weight ~ Time, data = ChickWeight, type = type_summary(median))
#'
#' # Works with groups and/or facets too
#' tinyplot(weight ~ Time | Diet, facet = "by", data = ChickWeight, type = "summary")
#'
#' # Custom/complex function example
#' tinyplot(
#'   weight ~ Time | Diet, facet = "by", data = ChickWeight,
#'   type = type_summary(function(y) quantile(y, probs = 0.9)/max(y))
#' )
#'
#' @importFrom stats ave
#' @export
type_summary = function(fun = mean, ...) {
  assert_function(fun)
  lines_args = list(...)
  data_summary = function(fun) {
    funky = function(datapoints, ...) {
      datapoints = split(datapoints, list(datapoints$facet, datapoints$by), drop = TRUE)
      datapoints = lapply(datapoints, function(dat) {
        newy = ave(dat$y, dat$x, FUN = fun)
        dat$y = newy
        dat = dat[order(dat$x), ]
        return(dat)
      })
      datapoints = do.call(rbind, datapoints)
      out = list(datapoints = datapoints)
      return(out)
    }
    return(funky)
  }
  out = list(
    draw = draw_lines(...),
    data = data_summary(fun = fun),
    name = "l"
  )
  class(out) = "tinyplot_type"
  return(out)
}

by_col = function(ngrps = 1L, col = NULL, palette = NULL, gradient = NULL, ordered = NULL, alpha = NULL) {
  if (is.null(alpha)) alpha = 1
  if (is.null(ordered)) ordered = FALSE
  if (is.null(gradient)) gradient = FALSE
  assert_logical(ordered)
  assert_logical(gradient)
  if (gradient) {
    ngrps = 100L
  }

  # pal_qual = get_tpar("palette.qualitative", default = NULL)
  pal_theme = get_tpar("palette.qualitative", default = NULL)
  theme_flag = !is.null(pal_theme)

  # palette = substitute(palette, env = parent.env(environment()))

  # special "by" convenience keyword (will treat as NULL & handle grouping below)
  if (!anyNA(col) && !is.null(col) && length(col) == 1 && col == "by") col = NULL

  #
  ## Base case: If no color or palette provided, pass colors as a sequence of
  ## numbers (will inherit from / cycle over the user's default palette)

  if (is.null(col) && (is.null(palette) && !theme_flag)) {
    if (ngrps <= length(palette())  && !ordered) {
      col = palette()[seq_len(ngrps)]
      if (alpha) col = adjustcolor(col, alpha.f = alpha)
    } else {
      # fallback to restricted viridis palette
      col = colorRampPalette(
        hcl.colors(n = 100, palette = "Viridis", alpha = alpha)[(100 * 0.1 + 1):(100 * 0.9)],
        alpha = TRUE
      )(ngrps)
    }
    if (gradient || ordered) col = rev(col)
    return(col)
  }

  #
  ## Next simplest case: No palette, but color(s) provided directly. We do
  ## some simple sanity checks, apply alpha transparency and return as-is.

  if (is.atomic(col) && is.vector(col)) {
    if (length(col) == 1) {
      col = rep(col, ngrps)
      if (alpha) col = adjustcolor(col, alpha.f = alpha)
      return(col)
    } else if (length(col) < ngrps) {
      # if (!gradient) {
      #   stop(sprintf("`col` must be of length 1, or greater than or equal to %s.", ngrps), call. = FALSE)
      # } else {
      #   # interpolate gradient colors
      #   col = colorRampPalette(colors = col, alpha = TRUE)(ngrps)
      # }
      # if manual colours < ngrps, either (1) interpolate for gradient
      # colors, or (2) recycle for discrete colours
      if (gradient) {
        col = colorRampPalette(colors = col, alpha = TRUE)(ngrps)
      } else {
        ncolsstr = paste0("(", length(col), ")")
        ngrpsstr = paste0("(", ngrps, ")")
        warning(
          "\nFewer colours ", ncolsstr, " provided than than there are groups ",
          ngrpsstr, ". Recycling to make up the shortfall."
        )
        col = rep(col, length.out = ngrps)
      }

    }
    if (gradient) {
      col = rev(col)
    } else if (!ordered && is.numeric(col)) {
      # col = palette()[col]
      if (ngrps <= length(palette())) {
        col = palette()[col]
        # if (alpha) col = adjustcolor(col, alpha.f = alpha)
      } else {
        col = hcl.colors(max(col), alpha = alpha)[col]
      }
    }
    if (anyNA(col) || is.character(col)) {
      if (alpha) col = adjustcolor(col, alpha.f = alpha)
      return(col)
    }
  }

  #
  ## Theme case: No palette provided, but fallback to tinytheme palette

  # we need to fix palette string, determine if in palette.pals() and then
  # determine no. of groups, before kicking over to sequential
  if (is.null(palette) && theme_flag) {
    if (length(pal_theme) == 1) {
      qual_match = match_pal(pal_theme, palette.pals())
      if (!is.na(qual_match)) {
        if (ngrps >= get_pal_lens(pal_theme) || ordered) {
          pal_theme = get_tpar("palette.sequential", default = NULL)
        }
      # mostly a catch for x-gradient fills, e.g. type_ridge
      } else if (gradient && !is.na(match_pal(pal_theme, hcl.pals()))) {
          pal_theme = get_tpar("palette.sequential", default = NULL)
      }
    }
    if (length(pal_theme) == 1) {
      palette_fun = gen_pal_fun(pal = pal_theme, gradient = gradient, alpha = alpha)
      args = list(n = ngrps, palette = pal_theme, alpha = alpha)
    }
    palette = pal_theme
  }

  if (is.null(palette)) {
    if (ngrps <= length(palette()) && !ordered && !gradient) {
      palette_fun = function(alpha) adjustcolor(palette(), alpha) # must be function to avoid arg ambiguity
      args = list(alpha = alpha)
    } else {
      if (ngrps <= 8 && !ordered) { # ngrps < 100 so we know gradient is FALSE too
        palette = "R4"
        palette_fun = palette.colors
      } else {
        palette = "Viridis"
        if (!gradient && !ordered) {
          palette_fun = hcl.colors
        } else {
          palette_fun_gradient = function(n, palette, from = 0.1, to = 0.9, alpha = 1) {
            colorRampPalette(
              hcl.colors(n = 100, palette = palette, alpha = alpha)[(100 * from + 1):(100 * to)],
              alpha = TRUE
            )(n)
          }
          palette_fun = palette_fun_gradient
        }
      }
      args = list(n = ngrps, palette = palette, alpha = alpha)
    }
  } else {
    if (is.character(palette)) {
      # special case: if vector of character strings, we assume that the user
      # must have passed a vector of colours (e.g., c("red", "blue")) rather
      # than a known/named colour palette (e.g. "Harmonic")
      if (length(palette) > 1) {
        palette_fun = "c"
        if (!is.null(alpha)) palette = adjustcolor(palette, alpha.f = alpha)
        args = as.list(palette)
        if (length(args) < ngrps && length(args) != 1) {
          # if manual colours < ngrps, either (1) interpolate for gradient
          # colors, or (2) recycle for discrete colours
          if (gradient) {
            args = list(colorRampPalette(args, alpha = TRUE)(ngrps))
          } else {
            ncolsstr = paste0("(", length(args), ")")
            ngrpsstr = paste0("(", ngrps, ")")
            warning(
              "\nFewer colours ", ncolsstr, " provided than than there are groups ",
              ngrpsstr, ". Recycling to make up the shortfall."
            )
            args = rep(args, length.out = ngrps)
          }
        }
      } else {
        palette_fun = gen_pal_fun(palette, gradient = gradient, alpha = alpha, n = ngrps)
        args = list(n = ngrps, palette = palette, alpha = alpha)
      }
    } else if (inherits(palette, c("call", "name"))) {
      # catch for when using passes palette as named object (e.g,
      # pal26 = palette.colors("Alphabet"))
      if (inherits(palette, "name") && is.character(eval(palette))) {
        args = as.list(eval(palette))
        palette_fun = "c"
      } else {
        args = as.list(palette)
        palette_fun = paste(args[[1]])
        args[[1]] = NULL
      }
      # catch for direct vector or list
      if (palette_fun %in% c("c", "list")) {
        if (palette_fun == "list") palette_fun = "c"
        if (!is.null(alpha)) args = lapply(args, function(a) adjustcolor(a, alpha.f = alpha))
        if (length(args) < ngrps && length(args) != 1) {
          # if manual colours < ngrps, either (1) interpolate for gradient
          # colors, or (2) recycle for discrete colours
          if (gradient) {
            args = list(colorRampPalette(args, alpha = TRUE)(ngrps))
          } else {
            ncolsstr = paste0("(", length(args), ")")
            ngrpsstr = paste0("(", ngrps, ")")
            warning(
              "\nFewer colours ", ncolsstr, " provided than than there are groups ",
              ngrpsstr, ". Recycling to make up the shortfall."
            )
            args = rep(args, length.out = ngrps)
          }
        }
      } else {
        args[["n"]] = ngrps
        # remove unnamed arguments to prevent unintentional argument sliding
        if (any(names(args) == "")) args[[which(names(args) == "")]] = NULL
      }
    } else if (inherits(palette, "function")) {
      args = list()
      palette_fun = palette
    } else {
      stop(
        "\nInvalid palette argument. Must be a recognized keyword, or a ",
        "palette-generating function with named arguments.\n"
      )
    }
  }

  cols = tryCatch(
    do.call(palette_fun, args),
    error = function(e) do.call(eval(palette), args) # catch for bespoke palette generating funcs
  )

  if (length(cols) > ngrps) cols = cols[1:ngrps]

  # For gradient and ordered colors, we'll run high to low
  if (gradient || ordered) cols = rev(cols)

  return(cols)
}

# Some utility functions for palette matching, etc.

match_pal = function(pal, pals) {
  fx = function(x) tolower(gsub("[-, _, \\,, (, ), \\ , \\.]", "", x))
  charmatch(fx(pal), fx(pals))
}

get_pal_lens = function(pal) {
  pal_lens = c(
    R3 = 8L, R4 = 8L, ggplot2 = 8L, `Okabe-Ito` = 9L, Accent = 8L,
    `Dark 2` = 8L, Paired = 12L, `Pastel 1` = 9L, `Pastel 2` = 8L,
    `Set 1` = 9L, `Set 2` = 8L, `Set 3` = 12L, `Tableau 10` = 10L,
    `Classic Tableau` = 10L, `Polychrome 36` = 36L, Alphabet = 26L
  )
  pal_lens[pal]
}

# take a character string, match to either palette.pals() pr hcl.pals(), and
# generate the corresponding function factor with alpha transparency
gen_pal_fun = function(pal, gradient = FALSE, alpha = NULL, n = NULL) {
  pal_match = match_pal(pal, palette.pals())
  if (!is.na(pal_match)) {
    if (pal_match < 1L) stop("'palette' is ambiguous")
    pal_fun = palette.colors
    if (!is.null(n) && n >= get_pal_lens(pal_match)) {
      warning(
        "\nFewer colours ", get_pal_lens(pal_match), " provided than than there are groups ",
        n, ". Recycling to make up the shortfall."
      )
      pal_fun = function(n, palette, alpha) palette.colors(n = n, palette = pal, alpha = alpha, recycle = TRUE)
    }
    if (gradient) {
      pal_fun = function(n, palette, alpha) colorRampPalette(palette.colors(palette = pal, alpha = alpha))(n)
    }
  } else {
    pal_match = match_pal(pal, hcl.pals())
    if (!is.na(pal_match)) {
      if (pal_match < 1L) stop("'palette' is ambiguous")
      pal_fun = hcl.colors
    } else {
      stop(
        "\nPalette string not recogized. Must be a value produced by either",
        "`palette.pals()` or `hcl.pals()`.\n",
        call. = FALSE
      )
    }
  }
  return(pal_fun)
}

by_pch = function(ngrps, type, pch = NULL) {
  no_pch = FALSE
  if (identical(type, "text")) {
    pch <- rep(15, ngrps)
  } else if (!type %in% c("p", "b", "o", "pointrange", "errorbar", "boxplot", "qq")) {
    no_pch = TRUE
    pch = NULL

    # special "by" convenience keyword
  } else if (!is.null(pch) && length(pch) == 1 && pch == "by") {
    no_pch = TRUE # skip checks below
    pch = 1:ngrps + par("pch") - 1
    # correctly recycle if over max pch type
    pch_ceiling = 25 # see ?pch
    if (max(pch) > pch_ceiling) {
      pch_below = pch[pch <= pch_ceiling]
      pch_above = pch[pch > pch_ceiling]
      pch_above = rep_len(0:pch_ceiling, length(pch_above))
      pch = c(pch_below, pch_above)
    }

    # return NULL if not a valid point type
  } else if (is.null(pch)) {
    pch = par("pch")
  }

  if (!no_pch) {
    if (!is.atomic(pch) || !is.vector(pch) || !(is.numeric(pch) || is.character(pch)) || (length(pch) != 1 && length(pch) != ngrps)) {
    # if (!is.atomic(pch) || !is.vector(pch) || !is.numeric(pch) || (length(pch) != 1 && length(pch) != ngrps)) {
      stop(sprintf("`pch` must be `NULL`, or a numeric or character vector of length 1 or %s.", ngrps), call. = FALSE)
    }

    if (length(pch) == 1) {
      pch = rep(pch, ngrps)
    }
  }

  return(pch)
}

by_lty = function(ngrps, type, lty = NULL) {
  # We only care about line types, otherwise return NULL
  if (!type %in% c("l", "b", "o", "c", "h", "s", "S", "ribbon", "barplot", "boxplot", "rect", "segments", "qq", "abline", "hline", "vline")) {
    out = NULL

    # special "by" convenience keyword
  } else if (!is.null(lty) && length(lty) == 1 && lty == "by") {
    lty_dict = c("solid", "dashed", "dotted", "dotdash", "longdash", "twodash")
    par_lty = par("lty")

    if (!par_lty %in% lty_dict) {
      warning(
        "\nBesoke lty specifications (i.e., using string combinations) are not",
        "currently supported alongside the lty='by' keyword argument.",
        "Defaulting to 1 and looping from there.\n"
      )
      par_lty = 1
    } else {
      par_lty = which(par_lty == lty_dict)
    }
    out = 1:ngrps + par_lty - 1
    # correctly recycle if over max pch type
    lty_ceiling = 6 # see ?pch
    if (max(out) > lty_ceiling) {
      lty_below = out[out <= lty_ceiling]
      lty_above = out[out > lty_ceiling]
      lty_above = rep_len(1:lty_ceiling, length(lty_above))
      out = c(lty_below, lty_above)
    }

    # NULL -> solid (or default) line
  } else if (is.null(lty)) {
    if (identical(type, "boxplot")) {
      out = NULL
    } else {
      out = rep(par("lty"), ngrps)
    }

    # atomic vector: sanity check length
  } else if (is.atomic(lty) && is.vector(lty)) {
    if (length(lty) == 1) {
      out = rep(lty, ngrps)
    } else {
      if (length(lty) != ngrps) {
        stop(sprintf("`lty` must be `NULL` or a numeric vector of length 1 or %s.", ngrps), call. = FALSE)
      }
      out = lty
    }
  }

  return(out)
}

by_lwd = function(ngrps, type, lwd = NULL) {
  lwd_base = par("lwd")
  lwd_floor = lwd_base / min(5, max((ngrps - 1), 1))
  lwd_ceiling = lwd_base * min(5, ngrps)

  no_lwd = FALSE
  # special "by" convenience keyword
  if (!is.null(lwd) && length(lwd) == 1 && lwd == "by") {
    no_lwd = TRUE # skip checks below
    lwd = seq(lwd_floor, lwd_ceiling, length.out = ngrps)
  } else if (is.null(lwd)) {
    no_lwd = TRUE
    lwd = NULL
  }

  if (!no_lwd) {
    if (!is.atomic(lwd) || !is.vector(lwd) || !is.numeric(lwd) || (length(lwd) != 1 && length(lwd) != ngrps)) {
      stop(sprintf("`lwd` must be `NULL` or a numeric vector of length 1 or %s.", ngrps), call. = FALSE)
    }
    if (length(lwd) == 1) {
      lwd = rep(lwd, ngrps)
    }
  }

  return(lwd)
}

by_bg = function(
    adjustcolor,
    alpha,
    bg,
    by,
    by_continuous,
    by_ordered,
    col,
    fill,
    ngrps,
    palette,
    ribbon.alpha,
    type) {
  if (is.null(bg) && !is.null(fill)) bg = fill
  if (!is.null(bg) && length(bg) == 1 && is.numeric(bg) && bg >= 0 && bg <= 1) {
    alpha = bg
    bg = "by"
  }
  if (!is.null(bg) && length(bg) == 1 && bg == "by") {
    bg = by_col(
      ngrps = ngrps,
      col = NULL,
      palette = palette,
      gradient = by_continuous,
      ordered = by_ordered,
      alpha = alpha
    )
  } else if (length(bg) != ngrps) {
    bg = rep(bg, ngrps)
  }
  if (type == "ribbon" || (type == "boxplot" && !is.null(by))) {
    if (!is.null(bg)) {
      bg = adjustcolor(bg, ribbon.alpha)
    } else if (!is.null(col)) {
      bg = adjustcolor(col, ribbon.alpha)
    }
  }

  return(bg)
}

#' Spline plot type
#'
#' @description Type function for plotting a cubic (or Hermite) spline interpolation.
#' Arguments are passed to \code{\link[stats]{spline}}; see this latter function
#' for default argument values.
#'
#' @inheritParams stats::spline
#' @inherit stats::spline details
#' @importFrom stats spline
#' @examples
#' # "spline" type convenience string
#' tinyplot(dist ~ speed, data = cars, type = "spline")
#'
#' # Use `type_spline()` to pass extra arguments for customization
#' tinyplot(dist ~ speed, data = cars, type = type_spline(method = "natural", n = 25),
#'     add = TRUE, lty = 2)
#' @export
type_spline = function(
        n = NULL,
        method = "fmm",
        xmin = NULL,
        xmax = NULL,
        xout = NULL,
        ties = mean
    ) {
    out = list(
        draw = draw_lines(),
        data = data_spline(method = method, ties = ties, n = n, xmin = xmin, xmax = xmax, xout = xout),
        name = "l"
    )
    class(out) = "tinyplot_type"
    return(out)
}

data_spline = function(n, method, xmin, xmax, xout, ties, ...) {
    fun = function(datapoints, ...) {
        datapoints = split(datapoints, list(datapoints$facet, datapoints$by), drop = TRUE)
        datapoints = lapply(datapoints, function(dat) {
            if (is.null(n)) n = 3*length(dat$x)
            if (is.null(xmax)) xmax = max(dat$x)
            if (is.null(xmin)) xmin = min(dat$x)
            if (is.null(xout)) {
                fit = spline(x = dat$x, y = dat$y, n = n, method = method, xmin = xmin, xmax = xmax, ties = ties)
            } else {
                fit = spline(x = dat$x, y = dat$y, n = n, method = method, xmin = xmin, xmax = xmax, xout = xout, ties = ties)
            }
            fit = as.data.frame(fit)
            fit$facet = dat$facet[1]
            fit$by = dat$by[1]
            fit
            return(fit)
        })
        datapoints = do.call(rbind, datapoints)
        out = list(datapoints = datapoints)
        return(out)
    }
    return(fun)
}

#' Line segments plot type
#'
#' @description Type function for plotting line segments.
#'
#' @details Contrary to base \code{\link[graphics]{segments}}, line segments in
#' [tinyplot] must be specified using the `xmin`, `ymin`,`xmax`, and `ymax`
#' arguments.
#'
#' @examples
#' # "segments" type convenience character string
#' tinyplot(
#'   xmin = c(0,.1), ymin = c(.2,1), xmax = c(1,.9), ymax = c(.75,0),
#'   type = "segments"
#' )
#'
#' # Same result with type_segments()
#' tinyplot(
#'   xmin = c(0,.1), ymin = c(.2,1), xmax = c(1,.9), ymax = c(.75,0),
#'   type = type_segments()
#' )
#'
#' @export
type_segments = function() {
  out = list(
    draw = draw_segments(),
    data = NULL,
    name = "segments"
  )
  class(out) = "tinyplot_type"
  return(out)
}

draw_segments = function() {
    fun = function(ixmin, iymin, ixmax, iymax, ilty, ilwd, icol, ...) {
        segments(
            x0 = ixmin, y0 = iymin, x1 = ixmax, y1 = iymax,
            lty = ilty,
            lwd = ilwd,
            col = icol
        )
    }
    return(fun)
}

check_dependency = function(library_name) {
  flag = requireNamespace(library_name, quietly = TRUE)
  if (isFALSE(flag)) {
    msg = sprintf("Please install the `%s` package.", library_name)
    return(msg)
  } else {
    return(TRUE)
  }
}

assert_dependency = function(library_name) {
  flag = check_dependency(library_name)
  if (!isTRUE(flag)) stop(flag, call. = FALSE)
  return(invisible())
}

assert_choice = function(x, choice, null.ok = FALSE, name = as.character(substitute(x))) {
  if (is.null(x) && isTRUE(null.ok)) {
    return(TRUE)
  }
  if (is.character(x) && length(x) == 1 && x %in% choice) {
    return(TRUE)
  }
  msg = sprintf(
    "`%s` must be one of: %s",
    name,
    paste(choice, collapse = ", ")
  )
  stop(msg, call. = FALSE)
}

check_true = function(x, null.ok = FALSE) {
  if (is.null(x) && isTRUE(null.ok)) {
    return(invisible(TRUE))
  }
  if (isTRUE(x)) {
    return(invisible(TRUE))
  }
  return(FALSE)
}

assert_true = function(x, null.ok = FALSE, name = as.character(substitute(x))) {
  msg = sprintf("`%s` must be true.", name)
  if (!isTRUE(check_true(x, null.ok = null.ok))) {
    stop(msg, call. = FALSE)
  }
}

check_string = function(x, null.ok = FALSE) {
  if (is.null(x) && isTRUE(null.ok)) {
    return(invisible(TRUE))
  }
  if (is.character(x) && length(x) == 1) {
    return(invisible(TRUE))
  }
  return(FALSE)
}

assert_string = function(x, null.ok = FALSE, name = as.character(substitute(x))) {
  msg = sprintf("`%s` must be a string.", name)
  if (!isTRUE(check_string(x, null.ok = null.ok))) {
    stop(msg, call. = FALSE)
  }
}

check_flag = function(x, null.ok = FALSE) {
  if (is.null(x) && isTRUE(null.ok)) {
    return(TRUE)
  }
  if (is.logical(x) && length(x) == 1) {
    return(TRUE)
  }
  return(FALSE)
}

assert_flag = function(x, null.ok = FALSE, name = as.character(substitute(x))) {
  msg = sprintf("`%s` must be a logical flag.", name)
  if (!isTRUE(check_flag(x, null.ok = null.ok))) {
    stop(msg, call. = FALSE)
  }
}

assert_length = function(x, len = 1, null.ok = FALSE, name = as.character(substitute(x))) {
  if (is.null(x) && isTRUE(null.ok)) {
    return(invisible(TRUE))
  }
  msg = sprintf("`%s` must be one of these lengths: %s", name, paste(len, collapse = ", "))
  if (!length(x) %in% len) {
    stop(msg, call. = FALSE)
  }
}

assert_logical = function(x, null.ok = FALSE, name = as.character(substitute(x))) {
  if (is.null(x) && isTRUE(null.ok)) {
    return(invisible(TRUE))
  }
  msg = sprintf("`%s` must be a logical vector", name)
  if (!is.logical(x)) stop(msg, call. = FALSE)
}

check_integerish = function(x, len = NULL, lower = NULL, upper = NULL, null.ok = TRUE) {
  if (is.null(x) && isTRUE(null.ok)) {
    return(TRUE)
  }
  if (!is.numeric(x)) {
    return(FALSE)
  }
  x = stats::na.omit(x)
  if (!is.null(len) && length(x) != len) {
    return(FALSE)
  }
  if (!is.null(lower) && any(x < lower)) {
    return(FALSE)
  }
  if (!is.null(upper) && any(x > upper)) {
    return(FALSE)
  }
  if (isTRUE(any(abs(x - round(x)) > (.Machine$double.eps)^0.5))) {
    return(FALSE)
  }
  return(TRUE)
}

assert_integerish = function(x, len = NULL, lower = NULL, upper = NULL, null.ok = FALSE, name = as.character(substitute(x))) {
  if (isTRUE(null.ok) && is.null(x)) {
    return(invisible())
  }
  msg = sprintf("`%s` must be integer-ish", name)
  if (is.null(x) && !isTRUE(null.ok)) stop(sprintf("%s should not be NULL.", name), call. = FALSE)
  if (!isTRUE(check_integerish(x, len = len, lower = lower, upper = upper, null.ok = null.ok))) {
    if (!is.numeric(x)) msg = paste0(msg, "; it is not numeric")
    if (!is.null(len) && length(x) != len) msg = paste0(msg, sprintf("; its length must be %s", len))
    if (!is.null(lower) && any(x < lower)) msg = paste0(msg, sprintf("; all values must be greater than or equal to %s", lower))
    if (!is.null(upper) && any(x > upper)) msg = paste0(msg, sprintf("; all values must be less than or equal to %s", upper))
    if (isTRUE(any(abs(x - round(x)) > (.Machine$double.eps)^0.5))) msg = paste0(msg, "; all values must be close to integers")
    stop(msg, call. = FALSE)
  }
}

check_numeric = function(x, len = NULL, lower = NULL, upper = NULL, null.ok = TRUE) {
  if (is.null(x) && isTRUE(null.ok)) {
    return(TRUE)
  }
  if (!is.numeric(x)) {
    return(FALSE)
  }
  if (!is.null(len) && length(x) != len) {
    return(FALSE)
  }
  if (!is.null(lower) && any(x < lower)) {
    return(FALSE)
  }
  if (!is.null(upper) && any(x > upper)) {
    return(FALSE)
  }
  return(TRUE)
}

assert_numeric = function(x, len = NULL, lower = NULL, upper = NULL, null.ok = FALSE, name = as.character(substitute(x))) {
  msg = sprintf("`%s` must be numeric", name)
  if (!isTRUE(check_numeric(x, len = len, lower = lower, upper = upper, null.ok = null.ok))) {
    if (!is.null(len) && length(x) != len) msg = paste0(msg, sprintf("; its length must be %s", len))
    if (!is.null(lower) && any(x < lower)) msg = paste0(msg, sprintf("; all values must be greater than or equal to %s", lower))
    if (!is.null(upper) && any(x > upper)) msg = paste0(msg, sprintf("; all values must be less than or equal to %s", upper))
    stop(msg, call. = FALSE)
  }
}

assert_data_frame = function(x, min_rows = 0, min_cols = 0, name = as.character(substitute(x))) {
  msg = sprintf("`%s` must be a data.frame.", name)
  if (!is.data.frame(x)) stop(msg, call. = FALSE)
  msg = sprintf("Number of rows in `%s` must be at least `%s`", name, min_rows)
  if (nrow(x) < min_rows) stop(msg, call. = FALSE)
  msg = sprintf("Number of columns in `%s` must be at least `%s`", name, min_cols)
  if (ncol(x) < min_cols) stop(msg, call. = FALSE)
}

check_character = function(x, len = NULL, null.ok = FALSE, name = as.character(substitute(x))) {
  if (isTRUE(null.ok) && is.null(x)) {
    return(TRUE)
  } else if (!is.character(x)) {
    msg = sprintf("`%s` must be character.", name)
    return(msg)
  } else if (!is.null(len) && length(x) != len) {
    msg = sprintf("`%s` must have length %s.", name, len)
    return(msg)
  }
  return(TRUE)
}

assert_character = function(x, len = NULL, null.ok = FALSE, name = as.character(substitute(x))) {
  flag = check_character(x, len = len, null.ok = null.ok, name = name)
  if (!isTRUE(flag)) {
    stop(flag, call. = FALSE)
  } else {
    return(invisible(TRUE))
  }
}

assert_list = function(x, named = FALSE, len = NULL, null.ok = FALSE, name = as.character(substitute(x))) {
  if (isTRUE(null.ok) && is.null(x)) {
    return(invisible(TRUE))
  }
  if (!is.list(x)) stop("Input is not a list.", call. = FALSE)
  if (isTRUE(named)) {
    if (is.null(names(x))) {
      stop(sprintf("`%s` should be named list.", name), call. = FALSE)
    }
  }
  if (!is.null(len)) {
    if (length(x) != len) {
      stop(sprintf("`%s` must be of length %s.", name, len), call. = FALSE)
    }
  }
}

assert_function = function(x, null.ok = FALSE, name = as.character(substitute(x))) {
  if (isTRUE(null.ok) && is.null(x)) {
    return(invisible(TRUE))
  }
  if (!is.function(x)) {
    msg = sprintf("`%s` must be a function.", name)
    stop(msg, call. = FALSE)
  }
}

check_atomic_vector = function(x, null.ok = FALSE, name = as.character(substitute(x))) {
  if (isTRUE(null.ok) && is.null(x)) {
    return(invisible(TRUE))
  }
  # doesn't work on glue::glue() output
  # flag = is.atomic(x) && is.vector(x) && !is.list(x)
  flag = is.atomic(x) && is.null(dim(x)) && length(x) > 0 && !is.list(x)
  if (flag) {
    out = TRUE
  } else if (is.factor(x) && is.null(dim(x))) {
    out = TRUE
  } else {
    out = sprintf("`%s` must be an atomic vector.", name)
  }
  return(out)
}

assert_atomic_vector = function(x, null.ok = FALSE, name = as.character(substitute(x))) {
  flag = check_atomic_vector(x, null.ok = null.ok, name = name)
  if (!isTRUE(flag)) {
    stop(flag, call. = FALSE)
  } else {
    return(invisible(TRUE))
  }
}

assert_class = function(x, classname) {
  if (!inherits(x, classname)) {
    msg = sprintf("`x` must be of class `%s`.", classname)
    stop(msg, call. = FALSE)
  }
}

#' Jittered points plot type
#'
#' @description Type function for plotting jittered points.
#' Arguments are passed to \code{\link[base]{jitter}}.
#'
#' @inheritParams base::jitter
#' @inherit base::jitter details
#' @examples
#' # "jitter" type convenience string
#' tinyplot(Sepal.Length ~ Species, data = iris, type = "jitter")
#'
#' # Use `type_jitter()` to pass extra arguments for customization
#' tinyplot(Sepal.Length ~ Species, data = iris, type = type_jitter(factor = 0.5))
#' @export
type_jitter = function(factor = 1, amount = NULL) {
  out = list(
    draw = draw_points(),
    data = data_jitter(factor = factor, amount = amount),
    name = "p"
  )
  class(out) = "tinyplot_type"
  return(out)
}

data_jitter = function(factor, amount) {
    fun = function(datapoints, ...) {
        x = datapoints$x
        y = datapoints$y
        if (is.factor(x)) {
            xlvls = levels(x)
            xlabs = seq_along(xlvls)
            names(xlabs) = xlvls
            x = as.integer(x)
        } else {
            xlabs = NULL
        }
        if (is.factor(y)) {
            ylvls = levels(y)
            ylabs = seq_along(ylvls)
            names(ylabs) = ylvls
            y = as.integer(y)
        } else {
            ylabs = NULL
        }
        x = jitter(x, factor = factor, amount = amount)
        y = jitter(y, factor = factor, amount = amount)

        datapoints$x = x
        datapoints$y = y

        out = list(
            datapoints = datapoints,
            x = x,
            y = y,
            xlabs = xlabs,
            ylabs = ylabs
        )
        return(out)
    }
}

#' Lines plot type
#'
#' @description Type function for plotting lines.
#'
#' @inheritParams graphics::plot.default
#'
#' @examples
#' # "l" type convenience character string
#' tinyplot(circumference ~ age | Tree, data = Orange, type = "l")
#'
#' # Use `type_lines()` to pass extra arguments for customization
#' tinyplot(circumference ~ age | Tree, data = Orange, type = type_lines(type = "s"))
#'
#' @export
type_lines = function(type = "l") {
  out = list(
    draw = draw_lines(type = type),
    data = NULL,
    name = type
  )
  class(out) = "tinyplot_type"
  return(out)
}

draw_lines = function(type = "l") {
    fun = function(ix, iy, icol, ipch, ibg, ilty, ilwd, cex = 1, ...) {
        lines(
            x = ix,
            y = iy,
            col = icol,
            type = type,
            pch = ipch,
            bg = ibg,
            lty = ilty,
            lwd = ilwd,
            cex = cex
        )
    }
    return(fun)
}

#' Polypath polygon type
#'
#' @description Type function for plotting polygons.
#' Arguments are passed to \code{\link[graphics]{polypath}}.
#'
#' @inheritParams graphics::polypath
#'
#' @examples
#' # "polypath" type convenience character string
#' tinyplot(
#'     c(.1, .1, .6, .6, NA, .4, .4, .9, .9),
#'     c(.1, .6, .6, .1, NA, .4, .9, .9, .4),
#'     type = "polypath", fill = "grey"
#' )
#'
#' # Use `type_polypath()` to pass extra arguments for customization
#' tinyplot(
#'     c(.1, .1, .6, .6, NA, .4, .4, .9, .9),
#'     c(.1, .6, .6, .1, NA, .4, .9, .9, .4),
#'     type = type_polypath(rule = "evenodd"), fill = "grey"
#' )
#' @export
type_polypath = function(rule = "winding") {
    draw_polypath = function() {
        fun =  function(ix, iy, icol, ibg, ilty, ilwd, dots, ...) {
            polypath(
                x = ix,
                y = iy,
                border = icol,
                col = ibg,
                lty = ilty,
                lwd = ilwd,
                rule = rule
            )
        }
        return(fun)
    }

    out = list(
        draw = draw_polypath(),
        data = NULL,
        name = "polypath"
    )
    class(out) = "tinyplot_type"
    return(out)
}

#' Rectangle plot type
#'
#' @description Type function for plotting rectangles.
#'
#' @details Contrary to base \code{\link[graphics]{rect}}, rectangles in
#' [tinyplot] must be specified using the `xmin`, `ymin`,`xmax`, and `ymax`
#' arguments.
#'
#' @examples
#' i = 4*(0:10)
#'
#' # "rect" type convenience character string
#' tinyplot(
#'   xmin = 100+i, ymin = 300+i, xmax = 150+i, ymax = 380+i,
#'   by = i, fill = 0.2,
#'   type = "rect"
#' )
#'
#' # Same result with type_rect()
#' tinyplot(
#'   xmin = 100+i, ymin = 300+i, xmax = 150+i, ymax = 380+i,
#'   by = i, fill = 0.2,
#'   type = type_rect()
#' )
#'
#' @export
type_rect = function() {
  out = list(
    draw = draw_rect(),
    data = NULL,
    name = "rect"
  )
  class(out) = "tinyplot_type"
  return(out)
}

draw_rect = function() {
    fun = function(ixmin, iymin, ixmax, iymax, ilty, ilwd, icol, ibg, ...) {
        rect(
            xleft = ixmin, ybottom = iymin, xright = ixmax, ytop = iymax,
            lty = ilty,
            lwd = ilwd,
            border = icol,
            col = ibg
        )
    }
    return(fun)
}

#' Linear model plot type
#'
#' @description Type function for plotting a linear model fit.
#' Arguments are passed to \code{\link[stats]{lm}}.
#'
#' @inheritParams type_glm
#' @importFrom stats lm predict
#' @examples
#' # "lm" type convenience string
#' tinyplot(Sepal.Width ~ Petal.Width, data = iris, type = "lm")
#'
#' # Grouped model fits (here: illustrating an example of Simpson's paradox)
#' tinyplot(Sepal.Width ~ Petal.Width | Species, data = iris, type = "lm")
#' tinyplot_add(type = "p")
#'
#' # Use `type_lm()` to pass extra arguments for customization
#' tinyplot(Sepal.Width ~ Petal.Width, data = iris, type = type_lm(level = 0.8))
#' @export
type_lm = function(se = TRUE, level = 0.95) {
    assert_flag(se)
    out = list(
        draw = draw_ribbon(),
        data = data_lm(se = se, level = level),
        name = if (isTRUE(se)) "ribbon" else "l"
    )
    class(out) = "tinyplot_type"
    return(out)
}

data_lm = function(se, level, ...) {
    fun = function(datapoints, ...) {
        dat = split(datapoints, list(datapoints$facet, datapoints$by))
        dat = lapply(dat, function(x) {
            if (nrow(x) == 0) return(x)
            if (nrow(x) < 3) {
                x$y = NA
                return(x)
            }
            fit = lm(y ~ x, data = x)
            nd = data.frame(x = seq(min(x$x, na.rm = TRUE), max(x$x, na.rm = TRUE), length.out = 100))
            nd$by = x$by[1]
            nd$facet = x$facet[1]
            if (se == TRUE) {
                p = predict(fit, newdata = nd, se.fit = TRUE)
                p = ci(p$fit, p$se.fit, conf.level = level, fit$df.residual)
                nd$y = p$estimate
                nd$ymax = p$conf.high
                nd$ymin = p$conf.low
            } else {
                nd$y = predict(fit, newdata = nd)
            }
            nd
        })
        datapoints = do.call(rbind, dat)
        datapoints = datapoints[order(datapoints$facet, datapoints$by, datapoints$x), ]
        out = list(datapoints = datapoints)
        return(out)
    }
    return(fun)
}

#' Polygon plot type
#'
#' @description Type function for plotting polygons.
#' Arguments are passed to \code{\link[graphics]{polygon}}.
#'
#' @inheritParams graphics::polygon
#'
#' @examples
#' # "polygon" type convenience character string
#' tinyplot(1:9, c(2,1,2,1,NA,2,1,2,1), type = "polygon")
#'
#' # Use `type_polygon()` to pass extra arguments for customization
#' tinyplot(1:9, c(2,1,2,1,NA,2,1,2,1), type = type_polygon(density = c(10, 20)))
#'
#' @export
type_polygon = function(density = NULL, angle = 45) {
  out = list(
    draw = draw_polygon(density = density, angle = angle),
    data = NULL,
    name = "polygon"
  )
  class(out) = "tinyplot_type"
  return(out)
}

draw_polygon = function(density = density, angle = 45) {
    fun = function(ix, iy, icol, ibg, ilty = par("lty"), ilwd = par("lwd"), ...) {
        polygon(
            x = ix,
            y = iy,
            border = icol,
            col = ibg,
            lty = ilty,
            lwd = ilwd,
            density = density,
            angle = angle
        )
    }
    return(fun)
}

#' Add new elements to the current `tinyplot`
#'
#' @description
#' This convenience function grabs the preceding `tinyplot` call and updates it
#' with any new arguments that have been explicitly provided by the user. It
#' then injects `add=TRUE` and evaluates the updated call, thereby drawing a new
#' layer on top of the existing plot. `plt_add()` is a shorthand alias for
#' `tinyplot_add()`.
#'
#' @section Limitations:
#' - `tinyplot_add()` works reliably only when adding to a plot originally
#'   created using the [`tinyplot.formula`] method with a valid `data` argument.
#'   We cannot guarantee correct behavior if the original plot was created with
#'   the atomic [`tinyplot.default`] method, due to potential environment
#'   mismatches. (An exception is when the original plot arguments---`x`, `y`,
#'   etc.---are located in the global environment.)
#'
#' - Automatic legends for the added elements will be turned off.
#'
#' @param ... All named arguments override arguments from the previous calls.
#' Arguments not supplied to [tinyplot_add] remain unchanged from the previous
#' call.
#'
#' @examples
#' tinyplot(Sepal.Width ~ Sepal.Length | Species,
#'   facet = ~Species,
#'   data = iris)
#'
#' tinyplot_add(type = "lm") ## or : plt_add(type = "lm")
#'
#' ## Note: the previous function is equivalent to (but much more convenient
#' ## than) re-writing the full call with the new type and `add=TRUE`:
#'
#' # tinyplot(Sepal.Width ~ Sepal.Length | Species,
#' #          facet = ~Species,
#' #          data = iris,
#' #          type = "lm",
#' #          add = TRUE)
#'
#' @returns No return value, called for side effect of producing a plot.
#'
#' @export
tinyplot_add = function(...) {
  cal = getOption("tinyplot_last_call", default = NULL)

  ## TODO: remove the global option above and move to this when density is refactored
  # cal = get(".last_call", envir = get(".tinyplot_env", envir = parent.env(environment())))

  if (is.null(cal)) {
    stop("No previous tinyplot call found.")
  }

  args = list(...)
  for (n in names(args)) {
    if (n != "") {
      cal[[n]] = args[[n]]
    }
  }

  # allow first argument in tinyplot_add() to be unnamed
  if (isTRUE(names(args)[1] == "")) {
    cal[[2]] = args[[1]]
  }

  cal[["add"]] = TRUE
  eval(cal)
}

#' @export
#' @name plt_add
#' @rdname tinyplot_add
plt_add = tinyplot_add

#' Local polynomial regression plot type
#'
#' @description Type function for plotting a LOESS (LOcal regrESSion) fit.
#' Arguments are passed to \code{\link[stats]{loess}}.
#'
#' @inheritParams stats::loess
#' @param se logical. If `TRUE` (the default), confidence intervals are drawn.
#' @param level the confidence level required if `se = TRUE`. Default is 0.95.
#' @importFrom stats loess loess.control predict
#' @examples
#' # "loess" type convenience string
#' tinyplot(dist ~ speed, data = cars, type = "loess")
#'
#' # Use `type_loess()` to pass extra arguments for customization
#' tinyplot(dist ~ speed, data = cars, type = type_loess(span = 0.5, degree = 1))
#' @export
type_loess = function(
    span = 0.75,
    degree = 2,
    family = "gaussian",
    control = loess.control(),
    se = TRUE,
    level = 0.95
    ) {
    out = list(
        draw = draw_ribbon(),
        data = data_loess(span = span, degree = degree, family = family, control = control, se = se, level = level),
        name = if (isTRUE(se)) "ribbon" else "l"
    )
    class(out) = "tinyplot_type"
    return(out)
}

data_loess = function(span, degree, family, control, se, level, ...) {
    fun = function(datapoints, ...) {
        datapoints = split(datapoints, list(datapoints$facet, datapoints$by))
        datapoints = Filter(function(k) nrow(k) > 0, datapoints)
        datapoints = lapply(datapoints, function(dat) {
            fit = loess(y ~ x, data = dat, span = span, degree = degree, family = family, control = control)
            if (se == TRUE) {
                p = predict(fit, newdata = dat, se = TRUE)
                p = ci(p$fit, p$se.fit, conf.level = level, p$df)
                dat$y = p$estimate
                dat$ymax = p$conf.high
                dat$ymin = p$conf.low
            } else {
                dat$y = predict(fit, dat)
            }
            dat
        })
        datapoints = do.call(rbind, datapoints)
        datapoints = datapoints[order(datapoints$facet, datapoints$by, datapoints$x), ]
        out = list(datapoints = datapoints)
        return(out)
    }
    return(fun)
}

#' @rdname type_errorbar
#' @export
type_pointrange = function() {
  out = list(
    draw = draw_pointrange(),
    data = data_pointrange(),
    name = "p"
  )
  class(out) = "tinyplot_type"
  return(out)
}

draw_pointrange = function() {
    fun = function(ix, iy, ixmin, iymin, ixmax, iymax, icol, ibg, ipch, ilwd, cex, ...) {
        segments(
            x0 = ixmin,
            y0 = iymin,
            x1 = ixmax,
            y1 = iymax,
            col = icol,
            lwd = ilwd
        )
        draw_points()(ix = ix, iy = iy, icol = icol, ibg = ibg, ipch = ipch, ilwd = ilwd, cex = cex)
    }
    return(fun)
}

data_pointrange = function() {
    fun = function(datapoints, xlabs, ...) {
        if (is.character(datapoints$x)) datapoints$x = as.factor(datapoints$x)
        if (is.factor(datapoints$x)) {
            ## original data (i.e., no new sorting by factor)
            xlvls = unique(datapoints$x)
            datapoints$x = factor(datapoints$x, levels = xlvls)
            xlabs = seq_along(xlvls)
            names(xlabs) = xlvls
            datapoints$x = as.integer(datapoints$x)
        }
        datapoints$xmin = datapoints$x
        datapoints$xmax = datapoints$x
        out = list(
            x = datapoints$x,
            xlabs = xlabs,
            datapoints = datapoints)

        return(out)
    }
    return(fun)
}

sanitize_ribbon.alpha = function(ribbon.alpha) {
  assert_numeric(ribbon.alpha, len = 1, lower = 0, upper = 1, null.ok = TRUE)
  if (is.null(ribbon.alpha)) ribbon.alpha = .tpar[["ribbon.alpha"]]
  return(ribbon.alpha)
}

sanitize_type = function(type, x, y, dots) {
  if (inherits(type, "tinyplot_type")) {
    return(type)
  }

  known_types = c(
    "p", "l", "o", "b", "c", "h", "j", "s", "S", "n",
    "abline",
    "area",
    "bar", "barplot",
    "box", "boxplot",
    "density",
    "errorbar",
    "function",
    "glm",
    "hist", "histogram",
    "hline",
    "j", "jitter",
    "lines",
    "lm",
    "loess",
    "pointrange",
    "points",
    "polygon", "polypath",
    "qq",
    "rect",
    "ribbon",
    "ridge",
    "rug",
    "segments",
    "spine", "spineplot",
    "spline",
    "summary",
    "text",
    "violin",
    "vline"
  )
  assert_choice(type, known_types, null.ok = TRUE)

  if (is.null(type)) {
    if (!is.null(x) && (is.factor(x) || is.character(x)) && !(is.factor(y) || is.character(y))) {
      # enforce boxplot type for y ~ factor(x)
      type = type_boxplot
    } else if (is.factor(y) || is.character(y)) {
      # enforce spineplot type for factor(y) ~ x
      type = type_spineplot
    } else {
      type = "p"
    }
  }

  if (is.character(type)) type = switch(type,
    "abline"     = type_abline,
    "area"       = type_area,
    "bar"        = type_barplot,
    "barplot"    = type_barplot,
    "box"        = type_boxplot,
    "boxplot"    = type_boxplot,
    "density"    = type_density,
    "errorbar"   = type_errorbar,
    "function"   = type_function,
    "glm"        = type_glm,
    "hist"       = type_histogram,
    "histogram"  = type_histogram,
    "hline"      = type_hline,
    "j"          = type_jitter,
    "jitter"     = type_jitter,
    "lines"      = type_lines,
    "lm"         = type_lm,
    "loess"      = type_loess,
    "p"          = type_points,
    "pointrange" = type_pointrange,
    "points"     = type_points,
    "polygon"    = type_polygon,
    "polypath"   = type_polypath,
    "qq"         = type_qq,
    "rect"       = type_rect,
    "ribbon"     = type_ribbon,
    "ridge"      = type_ridge,
    "rug"        = type_rug,
    "segments"   = type_segments,
    "spine"      = type_spineplot,
    "spineplot"  = type_spineplot,
    "spline"     = type_spline,
    "summary"    = type_summary,
    "text"       = type_text,
    "violin"     = type_violin,
    "vline"      = type_vline,
    type           # default case
  )

  if (is.function(type)) {
    args = intersect(names(formals(type)), names(dots))
    args = if (length(args) >= 1L) dots[args] else list()
    type = do.call(type, args)
    type$dots = dots[setdiff(names(dots), names(args))]
  }

  if (inherits(type, "tinyplot_type")) return(type)

  out = list(draw = NULL, data = NULL, name = type)
  return(out)
}

## auxiliary functions for formula/facet parsing

tinyformula = function(formula, facet = NULL) {
  ## input
  ## - formula:       y ~ x or y ~ x | z or ~ x or ~ x | z
  ## - facet:         ~ a or ~ a + b or b ~ a
  ##
  ## output:
  ## - x:      ~ x
  ## - y:      NULL or ~ y
  ## - by:     NULL or ~ z or ~ z1 + z2 + ... (use interaction of all)
  ## - xfacet: NULL or ~ a or ~ a + b etc.
  ## - yfacet: NULL or ~ b
  ## - full:   e.g. ~ x + y + z + a + b

  ## preliminaries
  if (!inherits(formula, "formula")) formula = as.formula(formula)
  nf = length(formula)

  ## basic formula types
  x     = ~ x
  y     = if (nf == 2L) NULL else ~ y
  by    = if (!inherits(formula[[nf]], "call") || formula[[nf]][[1L]] != as.name("|")) NULL else ~ z
  if (is.null(facet) || !inherits(facet, "formula")) {
    xfacet = NULL
    yfacet = NULL
  } else {
    xfacet = ~ a
    yfacet = if (length(facet) == 2L) NULL else ~ b
  }

  ## fill with actual terms
  environment(x) = environment(formula)
  if (!is.null(y)) {
    environment(y) = environment(formula)
    y[[2L]] = formula[[2L]]
  }
  if (is.null(by)) {
    x[[2L]] = formula[[nf]]
  } else {
    environment(by) = environment(formula)
    by[[2L]] = formula[[nf]][[3L]]
    x[[2L]] = formula[[nf]][[2L]]
  }
  if (!is.null(xfacet)) {
    environment(xfacet) = environment(formula)
    xfacet[[2L]] = facet[[length(facet)]]
  }
  if (!is.null(yfacet)) {
    environment(yfacet) = environment(formula)
    yfacet[[2L]] = facet[[2L]]
  }

  ## combine everything
  full = x
  if (!is.null(y))      full[[2L]] = call("+", full[[2L]], y[[2L]])
  if (!is.null(by))     full[[2L]] = call("+", full[[2L]], by[[2L]])
  if (!is.null(xfacet)) full[[2L]] = call("+", full[[2L]], xfacet[[2L]])
  if (!is.null(yfacet)) full[[2L]] = call("+", full[[2L]], yfacet[[2L]])

  ## return list of all formulas
  return(list(
    x = x,
    y = y,
    by = by,
    xfacet = xfacet,
    yfacet = yfacet,
    full = full
  ))
}

tinyframe = function(formula, data, drop = FALSE) {
  ## input
  ## - formula: (sub-)formula
  ## - data: model.frame from full formula
  if (is.null(formula)) return(NULL)
  names = sapply(attr(terms(formula), "variables")[-1L], deparse, width.cutoff = 500L)
  data[, names, drop = drop]
}

# Copied from https://raw.githubusercontent.com/r-lib/evaluate/refs/heads/main/R/hooks.R
# license: MIT + file LICENSE

#' Set and remove hooks
#'
#' This interface wraps the base [setHook()] function to provide a return
#' value that makes it easy to undo.
#'
#' @param hooks a named list of hooks - each hook can either be a function or
#'   a list of functions.
#' @param action `"replace"`, `"append"` or `"prepend"`
#' @keywords internal
set_hooks <- function(hooks, action = "append") {
  old <- list()
  for (hook_name in names(hooks)) {
    old[[hook_name]] <- getHook(hook_name)
    setHook(hook_name, hooks[[hook_name]], action = action)
  }
  invisible(old)
}

#' @rdname set_hooks
#' @keywords internal
remove_hooks <- function(hooks) {
  for (hook_name in names(hooks)) {
    hook <- getHook(hook_name)
    if (length(hook) > 0) {
      for (fun in unlist(hooks[hook_name])) {
        hook[sapply(hook, identical, fun)] <- NULL
      }
    }
    setHook(hook_name, hook, "replace")
  }
}

#' @rdname type_ribbon
#' @export
type_area = function(alpha = NULL) {
  out = list(
    draw = NULL,
    data = data_area(alpha = alpha),
    name = "area"
  )
  class(out) = "tinyplot_type"
  return(out)
}

data_area = function(alpha = alpha) {
    ribbon.alpha = if (is.null(alpha)) .tpar[["ribbon.alpha"]] else (alpha)
    fun = function(datapoints, ...) {
        datapoints$ymax = datapoints$y
        datapoints$ymin = rep.int(0, nrow(datapoints))
        out = list(
            datapoints = datapoints,
            ymax = datapoints$ymax,
            ymin = datapoints$ymin,
            type = "ribbon",
            ribbon.alpha = ribbon.alpha
        )
        return(out)
    }
    return(fun)
}

rescale_num = function (x, from = NULL, to = NULL) {
  if (is.null(from)) from = range(x)
  if (is.null(to)) to = c(0, 1)
  (x - from[1])/diff(from) * diff(to) + to[1]
}

## Function for efficiently checking whether a vector has more than n unique
## values (uses a hash set approach for large vectors to check sequentially)
more_than_n_unique = function(x, n, small_vec_len = 1e3L) {
  len_x = length(x)
  # For "small" vectors, just use direct length(unique(x)) approach
  if (len_x <= small_vec_len) {
    return(length(unique(x)) > n)
  } else {
    # For larger vectors, use the hash set approach
    env = new.env(hash = TRUE, size = n)
    count = 0
    for (val in x) {
      if (!exists(as.character(val), env)) {
        assign(as.character(val), TRUE, env)
        count = count + 1
        if (count > n) {
          return(TRUE)
        }
      }
    }
    return(FALSE)
  }
}

## Null coalescing operator
if (getRversion() <= "4.4.0") {
   `%||%` = function(x, y) if (is.null(x)) y else x
}

## Function that computes an appropriate bandwidth kernel based on a string
## input
bw_fun = function(kernel, x) {
    kernel = tolower(kernel)
    switch(
        kernel,
        nrd0 = bw.nrd0(x),
        nrd  = bw.nrd(x),
        ucv  = bw.ucv(x),
        bcv  = bw.bcv(x),
        sj   = bw.SJ(x),
        stop("Invalid `bw` string. Choose from 'nrd0', 'nrd', 'ucv', 'bcv', or 'SJ'.")
    )
}

# calculate limits of each plot

lim_args = function(
    datapoints,
    xlim, ylim,
    xaxb = NULL, yaxb = NULL,
    xlim_user = FALSE, ylim_user = FALSE,
    type
) {

  if (is.null(xlim)) {
    xlim = range(c(datapoints[["x"]], datapoints[["xmin"]],
                   datapoints[["xmax"]]), finite = TRUE)
  }
  if (is.null(ylim)) {
    ylim = range(c(datapoints[["y"]], datapoints[["ymin"]],
                   datapoints[["ymax"]]), finite = TRUE)
  }

  if (identical(type, "boxplot")) {
    xlim = xlim + c(-0.5, 0.5)
  }

  if (!xlim_user && !is.null(xaxb) && type != "spineplot") xlim = range(c(xlim, xaxb))
  if (!ylim_user && !is.null(yaxb) && type != "spineplot") ylim = range(c(ylim, yaxb))

  out = list(xlim = xlim, ylim = ylim)
  return(out)
}

#' Operations on package load
#' @importFrom utils globalVariables
#' @param libname library name
#' @param pkgname package name name
#' @keywords internal
#' @noRd
.onLoad = function(libname, pkgname) {
  # https://stackoverflow.com/questions/12598242/global-variables-in-packages-in-r
  # https://stackoverflow.com/questions/49056642/r-how-to-make-variable-available-to-namespace-at-loading-time?noredirect=1&lq=1
  init_environment()
  init_tpar()
  set_environment_variable(".saved_par_before", NULL)
  set_environment_variable(".saved_par_after", NULL)
  set_environment_variable(".saved_par_first", NULL)
  set_environment_variable(".last_call", NULL)
  set_environment_variable(".tpar_hooks", NULL)

  globalVariables(c(
    "add",
    "asp",
    "axes",
    "by_continuous",
    "by_ordered",
    "cex_fct_adj",
    "dots",
    "draw",
    "facet_bg",
    "facet_border",
    "facet_col",
    "facet_font",
    "facet_newlines",
    "facet_rect",
    "facet_text",
    "facet.args",
    "facet",
    "facets",
    "fill",
    "flip",
    "frame.plot",
    "has_legend",
    "iby",
    "ifacet",
    "nfacet_cols",
    "nfacet_rows",
    "nfacets",
    "ngrps",
    "oxaxis",
    "oyaxis",
    "ribbon.alpha",
    "split_data",
    "type",
    "x",
    "xaxl",
    "xaxs",
    "xaxt",
    "xlabs",
    "xlim",
    "xlim_user",
    "xlvls",
    "xmax",
    "xmin",
    "y",
    "yaxl",
    "yaxs",
    "yaxt",
    "ylabs",
    "ylim",
    "ylim_user",
    "ymax",
    "ymin"
  ))
}

setup_device = function(file, width, height) {
  # write to file
  if (!is.null(file)) {
    filepath = file
    filewidth = width
    fileheight = height
    if (is.null(filewidth)) filewidth = .tpar[["file.width"]]
    if (is.null(fileheight)) fileheight = .tpar[["file.height"]]
    fileres = .tpar[["file.res"]]
    # catch to close interactive device if one isn't already open
    fkdev = is.null(dev.list())
    # grab existing device pars to pass on to next one
    dop = par(no.readonly = TRUE)
    # close interactive device if not already open
    if (isTRUE(fkdev)) dev.off()
    exttype = file_ext(filepath)
    if (exttype == "pdf" && .tpar[["cairo"]]) {
      exttype = "cairo"
    } else if (exttype == "jpg") {
      exttype = "jpeg"
    }
    switch(exttype,
      png = png(filepath, width = filewidth, height = fileheight, units = "in", res = fileres),
      jpeg = jpeg(filepath, width = filewidth, height = fileheight, units = "in", res = fileres),
      pdf = pdf(filepath, width = filewidth, height = fileheight),
      cairo = cairo_pdf(filepath, width = filewidth, height = fileheight),
      svg = svg(filepath, width = filewidth, height = fileheight),
      stop("\nUnsupported file extension. Only '.png', '.jpg', '.pdf', or '.svg' are allowed.\n")
    )
    dop$new = FALSE # catch for some interfaces
    par(dop)

  # interactive plot with user-specified width/height
  } else if (!is.null(width) || !is.null(height)) {
    devwidth = width
    devheight = height
    # if one of width or height is missing, set equal to the other
    if (is.null(devwidth)) devwidth = devheight
    if (is.null(devheight)) devheight = devwidth
    # catch to close interactive device if one isn't already open
    fkdev = is.null(dev.list())
    # grab existing device pars to pass on to next one
    dop = par(no.readonly = TRUE)
    # close interactive device if not already open
    if (isTRUE(fkdev)) dev.off()
    dev.new(width = devwidth, height = devheight)
    dop$new = FALSE # catch for some interfaces
    par(dop)
  }
}

init_environment = function() {
  tnypltptns = parent.env(environment())
  assign(".tinyplot_env", new.env(), envir = tnypltptns)
  .tpar = new.env()
  assign(".tpar", .tpar, envir = tnypltptns)
}

get_environment_variable = function(name) {
  get(name, envir = get(".tinyplot_env", envir = parent.env(environment())))
}

set_environment_variable = function(name, value) {
  assign(name, value, envir = get(".tinyplot_env", envir = parent.env(environment())))
}

function(adj = NULL, pos = NULL, offset = 0.5, vfont = NULL, font = NULL, xpd = NULL, srt = 0) {}

This code segment functions to: Configure graphical parameters for rendering text elements within a coordinate system and execute the display of formatted annotations with positional adjustments, rotation settings, and font specifications.

```r
[TASK_BEGIN]
draw_text = function(adj = NULL, pos = NULL, offset = 0.5, vfont = NULL, font = NULL, xpd = NULL, srt = 0) {
  function(elements, ...) {
    with(elements, {
      graphics::text(
        x = coords$x,
        y = coords$y,
        labels = data$datapoints$labels,
        adj = adj,
        pos = pos,
        offset = offset,
        vfont = vfont,
        font = font,
        xpd = xpd,
        srt = srt
      )
    })
  }
}
[TASK_END]
```