splot coverage - 69.53%

Files
Source

#' Split Plot
#'
#' A plotting function aimed at automating some common visualization tasks in order to ease data exploration.
#' @param y a formula (see note), or the primary variable(s) to be shown on the y axis (unless \code{x} is not specified).
#'   When not a formula, this can be one or more variables as objects, or names in \code{data}.
#' @param data a \code{data.frame} to pull variables from. If variables aren't found in \code{data}, they will be looked
#'   for in the environment.
#' @param su a subset to all variables, applied after they are all retrieved from \code{data} or the environment.
#' @param type determines the type of plot to make, between \code{"bar"}, \code{"line"}, \code{"density"}, or
#'   \code{"scatter"}. If \code{"density"}, \code{x} is ignored. Anything including the first letter of each is accepted
#'   (e.g., \code{type='l'}).
#' @param split how to split any continuous variables (those with more than \code{lim} levels as factors). Default is
#'   \code{"median"}, with \code{"mean"}, \code{"standard deviation"}, \code{"quantile"}, or numbers as options. If
#'   numbers, the variable is either cut at each value in a vector, or broken into roughly equal chunks. Entering an
#'   integer (e.g., \code{split = 3L}) that is greater than 1 will force splitting into segments. Otherwise variables will
#'   be split by value if you enter a single value for split and there are at least two data less than or equal to and
#'   greater than the split, or if you enter more than 1 value for split. If a numeric split is not compatible with
#'   splitting by value or segment, splitting will default to the median.
#' @param levels a list with entries corresponding to variable names, used to rename and/or reorder factor levels. To
#'   reorder a factor, enter a vector of either numbers or existing level names in the new order (e.g.,
#'   \code{levels =} \code{list(var =} \code{c(3,2,1))}). To rename levels of a factor, enter a character vector the same
#'   length as the number of levels. To rename and reorder, enter a list, with names as the first entry, and order as the
#'   second entry (e.g., \code{levels =} \code{list(var =} \code{list(c('a','b','c'),} \code{c(3,2,1)))}). This happens
#'   after variables are split, so names and orders should correspond to the new split levels of split variables. For
#'   example, if a continuous variable is median split, it now has two levels ('Under Median' and 'Over Median'), which are
#'   the levels reordering or renaming would apply to. Multiple variables entered as \code{y} can be renamed and sorted
#'   with an entry titled \code{'mv'}.
#' @param sort specified the order of character or factor \code{x} levels. By default, character or factor \code{x} levels
#'   are sorted alphabetically. \code{FALSE} will prevent this (preserving entered order). \code{TRUE} or \code{'d'} will
#'   sort by levels of \code{y} in decreasing order, and anything else will sort in increasing order.
#' @param error string; sets the type of error bars to show in bar or line plots, or turns them off. If \code{FALSE}, no
#'   error bars will be shown. Otherwise, the default is \code{"standard error"} (\code{'^s'}), with \code{"confidence
#'   intervals"} (anything else) as an option.
#' @param error.color color of the error bars. Default is \code{'#585858'}.
#' @param error.lwd line weight of error bars. Default is 2.
#' @param lim numeric; checked against the number of factor levels of each variable. Used to decide which variables should
#'   be split, which colors to use, and when to turn off the legend. Default is \code{9}. If set over \code{20}, \code{lim}
#'   is treated as infinite (set to \code{Inf}).
#' @param lines logical or a string specifying the type of lines to be drawn in scatter plots. By default (and whenever
#'   \code{cov} is not missing, or if \code{lines} matches \code{'^li|^lm|^st'}), a prediction line is fitted with
#'   \code{\link[stats]{lm}}. For (potentially) bendy lines, \code{'loess'} (matching \code{'^loe|^po|^cu'}) will use
#'   \code{\link[stats]{loess}}, and \code{'spline'} (\code{'^sm|^sp|^in'}) will use \code{\link[stats]{smooth.spline}}.
#'   If \code{y} is not numeric and has only 2 levels, \code{'probability'} (\code{'^pr|^log'}) will draw probabilities
#'   estimated by a logistic regression (\code{glm(y ~} \code{x, binomial)}). \code{'connected'} (\code{'^e|^co|^d'}) will
#'   draw lines connecting all points, and \code{FALSE} will not draw any lines.
#' @param colors sets a color theme or manually specifies colors. Default theme is \code{"pastel"}, with \code{"dark"} and
#'   \code{"bright"} as options; these are passed to \code{\link{splot.color}}. If set to \code{"grey"}, or if \code{by}
#'   has more than 9 levels, a grey scale is calculated using \code{\link[grDevices]{gray}}. See the \code{col} parameter
#'   in \code{\link[graphics]{par}} for acceptable manual inputs. To set text and axis colors, \code{col} sets outside
#'   texts (title, sud, labx, laby, and note), \code{col.sub} or \code{col.main} sets the frame titles, and \code{col.axis}
#'   sets the axis text and line colors. To set the color of error bars, use \code{error.color}. For histograms, a vector of
#'   two colors would apply to the density line and bars separately (e.g., for \code{color =} \code{c('red','green')}, the
#'   density line would be red and the histogram bars would be green). See the \code{color.lock} and \code{color.offset}
#'   arguments for more color controls.
#' @param colorby a variable or list of arguments used to set colors and the legend, alternatively to \code{by}. If
#'   \code{by} is not missing, \code{colorby} will be reduced to only the unique combinations of \code{by} and \code{colorby}.
#'   For example, if \code{by} is a participant ID with multiple observations per participant, and \code{by} is a condition
#'   ID which is the same for all observations from a given participant, \code{colorby} would assign a single color to each
#'   participant based on their condition. A list will be treated as a call to \code{\link{splot.color}}, so arguments can be
#'   entered positionally or by name. Data entered directly into splot can be accessed by position name preceded by a
#'   period. For example, \code{splot(rnorm(100),} \code{colorby=.y)} would draw a histogram, with bars colored by the value
#'   of \code{y} (\code{rnorm(100)} in this case).
#' @param ... passes additional arguments to \code{\link[graphics]{par}} or \code{\link[graphics]{legend}}. Arguments before
#'   this can be named partially; those after must by fully named.
#' @param colorby.leg logical; if \code{FALSE}, a legend for \code{colorby} is never drawn. Otherwise, a legend for
#'   \code{colorby} will be drawn if there is no specified \code{by}, or for non-scatter plots (overwriting the usual legend).
#' @param color.lock logical; if \code{FALSE}, colors will not be adjusted to offset lines from points or histogram bars.
#' @param color.offset how much points or histogram bars should be offset from the initial color used for lines. Default is
#'   1.1; values greater than 1 lighten, and less than 1 darken.
#' @param color.summary specifies the function used to collapse multiple colors for a single display. Either a string
#'   matching one of \code{'mean'} (which uses \code{\link{splot.colormean}} to average RGB values), \code{'median'} (
#'   which treats codes as ordered, and selects that at the rounded median), or \code{'mode'} (which selects the most
#'   common code), or a function which takes color codes in its first argument, and outputs a single color code as a
#'   character.
#' @param opacity a number between 0 and 1; sets the opacity of points, lines, and bars. Semi-opaque lines will sometimes
#'   not be displayed in the plot window, but will show up when the plot is written to a file.
#' @param dark logical; if \code{TRUE}, sets text and axis colors to \code{"white"}. Defaults to the \code{splot.dark}
#'   option.
#' @param x secondary variable, to be shown in on the x axis. If not specified, \code{type} will be set to \code{'density'}.
#'   If \code{x} is a factor or vector of characters, or has fewer than \code{lim} levels when treated as a factor,
#'   \code{type} will be set to \code{'line'} unless specified.
#' @param by the 'splitting' variable within each plot, by which the plotted values of \code{x} and \code{y} will be
#'   grouped.
#' @param between a single object or name, or two in a vector (e.g., \code{c(b1, b2)}), the levels of which will determine
#'   the number of plot windows to be shown at once (the cells in a matrix of plots; levels of the first variable as rows,
#'   and levels of the second as columns).
#' @param cov additional variables used for adjustment. Bar and line plots include all \code{cov} variables in their
#'   regression models (via \code{\link[stats]{lm}}, e.g., \code{lm(y ~ 0 + x + cov1 + cov2)}) as covariates. Scatter plots
#'   with lines include all \code{cov} variables in the regression model to adjust the prediction line (e.g.,
#'   \code{lm(y ~ x + x^2)}).
#'   \code{\link[graphics]{par}} options \code{col}, \code{mfrow}, \code{oma}, \code{mar}, \code{mgp}, \code{font.main},
#'   \code{cex.main}, \code{font.lab}, \code{tcl}, \code{pch}, \code{lwd}, and \code{xpd} are all set within the function,
#'   but will be overwritten if they are included in the call. For example, \code{col} sets font colors in this case
#'   (as opposed to \code{colors} which sets line and point colors). The default is \code{'#303030'} for a nice dark grey,
#'   but maybe you want to lighten that up: \code{col='#606060'}. After arguments have been applied to
#'   \code{\link[graphics]{par}}, if any have not been used and match a \code{\link[graphics]{legend}} argument, these will
#'   be applied to \code{\link[graphics]{legend}}.
#' @param line.type a character setting the style of line (e.g., with points at joints) to be drawn in line plots. Default
#'   is \code{'b'} if \code{error} is \code{FALSE}, and \code{'l'} otherwise. See the \code{line} argument of
#'   \code{\link[graphics]{plot.default}} for options. \code{line.type='c'} can look nice when there aren't a lot of
#'   overlapping error bars.
#' @param mv.scale determines whether to center and scale multiple \code{y} variables. Does not center or scale by default.
#'   Anything other than \code{'none'} will mean center each numeric \code{y} variable. Anything matching \code{'^t|z|sc'}
#'   will also scale.
#' @param mv.as.x logical; if \code{TRUE}, variable names are displayed on the x axis, and \code{x} is treated as \code{by}.
#' @param save logical; if \code{TRUE}, an image of the plot is saved to the current working directory.
#' @param format the type of file to save plots as. Default is \code{cairo_pdf}; see
#'   \code{\link[grDevices]{Devices}} for options.
#' @param dims a vector of 2 values (\code{c(width, height)}) specifying the dimensions of a plot to save in inches or
#'   pixels depending on \code{format}. Defaults to the dimensions of the plot window.
#' @param file.name a string with the name of the file to be save (excluding the extension, as this is added depending on
#'   \code{format}).
#' @param myl sets the range of the y axis (\code{ylim} of \code{\link{plot}} or \code{\link[graphics]{barplot}}).
#'   If not specified, this will be calculated from the data.
#' @param mxl sets the range of the x axis (\code{xlim} of \code{\link{plot}}). If not specified, this will be
#'   calculated from the data.
#' @param autori logical; if \code{FALSE}, the origin of plotted bars will be set to 0. Otherwise, bars are adjusted such
#'   that they extend to the bottom of the y axis.
#' @param xlas,ylas numeric; sets the orientation of the x- and y-axis labels. See \code{\link[graphics]{par}}.
#' @param xaxis,yaxis logical; if \code{FALSE}, the axis will not be drawn.
#' @param breaks determines the width of histogram bars. See \code{\link[graphics]{hist}}.
#' @param density.fill logical; \code{FALSE} will turn off polygon fills when they are displayed, \code{TRUE} will replace
#'   histograms with polygons.
#' @param density.opacity opacity of the density polygons, between 0 and 1.
#' @param density.args list of arguments to be passed to \code{\link[stats]{density}}.
#' @param leg sets the legend inside or outside the plot frames (when a character matching \code{'^i'}, or a character
#'   matching \code{'^o'} or a number respectively), or turns it off (when \code{FALSE}). When inside, a legend is drawn in
#'   each plot frame. When outside, a single legend is drawn either to the right of all plot frames, or within an empty
#'   plot frame. By default, this will be determined automatically, tending to set legends outside when there are multiple
#'   levels of \code{between}. A number will try and set the legend in an empty frame within the grid of plot frames. If
#'   there are no empty frames, the legend will just go to the side as if \code{leg='outside'}.
#' @param lpos sets the position of the legend within its frame (whether inside or outside of the plot frames) based on
#'   keywords (see \code{\link[graphics]{legend}}. By default, when the legend is outside, \code{lpos} is either
#'   \code{'right'} when the legend is in a right-hand column, or \code{'center'} when in an empty plot frame. When the
#'   legend is inside and \code{lpos} is not specified, the legend will be placed automatically based on the data. Set to
#'   \code{'place'} to manually place the legend; clicking the plot frame will set the top left corner of the legend.
#' @param lvn level variable name. Logical: if \code{FALSE}, the names of by and between variables will not be shown
#'   before their level (e.g., for a sex variable with a "female" level, "sex: female" would become "female" above each
#'   plot window).
#' @param leg.title sets the title of the legend (which is the by variable name by default), or turns it off with
#'   \code{FALSE}.
#' @param leg.args a list passing arguments to the \code{\link[graphics]{legend}} call.
#' @param title logical or a character: if \code{FALSE}, the main title is turned off. If a character, this will be shown
#'   as the main title.
#' @param labx,laby logical or a character: if \code{FALSE}, the label on the x axis is turned off. If a character, this
#'   will be shown as the axis label.
#' @param lty logical or a vector: if \code{FALSE}, lines are always solid. If a vector, changes line type based on each
#'   value. Otherwise loops through available line types, see \code{\link[graphics]{par}}.
#' @param lwd numeric; sets the weight of lines in line, density, and scatter plots. Default is 2. See
#'   \code{\link[graphics]{par}}.
#' @param sub affects the small title above each plot showing \code{between} levels; text replaces it, and \code{FALSE}
#'   turns it off.
#' @param note logical; if \code{FALSE}, the note at the bottom about splits and/or lines or error bars is turned off.
#' @param font named numeric vector: \code{c(title,sud,leg,leg.title,note)}. Sets the font of the title, su display, legend
#'   levels and title, and note. In addition, \code{font.lab} sets the x and y label font, \code{font.sub} sets the font of
#'   the little title in each panel, \code{font.axis} sets the axis label font, and \code{font.main} sets the between level/n
#'   heading font; these are passed to \code{\link[graphics]{par}}. See the input section.
#' @param cex named numeric vector: \code{c(title,sud,leg,note,points)}. Sets the font size of the title, su display, legend,
#'   note, and points. In addition, \code{cex.lab} sets the x and y label size, \code{cex.sub} sets the size of the little
#'   title in each panel, \code{cex.axis} sets the axis label size, and \code{cex.main} sets the between level/n heading size;
#'   these are passed to \code{\link[graphics]{par}}. See the input section.
#' @param sud affects the heading for subset and covariates/line adjustments (su display); text replaces it, and
#'   \code{FALSE} turns it off.
#' @param ndisp logical; if \code{FALSE}, n per level is no longer displayed in the subheadings.
#' @param labels logical; if \code{FALSE}, sets all settable text surrounding the plot to \code{FALSE} (just so you don't
#'   have to set all of them if you want a clean frame).
#' @param labels.filter a regular expression string to be replaced in label texts with a blank space. Default is
#'   \code{'_'}, so underscores appearing in the text of labels are replace with blank spaces. Set to
#'   \code{FALSE} to prevent all filtering.
#' @param labels.trim numeric or logical; the maximum length of label texts (in number of characters). Default is 20, with
#'   any longer labels being trimmed. Set to \code{FALSE} to prevent any trimming.
#' @param points logical; if \code{FALSE}, the points in a scatter plot are no longer drawn.
#' @param points.first logical; if \code{FALSE}, points are plotted after lines are drawn in a scatter plot, placing lines
#'   behind points. This does not apply to points or lines added in \code{add}, as that is always evaluated after the main
#'   points and lines are drawn.
#' @param byx logical; if \code{TRUE} (default) and \code{by} is specified, regressions for bar or line plots compare
#'   levels of \code{by} for each level of \code{x}. This makes for more intuitive error bars when comparing levels of
#'   \code{by} within a level of \code{x}; otherwise, the model is comparing the difference between the first level of
#'   \code{x} and each of its other levels.
#' @param drop named logical vector: \code{c(x,by,bet)}. Specifies how levels with no data should be treated. All are
#'   \code{TRUE} by default, meaning only levels with data will be presented, and the layout of \code{between} levels
#'   will be minimized. \code{x} only applies to bar or line plots. \code{by} relates to levels presented in the legend.
#'   If \code{bet} is \code{FALSE}, the layout of \code{between} variables will be strict, with levels of \code{between[1]}
#'   as rows, and levels of \code{between[2]} as columns -- if there are no data at an intersection of levels, the
#'   corresponding panel will be blank. See the input section.
#' @param prat panel ratio, referring to the ratio between plot frames and the legend frame when the legend is out. A
#'   single number will make all panels of equal width. A vector of two numbers will adjust the ratio between plot panels
#'   and the legend panel. For example, \code{prat=c(3,1)} makes all plot panels a relative width of 3, and the legend frame
#'   a relative width of 1.
#' @param check.height logical; if \code{FALSE}, the height of the plot frame will not be checked before plotting is
#'   attempted. The check tries to avoid later errors, but may prevent plotting when a plot is possible.
#' @param model logical; if \code{TRUE}, the summary of an interaction model will be printed. This model won't always align
#'   with what is plotted since variables may be treated differently, particularly in the case of interactions.
#' @param options a list with named arguments, useful for setting temporary defaults if you plan on using some of the same
#'   options for multiple plots (e.g., \code{opt = list(}\code{type = 'bar',} \code{colors = 'grey',}
#'   \code{bg = '#999999');} \code{splot(x ~ y,} \code{options = opt)}).
#'   use \code{\link{quote}} to include options that are to be evaluated within the function (e.g.,
#'   \code{opt =} \code{list(su =} \code{quote(y > 0))}).
#' @param add evaluated within the function, so you can refer to the objects that are returned, to variable names (those
#'   from an entered data frame or entered as arguments), or entered data by their position, preceded by '.' (e.g.,
#'   \code{mod =} \code{lm(.y~.x)}). Useful for adding things like lines to a plot while the parameters are still
#'   those set by the function (e.g., \code{add =} \code{abline(v =} \code{mean(x),} \code{xpd = FALSE)} for a vertical
#'   line at the mean of x).
#'
#' @return A list containing data and settings is invisibly returned, which might be useful to check for errors.
#' Each of these objects can also be pulled from within \code{add}:
#' \tabular{ll}{
#'   \code{dat} \tab a \code{data.frame} of processed, unsegmented data.\cr
#'   \code{cdat} \tab a \code{list} of \code{list}s of \code{data.frame}s of processed, segmented data.\cr
#'   \code{txt} \tab a \code{list} of variable names. used mostly to pull variables from \code{data} or the environment.\cr
#'   \code{ptxt} \tab a \code{list} of processed variable and level names. Used mostly for labeling.\cr
#'   \code{seg} \tab a \code{list} containing segmentation information (such as levels) for each variable.\cr
#'   \code{ck} \tab a \code{list} of settings.\cr
#'   \code{lega} \tab a \code{list} of arguments that were or would have been passed to \code{\link[graphics]{legend}}.\cr
#'   \code{fmod} \tab an \code{lm} object if \code{model} is \code{TRUE}, and the model succeeded.
#' }
#'
#' @section Input:
#' \strong{formulas}
#'
#' When \code{y} is a formula (has a \code{~}), other variables will be pulled from it:
#'
#' \code{y ~ x * by * between[1] * between[2] + cov[1] + cov[2] + cov[n]}
#'
#' If \code{y} has multiple variables, \code{by} is used to identify the variable (it becomes a factor with variable names
#' as levels), so anything entered as \code{by} is treated as \code{between[1]}, \code{between[1]} is moved to
#' \code{between[2]}, and \code{between[2]} is discarded with a message.
#'
#' \strong{named vectors}
#'
#' Named vector arguments like \code{font}, \code{cex}, and \code{drop} can be set with a single value, positionally, or
#' with names. If a single value is entered (e.g., \code{drop = FALSE}), this will be applied to each level (i.e.,
#' \code{c(x = FALSE, by = FALSE, bet = FALSE)}). If more than one value is entered, these will be treated positionally
#' (e.g., \code{cex =} \code{c(2, 1.2)} would be read as \code{c(title = 2, sud = 1.2, leg = .9, note = .7, points = 1)}).
#' If values are named, only named values will be set, with other defaults retained (e.g., \code{cex =} \code{c(note = 1.2)}
#' would be read as \code{c(title = 1.5, sud = .9, leg = .9, note = 1.2, points = 1)}).
#'
#' @note
#' \strong{x-axis levels text}
#'
#' If the text of x-axis levels (those corresponding to the levels of \code{x}) are too long, they are hidden before
#' overlapping. To try and avoid this, by default longer texts are trimmed (dictated by \code{labels.trim}), and at some
#' point the orientation of level text is changed (settable with \code{xlas}), but you may still see level text missing.
#' To make these visible, you can reduce \code{labels.trim} from the default of 20 (or rename the levels of that variable),
#' make the level text vertical (\code{xlas = 3}), or expand your plot window if possible.
#'
#' \strong{missing levels, lines, and/or error bars}
#'
#' By default (if \code{drop = TRUE}), levels of \code{x} with no data are dropped, so you may not see every level of your
#' variable, at all or at a level of \code{by} or \code{between}. Sometimes error bars cannot be estimated (if, say, there
#' is only one observation at the given level), but lines are still drawn in these cases, so you may sometimes see levels
#' without error bars even when error bars are turned on. Sometimes (particularly when \code{drop['x']} is \code{FALSE}),
#' you might see floating error bars with no lines drawn to them, or what appear to be completely empty levels. This
#' happens when there is a missing level of \code{x} between two non-missing levels, potentially making an orphaned level
#' (if a non-missing level is surrounded by missing levels). If there are no error bars for this orphaned level, by default
#' nothing will be drawn to indicate it. If you set \code{line.type} to \code{'b'} (or any other type with points), a point
#' will be drawn at such error-bar-less, orphaned levels.
#'
#' \strong{unexpected failures}
#'
#' splot tries to clean up after itself in the case of an error, but you may still run into errors that break things before
#' this can happen. If after a failed plot you find that you're unable to make any new plots, or new plots are drawn over
#' old ones, you might try entering \code{dev.off()} into the console. If new plots look off (splot's
#' \code{\link[graphics]{par}} settings didn't get reset), you may have to close the plot window to reset
#' \code{\link[graphics]{par}} (if you're using RStudio, Plots > "Remove Plot..." or "Clear All..."), or restart R.
#'
#' @examples
#' # simulating data
#' n <- 2000
#' dat <- data.frame(sapply(c("by", "bet1", "bet2"), function(c) sample(0:1, n, TRUE)))
#' dat$x <- with(
#'   dat,
#'   rnorm(n) + by * -.4 + by * bet1 * -.3 + by * bet2 *
#'     .3 + bet1 * bet2 * .9 - .8 + rnorm(n, 0, by)
#' )
#' dat$y <- with(
#'   dat,
#'   x * .2 + by * .3 + bet2 * -.6 + bet1 * bet2 * .8 + x *
#'     by * bet1 * -.5 + x * by * bet1 * bet2 * -.5
#'     + rnorm(n, 5) + rnorm(n, -1, .1 * x^2)
#' )
#'
#' # looking at the distribution of y between bets split by by
#' splot(y, by = by, between = c(bet1, bet2), data = dat)
#'
#' # looking at quantile splits of y in y by x
#' splot(y ~ x * y, dat, split = "quantile")
#'
#' # looking at y by x between bets
#' splot(y ~ x, dat, between = c(bet1, bet2))
#'
#' # sequentially adding levels of split
#' splot(y ~ x * by, dat)
#' splot(y ~ x * by * bet1, dat)
#' splot(y ~ x * by * bet1 * bet2, dat)
#'
#' # same as the last but entered by name
#' splot(y, x = x, by = by, between = c(bet1, bet2), data = dat)
#'
#' # zooming in on one of the windows
#' splot(y ~ x * by, dat, bet1 == 1 & bet2 == 0)
#'
#' # comparing an adjusted lm prediction line with a loess line
#' # this could also be entered as y ~ poly(x,3)
#' splot(y ~ x + x^2 + x^3, dat, bet1 == 1 & bet2 == 0 & by == 1, add = {
#'   lines(x[order(x)], loess(y ~ x)$fitted[order(x)], lty = 2)
#'   legend("topright", c("lm", "loess"), lty = c(1, 2), lwd = c(2, 1), bty = "n")
#' })
#'
#' # looking at different versions of x added to y
#' splot(cbind(
#'   Raw = y + x,
#'   Sine = y + sin(x),
#'   Cosine = y + cos(x),
#'   Tangent = y + tan(x)
#' ) ~ x, dat, myl = c(-10, 15), lines = "loess", laby = "y + versions of x")
#'
#' @export
#' @importFrom grDevices grey dev.copy dev.size dev.off cairo_pdf adjustcolor colors col2rgb
#' @importFrom graphics axis axTicks hist legend lines text mtext plot barplot par points arrows strwidth layout plot.new
#' locator strheight polygon abline
#' @importFrom stats density median quantile sd lm glm confint update loess smooth.spline formula as.formula predict
#' var binomial

splot <- function(
  y,
  data = NULL,
  su = NULL,
  type = "",
  split = "median",
  levels = list(),
  sort = NULL,
  error = "standard",
  error.color = "#585858",
  error.lwd = 2,
  lim = 9,
  lines = TRUE,
  ...,
  colors = "pastel",
  colorby = NULL,
  colorby.leg = TRUE,
  color.lock = FALSE,
  color.offset = 1.1,
  color.summary = "mean",
  opacity = 1,
  dark = getOption("splot.dark", FALSE),
  x = NULL,
  by = NULL,
  between = NULL,
  cov = NULL,
  line.type = "l",
  mv.scale = "none",
  mv.as.x = FALSE,
  save = FALSE,
  format = cairo_pdf,
  dims = dev.size(),
  file.name = "splot",
  myl = NULL,
  mxl = NULL,
  autori = TRUE,
  xlas = 0,
  ylas = 1,
  xaxis = TRUE,
  yaxis = TRUE,
  breaks = "sturges",
  density.fill = TRUE,
  density.opacity = .4,
  density.args = list(),
  leg = "outside",
  lpos = "auto",
  lvn = TRUE,
  leg.title = TRUE,
  leg.args = list(),
  title = TRUE,
  labx = TRUE,
  laby = TRUE,
  lty = TRUE,
  lwd = 2,
  sub = TRUE,
  ndisp = TRUE,
  note = TRUE,
  font = c(title = 2, sud = 1, leg = 1, leg.title = 2, note = 3),
  cex = c(title = 1.5, sud = .9, leg = .9, note = .7, points = 1),
  sud = TRUE,
  labels = TRUE,
  labels.filter = "_",
  labels.trim = 20,
  points = TRUE,
  points.first = TRUE,
  byx = TRUE,
  drop = c(x = TRUE, by = TRUE, bet = TRUE),
  prat = c(1, 1),
  check.height = TRUE,
  model = FALSE,
  options = NULL,
  add = NULL
) {
  # parsing input and preparing data
  if (check.height && dev.size()[2] < 1.7) {
    stop(
      "the plot window seems too short; increase the height of the plot window, or set check.height to FALSE",
      call. = FALSE
    )
  }
  if (!missing(options) && is.list(options) && length(options) != 0) {
    a <- as.list(match.call())[-1]
    options <- tryCatch(options, error = function(e) NULL)
    if (is.null(options)) {
      stop("could not find options")
    }
    return(do.call(
      splot,
      c(a[names(a) != "options"], options[!names(options) %in% names(a)]),
      envir = parent.frame()
    ))
  }
  if (!labels) {
    title <- sud <- sub <- labx <- laby <- note <- FALSE
  }
  opt_saf <- getOption("stringsAsFactors")
  on.exit(options(stringsAsFactors = opt_saf))
  options(stringsAsFactors = FALSE)
  ck <- list(
    ff = list(bet = FALSE, cov = FALSE),
    t = if (grepl("^b|^l", type, TRUE)) {
      1
    } else if (grepl("^d", type, TRUE)) {
      2
    } else {
      3
    },
    b = grepl("^b", type, TRUE),
    tt = !missing(type) && !grepl("^b|^l", type, TRUE),
    d = !missing(data) && !is.null(data),
    su = !missing(su),
    c = !missing(cov),
    co = missing(colors),
    cb = !missing(colorby),
    cblegm = missing(colorby.leg),
    cbleg = is.logical(colorby.leg) && colorby.leg,
    poly = missing(density.fill) || (!is.logical(density.fill) || density.fill),
    polyo = !missing(density.fill) || !missing(density.opacity),
    e = grepl("^s", error, TRUE),
    el = !(is.logical(error) && !error),
    sp = if (!is.character(split)) {
      4
    } else if (grepl("^mea|^av", split, TRUE)) {
      1
    } else if (grepl("^q", split, TRUE)) {
      2
    } else {
      ifelse(grepl("^s", split, TRUE), 3, 4)
    },
    ly = !(is.logical(laby) && !laby) || is.character(laby),
    lys = is.character(laby),
    lx = !(is.logical(labx) && !labx) || is.character(labx),
    line = substitute(lines),
    lty = is.logical(lty),
    ltym = missing(lty),
    ltm = missing(line.type),
    leg = if (is.logical(leg) && !leg) {
      0
    } else if (!is.character(leg) || grepl("^o", leg, TRUE)) {
      1
    } else {
      2
    },
    legm = missing(leg),
    legt = !(is.logical(leg.title) && !leg.title),
    lp = is.character(lpos) && grepl("^a", lpos, TRUE),
    lpm = is.character(lpos) && grepl("^p|^m", lpos, TRUE),
    mod = !missing(x) && model,
    note = !is.character(note),
    mv = FALSE,
    mlvn = missing(lvn),
    opacity = !missing(opacity) && opacity <= 1 && opacity > 0,
    mai = FALSE
  )
  if (ck$lpm) {
    lpos <- "center"
  }
  if (ck$d && !is.data.frame(data)) {
    data <- if (!is.matrix(data) && !is.list(data)) {
      as.data.frame(as.matrix(data))
    } else {
      as.data.frame(data)
    }
  }
  ck$ltck <- (is.logical(ck$line) && ck$line) || !grepl("^F", ck$line)
  if (!ck$ltck && ck$note) {
    note <- FALSE
  }
  ck$ltco <- if (ck$ltck) {
    if (is.logical(ck$line) || ck$c || grepl("^li|^lm|^st", ck$line, TRUE)) {
      "li"
    } else if (grepl("^loe|^po|^cu", ck$line, TRUE)) {
      "lo"
    } else if (grepl("^sm|^sp|^in", ck$line, TRUE)) {
      "sm"
    } else if (grepl("^e|^co|^d", ck$line, TRUE)) {
      "e"
    } else if (grepl("^pr|^log", ck$line, TRUE)) {
      "pr"
    } else {
      "li"
    }
  } else {
    "li"
  }
  if (any(!missing(font), !missing(cex), !missing(drop))) {
    dop <- formals(splot)[c("font", "cex", "drop")]
    oco <- function(s, d) {
      od <- d <- eval(d)
      if (length(s) != length(d)) {
        n <- NULL
        if (!is.null(n <- names(s)) || length(s) != 1) {
          if (!is.null(n)) d[n] <- s[n] else d[seq_along(s)] <- s
        } else {
          d[] <- s
        }
        s <- d
      }
      s <- s[names(od)]
      names(s) <- names(od)
      if (any(n <- is.na(s))) {
        s[n] <- od[n]
      }
      s
    }
    if (!missing(font)) {
      font <- oco(font, dop$font)
    }
    if (!missing(cex)) {
      cex <- oco(cex, dop$cex)
    }
    if (!missing(drop)) drop <- oco(drop, dop$drop)
  }
  dn <- if (ck$d) names(data) else ""
  if (
    any(grepl(
      "~",
      c(
        substitute(y),
        if (
          paste(deparse(substitute(y)), collapse = "") %in%
            ls(envir = globalenv())
        ) {
          y
        }
      ),
      fixed = TRUE
    ))
  ) {
    f <- as.character(as.formula(y))[-1]
    y <- as.formula(y)[[2]]
    bl <- function(x) {
      cs <- strsplit(x, "")[[1]]
      rs <- lapply(c("(", ")", "[", "]"), grep, cs, fixed = TRUE)
      l <- vapply(rs, length, 0)
      cr <- TRUE
      if (any(l != 0)) {
        if (l[1] != l[2] || l[3] != l[4]) {
          stop("invalid parentheses or brackets in ", x)
        }
        cr <- !seq_along(cs) %in%
          c(
            unlist(lapply(
              seq_len(l[1]),
              function(r) do.call(seq, lapply(rs[1:2], "[[", r))
            )),
            unlist(lapply(
              seq_len(l[3]),
              function(r) do.call(seq, lapply(rs[3:4], "[[", r))
            ))
          )
      }
      cs[cr] <- sub(
        "*",
        "_VAR_",
        sub("+", "_COV_", cs[cr], fixed = TRUE),
        fixed = TRUE
      )
      paste(cs, collapse = "")
    }
    f <- strsplit(bl(f[-1]), " _COV_ ", fixed = TRUE)[[1]]
    if (any(grepl(" _VAR_ ", f, fixed = TRUE))) {
      r <- strsplit(f[1], " _VAR_ ", fixed = TRUE)[[1]]
      if (length(r)) {
        x <- r[1]
      }
      if (length(r) > 1) {
        by <- r[2]
      }
      if (length(r) > 2) {
        ck$ff$bet <- TRUE
        between <- r[3]
      }
      if (length(r) > 3) {
        between <- c(r[3], r[4])
      }
      f <- f[!grepl(" _VAR_ ", f, fixed = TRUE)]
    } else {
      x <- f[1]
      f <- f[-1]
    }
    if (length(f)) {
      cov <- f
      ck$c <- ck$ff$cov <- TRUE
    }
  }
  txt <- list(
    split = "none",
    y = substitute(y),
    x = substitute(x),
    by = substitute(by),
    bet = as.list(substitute(between)),
    cov = as.list(substitute(cov)),
    su = deparse(substitute(su))
  )
  txt[c("bet", "cov")] <- lapply(c("bet", "cov"), function(l) {
    paste(if (!ck$ff[[l]] && length(txt[[l]]) > 1) txt[[l]][-1] else txt[[l]])
  })
  txt <- lapply(
    txt,
    function(e) if (is.call(e)) paste(deparse(e), collapse = "\n") else e
  )
  if (length(txt$bet) > 2) {
    txt$bet <- txt$bet[1:2]
  }
  tdc <- function(x, l = NULL) {
    if (!is.call(x)) {
      if ((is.null(l) && length(x) != 1) || (!is.null(l) && length(x) == l)) {
        return(x)
      }
    }
    if (is.character(x)) {
      x <- parse(text = x)
    }
    tx <- tryCatch(eval(x, data, parent.frame(2)), error = function(e) NULL)
    if (is.character(tx) && length(tx) < 2) {
      x <- parse(text = tx)
      tx <- tryCatch(eval(x, data, parent.frame(2)), error = function(e) NULL)
    } else if (is.null(tx)) {
      tx <- tryCatch(eval(x, data, parent.frame(3)), error = function(e) NULL)
    }
    if (
      is.null(tx) ||
        any(class(tx) %in% c("name", "call", "expression", "function"))
    ) {
      stop("could not find ", x, call. = FALSE)
    }
    if (!is.null(l) && is.null(ncol(tx))) {
      if (length(tx) != l) {
        tx <- rep_len(tx, l)
        if (is.call(x)) {
          x <- deparse(x)
        }
        warning(x, " is not the same length as y", call. = FALSE)
      }
    }
    if (!is.null(dim(tx)) && !is.matrix(tx) && !is.data.frame(tx)) {
      tx <- as.matrix(tx)
    }
    tx
  }
  if (!missing(data) && !any(class(data) %in% c("matrix", "data.frame"))) {
    data <- if (is.character(data)) {
      eval(parse(text = data))
    } else {
      eval(data, globalenv())
    }
  }
  dat <- data.frame(y = tdc(txt$y), check.names = FALSE)
  if (ncol(dat) == 1) {
    names(dat) <- "y"
  }
  nr <- nrow(dat)
  lvs <- function(x, s = FALSE) {
    if (is.factor(x)) {
      base::levels(x)
    } else if (s) {
      sort(unique(x[!is.na(x)]))
    } else {
      unique(x[!is.na(x)])
    }
  }
  for (n in names(txt)[-c(1, 2, 7)]) {
    l <- length(txt[[n]])
    if (l == 0) {
      next
    }
    if (l == nr) {
      dat[, n] <- txt[[n]]
      txt[[n]] <- n
    } else if (l == 1) {
      dat[, n] <- tdc(txt[[n]], nr)
    } else {
      for (i in seq_along(txt[[n]])) {
        dat[, paste0(n, ".", i)] <- tdc(txt[[n]][[i]], nr)
      }
    }
  }
  if (length(txt$y) == nr) {
    txt$y <- "y"
  }
  if (missing(x) && !is.null(dat$y) && !is.numeric(dat$y)) {
    dat$x <- dat$y
    sl <- grepl("^(y|by|bet[.12]{,2})$", colnames(dat))
    dat$y <- if (sum(sl) == 1) dat[, sl] else do.call(paste, dat[, sl])
    dat$y <- table(dat$y)[dat$y]
    if (sum(sl) != 1) {
      dat <- dat[, c("y", "x", colnames(dat)[!colnames(dat) %in% c("y", "x")])]
    }
    if (ck$t != 2) {
      txt[c("y", "x")] <- c("count", txt$y)
    }
    ck$el <- FALSE
    if (missing(type)) {
      ck$b <- TRUE
      ck$t <- 1
      ck[c("b", "t", "tt")] <- list(TRUE, 1, FALSE)
    }
    if (missing(autori)) autori <- FALSE
  }
  if (NCOL(dat$x) > 1) {
    ck$c <- TRUE
    txt$cov <- c(txt$x, txt$cov)
    dat$cov <- cbind(dat$cov, dat$x[, -1])
    dat$x <- dat$x[, 1]
  }
  ck$orn <- nr
  su <- substitute(su)
  if (ck$su && length(su) != nr) {
    tsu <- tryCatch(eval(su, if (ck$d) data), error = function(e) NULL)
    if (is.null(tsu) || length(tsu) != nr) {
      odat <- dat
      colnames(odat) <- sub("^y\\.", "", colnames(dat))
      tsu <- tryCatch(eval(su, odat), error = function(e) NULL)
    }
    if (!is.null(tsu)) {
      tsu[is.na(tsu)] <- FALSE
      su <- tsu
    }
    if (is.logical(tsu) && sum(tsu) == 0 || length(tsu) == 0) {
      ck$su <- FALSE
      warning("su excludes all rows, so it was ignored.", .call = FALSE)
    }
  }
  tsu <- vapply(dat, is.numeric, TRUE)
  ck$omitted <- list(
    na = apply(dat, 1, function(r) any(is.na(r))),
    inf = apply(dat[, tsu, drop = FALSE], 1, function(r) any(is.infinite(r)))
  )
  if (ck$su) {
    ck$omitted$su <- !su
  }
  ck$omitted$all <- !Reduce("|", ck$omitted)
  if (any(!ck$omitted$all)) {
    if (any(ck$omitted$all)) {
      odat <- dat[ck$omitted$all, , drop = FALSE]
      dat <- odat
      dn <- colnames(dat)
      if ("x" %in% dn && length(unique(dat$x)) == 1) {
        ck$t <- 2
        dat$x <- NULL
        warning("after omitting, x only had 1 level, so it was dropped")
      }
      if ("by" %in% dn && length(unique(dat$by)) == 1) {
        txt$by <- dat$by <- NULL
        warning("after omitting, by only had 1 level, so it was dropped")
      }
      if (ck$d) data <- data[ck$omitted$all, , drop = FALSE]
    } else {
      stop("this combination of variables/splits has no complete cases")
    }
  }
  dn <- colnames(dat)
  nr <- nrow(dat)
  if (sum(grepl("^y", dn)) > 1) {
    # setting up multiple y variables
    dn <- grep("^y\\.", dn)
    ck$mvn <- colnames(dat)[dn]
    ck$mvnl <- length(ck$mvn)
    if (any(tcn <- grepl("(V\\d+$|c\\(|y\\.(\\d+$|.*\\.))", ck$mvn))) {
      ncn <- substitute(y)
      if (
        length(ncn) > 1 && length(ncn <- as.character(ncn[-1])) == length(dn)
      ) {
        ck$mvn[tcn] <- paste0("y.", ncn[tcn])
      }
    }
    ck$mv <- TRUE
    if (ck$mlvn) {
      lvn <- FALSE
    }
    if (!missing(by)) {
      txt$bet <- c(txt$by, txt$bet)
      if (length(txt$bet) > 2) {
        warning(
          "multiple y variables moves by to between, so the second level of between was dropped"
        )
        txt$bet <- txt$bet[1:2]
        dat <- dat[-grep("bet", colnames(dat))[2]]
      }
      if (length(txt$bet) > 1) {
        dat$bet.1 <- if (is.factor(dat$by)) dat$by else as.character(dat$by)
        dat$bet.2 <- if (is.factor(dat$bet)) dat$bet else as.character(dat$bet)
        dat$bet <- NULL
      } else {
        dat$bet <- if (is.factor(dat$by)) dat$by else as.character(dat$by)
      }
    }
    td <- dat
    if (any(ckn <- duplicated(ck$mvn))) {
      ck$mvn[ckn] <- paste0(ck$mvn[ckn], "_", seq_len(sum(ckn)))
    }
    by <- sub("^y\\.", "", ck$mvn)
    if (any(by == "")) {
      by[by == ""] <- seq_len(sum(by == ""))
    }
    by <- factor(rep(by, each = nr), levels = by)
    cncls <- vapply(
      dat[, dn],
      function(v) is.numeric(v) || is.integer(v) || is.factor(v),
      TRUE
    )
    if (any(cncls) && any(!cncls)) {
      for (cnc in which(!cncls)) {
        dat[, cnc] <- as.numeric(factor(dat[, cnc], lvs(dat[, cnc])))
      }
    }
    dat <- data.frame(y = unlist(dat[, dn], use.names = FALSE))
    if (ncol(td) > length(dn)) {
      dat <- cbind(
        dat,
        do.call(
          rbind,
          lapply(seq_along(dn), function(i) td[, -dn, drop = FALSE])
        )
      )
    }
    if (mv.as.x) {
      txt$by <- txt$x
      txt$x <- if (missing(labx)) {
        "variable"
      } else if (labx == txt$by) {
        paste0(labx, ".1")
      } else {
        labx
      }
      dat$by <- dat$x
      dat$x <- by
    } else {
      txt$by <- "variable"
      dat$by <- by
    }
    if (missing(leg.title) && !mv.as.x) {
      ck$legt <- FALSE
    }
    if (!missing(levels) && "mv" %in% names(levels)) {
      names(levels)[names(levels) == "mv"] <- txt[[if (mv.as.x) "x" else "by"]]
    }
    dn <- colnames(dat)
    if (!missing(mv.scale) && mv.scale != "none") {
      tv <- if (mv.as.x) dat$x else dat$by
      for (g in levels(as.factor(tv))) {
        svar <- tv == g
        cvar <- scale(dat[svar, 1], scale = grepl("^t|z|sc", mv.scale, TRUE))
        if (any(is.na(cvar))) {
          cvar <- dat[svar, 1] - mean(dat[svar, 1], na.rm = TRUE)
        }
        dat[svar, 1] <- cvar
      }
    }
    nr <- nrow(dat)
  } else {
    ck$mv <- FALSE
  }
  if (!"x" %in% dn) {
    ck$t <- 2
    if (!missing(type) && !grepl("^d", type, TRUE)) {
      warning("x must be included to show other types of splots")
    }
  }
  if (!ck$cb && !"by" %in% dn) {
    ck$leg <- 0
  }
  if (lim > 20 || (is.logical(lim) && !lim)) {
    lim <- Inf
    if (ck$legm && !ck$cb) {
      ck$leg <- 0
    }
    if (missing(error)) ck$el <- FALSE
  }
  if (ck$ltm && !ck$el) {
    line.type <- "b"
  }
  if (ck$ltym && is.logical(lines) && !lines) {
    ck$lty <- FALSE
    lty <- 1
  }
  if (!is.numeric(dat$y)) {
    txt$yax <- lvs(dat$y)
    if (!is.logical(dat$y) && !is.factor(dat$y)) {
      dat$y <- factor(dat$y, lvs(dat$y))
    }
    dat$y <- as.numeric(dat$y)
  }
  if ("by" %in% dn && is.character(dat$by) && all(!grepl("[^0-9]", dat$by))) {
    dat$by <- gsub(
      " ",
      "0",
      base::format(dat$by, justify = "right"),
      fixed = TRUE
    )
  }
  odat <- dat
  # splitting and parsing variables
  splt_type <- function(x, s) {
    if (s == 1) {
      "mean"
    } else if (s == 3) {
      "standard deviation"
    } else if (s == 2) {
      "quantile"
    } else if (
      s == 4 &&
        is.double(split) &&
        (length(split) != 1 ||
          all(
            c(
              sum(split >= x, na.rm = TRUE),
              sum(split <= x, na.rm = TRUE)
            ) >
              1
          ))
    ) {
      paste(split, collapse = ", ")
    } else if (s == 4 && is.numeric(split) && split > 1) {
      split <- min(length(x), round(split), na.rm = TRUE)
      paste0("segments (", split, ")")
    } else {
      "median"
    }
  }
  splt <- function(x, s) {
    if (s == 1) {
      factor(
        x >= mean(x, na.rm = TRUE) * 1,
        labels = c("Below Average", "Above Average")
      )
    } else if (s == 3) {
      m <- mean(x, na.rm = TRUE)
      s <- sd(x, TRUE)
      cut(x, c(-Inf, m - s, m + s, Inf), labels = c("-1 SD", "Mean", "+1 SD"))
    } else if (s == 2) {
      cut(
        x,
        c(-Inf, quantile(x, na.rm = TRUE)[c(2, 4)], Inf),
        labels = c("2nd Quantile", "Median", "4th Quantile")
      )
    } else if (
      s == 4 &&
        is.double(split) &&
        (length(split) != 1 ||
          all(
            c(
              sum(split >= x, na.rm = TRUE),
              sum(split <= x, na.rm = TRUE)
            ) >
              1
          ))
    ) {
      cut(
        x,
        c(-Inf, split, Inf),
        paste0("<=", c(split, "Inf")),
        ordered_result = TRUE
      )
    } else if (s == 4 && is.numeric(split) && split > 1) {
      n <- length(x)
      split <- min(n, round(split), na.rm = TRUE)
      factor(paste(
        "seg",
        rep(seq_len(split), each = round(n / split + .49))[order(order(x))]
      ))
    } else {
      factor(
        x >= median(x, TRUE) * 1,
        labels = c("Under Median", "Over Median")
      )
    }
  }
  seg <- list(
    x = list(e = !missing(x), s = FALSE, i = 2),
    f1 = list(e = FALSE, s = FALSE, l = "", ll = 1),
    f2 = list(e = FALSE, s = FALSE, l = "", ll = 1),
    by = list(e = FALSE, s = FALSE, l = "", ll = 1)
  )
  if (seg$x$e && ck$t != 2) {
    if (
      (ck$t == 1 ||
        is.character(dat$x) ||
        is.factor(dat$x) ||
        (missing(type) && length(unique(dat$x)) < lim))
    ) {
      dat$x <- if (
        !is.character(dat$x) && !is.factor(dat$x) && length(unique(dat$x)) > lim
      ) {
        seg$x$s <- TRUE
        if (missing(type)) {
          ck$t <- 1
        }
        txt$split <- splt_type(dat$x, ck$sp)
        splt(dat$x, ck$sp)
      } else {
        if (missing(type)) {
          ck$t <- 1
        }
        as.factor(dat$x)
      }
    }
  }
  if (ck$t == 1 || (is.character(dat$x) || is.factor(dat$x))) {
    seg$x$l <- lvs(dat$x)
    if (length(seg$x$l) == 1) ck$t <- 3
  }
  svar <- NULL
  cvar <- if (any(grepl("^c", dn))) which(grepl("^c", dn)) else NULL
  if (any(grepl("^b", dn))) {
    svar <- which(grepl("^b", dn))
    for (i in svar) {
      e <- if (grepl("bet", dn[i])) {
        if (!seg$f1$e) "f1" else "f2"
      } else {
        "by"
      }
      seg[[e]]$e <- TRUE
      seg[[e]]$i <- i
      seg[[e]]$l <- lvs(dat[, i])
      if (is.factor(dat[, i]) && drop[[dn[i]]]) {
        seg[[e]]$l <- seg[[e]]$l[seg[[e]]$l %in% dat[, i]]
      }
      seg[[e]]$ll <- length(seg[[e]]$l)
      if (
        seg[[e]]$ll > lim && !(is.character(dat[, i]) || is.factor(dat[, i]))
      ) {
        txt$split <- splt_type(dat[, i], ck$sp)
        dat[, i] <- splt(dat[, i], ck$sp)
        seg[[e]]$s <- TRUE
        seg[[e]]$l <- lvs(dat[, i])
        seg[[e]]$ll <- length(seg[[e]]$l)
      }
      if (!is.factor(dat[, i])) {
        dat[, i] <- if (is.character(dat[, i])) {
          factor(dat[, i], lvs(dat[, i]))
        } else {
          as.factor(dat[, i])
        }
      }
    }
  }
  if (seg$by$l[1] == "") {
    seg$by$l <- "NA"
  }
  fmod <- NULL
  vs <- c(y = txt$y, x = txt$x, by = txt$by, bet = txt$bet, cov = txt$cov)
  colnames(odat) <- vs
  if (ck$t != 2 && model) {
    tryCatch(
      {
        mod <- formula(paste(
          vs["y"],
          "~",
          vs["x"],
          if (seg$by$e) paste0("*", vs["by"]),
          if (seg$f1$e) paste0("*", vs[grep("^bet", names(vs))[1]]),
          if (seg$f2$e) paste0("*", vs["bet2"]),
          if (length(cvar)) paste0("+", paste0(vs["cov"], collapse = "+"))
        ))
        fmod <- lm(mod, odat)
        if (model) {
          s <- summary(fmod)
          s$call <- mod
          print(s)
        }
      },
      error = function(e) {
        warning(paste("summary model failed:", e$message), call. = FALSE)
      }
    )
  }
  if (!missing(levels)) {
    tryCatch(
      {
        lc <- c("y", "x", "by", "f1", "f2")
        ns <- c(txt$y, txt$x, txt$by, txt$bet, lc)
        lc <- c(lc[seq_len(length(ns) - length(lc))], lc)
        for (n in names(levels)) {
          if (any(cns <- ns %in% n)) {
            sl <- lc[cns <- which(cns)[1]]
            if (sl == "y") {
              sl <- list(i = 1)
              vfac <- txt$yax
              dat$y <- factor(dat$y, labels = vfac)
            } else {
              sl <- seg[[sl]]
              vfac <- lvs(dat[, sl$i])
            }
            vl <- length(vfac)
            ln <- levels[[n]]
            lo <- NULL
            if (is.list(ln)) {
              if (length(ln) > 1) {
                lo <- levels[[n]][[2]]
              }
              ln <- ln[[1]]
            }
            if (is.numeric(ln)) {
              ln <- vfac[ln]
            }
            if (vl == length(ln)) {
              vl <- list(dat[, sl$i])
              if (all(ln %in% vfac)) {
                vl$levels <- ln
              } else {
                if (!is.null(lo)) {
                  vl$labels <- ln[lo]
                  vl$levels <- vfac[lo]
                } else {
                  vl$labels <- ln
                }
              }
              dat[, sl$i] <- do.call(factor, vl)
              if ("l" %in% names(sl)) seg[[lc[cns]]]$l <- levels(dat[, sl$i])
            } else {
              warning(
                n,
                " has ",
                vl,
                " levels but you provided ",
                length(ln),
                call. = FALSE
              )
            }
            if (sl$i == 1) {
              txt$yax <- lvs(dat$y)
              dat$y <- as.numeric(dat$y)
            }
          }
        }
      },
      error = function(e) {
        warning("setting levels failed: ", e$message, call. = FALSE)
      }
    )
  }
  dsf <- list(c1 = "", sep = rep.int("^^", nr), c2 = "")
  if (seg$f1$e) {
    dsf$c1 <- dat[, seg$f1$i]
  }
  if (seg$f2$e) {
    dsf$c2 <- dat[, seg$f2$i]
  }
  cdat <- split(dat, dsf)
  if (seg$by$e) {
    cdat <- lapply(cdat, function(s) {
      if (length(unique(s$by)) > 1) {
        split(s, factor(as.character(s$by), lvs(s$by)))
      } else {
        s <- lapply(seg$by$l, function(l) if (sum(s$by == l)) s else NULL)
        names(s) <- seg$by$l
        s
      }
    })
    if (all((seg$n <- vapply(cdat, length, 0)) == seg$by$ll)) {
      seg$n <- vapply(cdat, function(s) vapply(s, NROW, 0), numeric(seg$by$ll))
    } else {
      drop["by"] <- FALSE
    }
  } else {
    seg$n <- vapply(cdat, nrow, 0)
  }
  if (seg$by$e && ck$t != 3 && drop["by"]) {
    seg$by$l <- if (is.null(rownames(seg$n))) {
      structure(seg$n > 1, names = seg$by$l)
    } else {
      vapply(rownames(seg$n), function(r) any(seg$n[r, ] > 1), TRUE)
    }
    if (!any(seg$by$l)) {
      if (ck$t == 2) {
        stop("no level of by has more than 1 observation")
      }
      warning(
        "no level of by has more than 1 observation so it was treated as colorby",
        call. = FALSE
      )
      seg$by$e <- FALSE
      seg$by$l <- ""
      seg$by$ll <- 1
      if (ck$cb) {
        colorby <- substitute(colorby)
        colorby[[2]] <- dat$by
      } else {
        colorby <- dat$by
      }
      ck$cb <- TRUE
      dat <- dat[, -seg$by$i]
      cdat <- split(dat, dsf)
      seg$n <- vapply(cdat, nrow, 0)
    } else {
      seg$by$l <- names(seg$by$l[seg$by$l])
      seg$by$ll <- length(seg$by$l)
    }
  }
  if (!is.null(nrow(seg$n))) {
    cdat <- cdat[apply(seg$n, 2, function(r) any(r > 1))]
    if (nrow(seg$n) > 1) seg$n <- colSums(seg$n[, names(cdat), drop = FALSE])
  }
  if (ck$mv) {
    seg$n <- seg$n / length(ck$mvn)
  }
  seg$ll <- length(seg$n)
  if (ck$mlvn && seg$by$e && (seg$by$s || !any(grepl("^[0-9]", seg$by$l)))) {
    lvn <- FALSE
  }
  ptxt <- c(txt[-c(1, 7)], l = lapply(seg[1:4], "[[", "l"))
  if (
    missing(labels.trim) &&
      seg$ll == 1 &&
      length(ptxt$l.x) < 2 &&
      (seg$by$ll == 1 || ck$mv)
  ) {
    labels.trim <- 40
  }
  if (is.numeric(labels.trim) || is.character(labels.filter)) {
    vs <- c("y", "x", "by", "bet", "cov", "l.x", "l.f1", "l.f2", "l.by")
    ptxt <- lapply(vs, function(n) {
      n <- as.character(ptxt[[n]])
      if (length(n) != 0 && all(n != "NULL" & n != "")) {
        names(n) <- n
        if (is.character(labels.filter)) {
          n <- gsub(labels.filter, " ", n, perl = TRUE)
        }
        if (any(is.na(iconv(n)))) {
          stop(
            "labels appear to be misencoded -- check them with the iconv function"
          )
        }
        if (is.numeric(labels.trim)) {
          if (any(ln <- nchar(n) > (labels.trim + 3))) {
            n[ln] <- sub("$", "...", strtrim(n[ln], labels.trim))
          }
        }
      }
      n
    })
    names(ptxt) <- vs
  }
  if (is.character(labx)) {
    ptxt$x <- labx
  } else if (ck$t == 2) {
    ptxt$x <- ptxt$y
  }
  if (is.character(laby)) {
    ptxt$y <- laby
  } else if (ck$t == 2) {
    ptxt$y <- "Density"
  }
  ck$ileg <- seg$by$e && ck$leg > 1
  ptxt$leg <- ptxt$l.by
  fdat <- dat
  names(fdat) <- paste0(".", names(dat))
  fdat <- if (!is.null(data)) {
    if (nrow(data) == nr) cbind(data, fdat, odat) else data
  } else {
    cbind(fdat, odat)
  }
  # figuring out colors
  csf <- if (is.function(color.summary)) {
    color.summary
  } else if (grepl("^av|mea", color.summary, TRUE)) {
    splot.colormean
  } else if (grepl("^mode", color.summary, TRUE)) {
    function(x) names(which.max(table(x)))
  } else {
    function(x) lvs(x)[round(median(as.numeric(factor(x, lvs(x)))))]
  }
  colors <- substitute(colors)
  seg$cols <- if (ck$co) {
    colors
  } else if (any(paste(colors) %in% names(fdat))) {
    NULL
  } else {
    tryCatch(tdc(colors), error = function(e) NULL)
  }
  if (is.null(seg$cols)) {
    seg$cols <- eval(colors, fdat, parent.frame(1))
  }
  ptxt$cbo <- substitute(colorby)
  if (length(ptxt$cbo) > 1 && ptxt$cbo[[1]] == "list") {
    ptxt$cbo <- ptxt$cbo[[2]]
  }
  if (!is.character(ptxt$cbo)) {
    ptxt$cbo <- deparse(ptxt$cbo)
  }
  if (length(seg$cols) == 1) {
    if (
      grepl("^bri|^dar|^pas", seg$cols, TRUE) &&
        (ck$cb || (seg$by$ll > 1 && seg$by$ll < 10))
    ) {
      seg$cols <- splot.color(seed = seg$cols)
    } else if (ck$co || grepl("^gra|^grey", seg$cols, TRUE)) {
      seg$cols <- splot.color(seg$by$ll, seed = "grey")
    }
  }
  cl <- length(seg$cols)
  seg$lcols <- seg$cols
  ck[c("cbn", "cbb")] <- tg <- FALSE
  chl <- if (ck$cblegm) FALSE else ck$cbleg
  if (ck$cb) {
    sca <- names(formals(splot.color))
    colorby <- substitute(colorby)
    cba <- if (any(paste(colorby) %in% names(fdat))) {
      NULL
    } else {
      tryCatch(tdc(colorby), error = function(e) NULL)
    }
    if (is.null(cba)) {
      cba <- eval(substitute(colorby), fdat)
    }
    if (is.null(cba) || (is.character(cba) && length(cba) == 1)) {
      cba <- tdc(colorby)
    }
    if (!is.list(cba) || is.data.frame(cba)) {
      cba <- list(x = cba)
    } else if (is.null(names(cba))) {
      names(cba) <- names(formals(splot.color))[seq_along(cba)]
    } else if (any(names(cba) == "")) {
      tn <- names(cba) == ""
      names(cba)[tn] <- sca[seq_len(sum(tn))]
    }
    if (!is.null(ncol(cba$x)) && ncol(cba$x) > 1) {
      if (!"by" %in% names(cba)) {
        cba$by <- cba$x[, 2]
      }
      cba$x <- cba$x[, 1]
    }
    cba$flat <- TRUE
    cn <- names(cba)
    ck$cbb <- "by" %in% cn
    if (ck$mv && length(cba$x) * ck$mvnl == nr) {
      cba$x <- rep(cba$x, ck$mvnl)
      if (ck$cbb) cba$by <- rep(cba$by, ck$mvnl)
    }
    if (ck$cbb) {
      cba$by <- if (is.numeric(cba$by) && length(unique(cba$by)) > lim) {
        ptxt$cbos <- if (missing(leg.title)) colorby else leg.title
        ptxt$cbos <- if (is.call(ptxt$cbos)) {
          deparse(ptxt$cbos[[
            if (cn[2] == "by" && length(ptxt$cbos) > 2) 3 else 2
          ]])
        } else {
          deparse(ptxt$cbos)
        }
        splt(cba$by, ck$sp)
      } else {
        factor(cba$by, lvs(cba$by))
      }
      if (
        seg$by$e &&
          seg$by$ll <= lim &&
          length(cba$by) == nr &&
          !identical(as.character(dat$by), as.character(cba$by))
      ) {
        cba$by <- dat$by:cba$by
        cbbl <- sub(":.*", "", lvs(cba$by))
        colorby[[3]] <- as.name(paste0(ptxt$by, ":", colorby[[3]]))
        seg$lcols <- seg$cols <- splot.color(cbbl, seed = seg$cols)
        if (!ck$b && ck$line) {
          if (length(lty) < seg$by$ll) {
            lty <- seq_len(seg$by$ll)
          }
          ck[c("lty", "ltym")] <- FALSE
          lty <- rep(lty, table(cbbl))
          seg$lty <- unique(lty)
        }
      } else {
        lby <- length(lvs(cba$by))
        if (!color.lock && cl < lby) {
          seg$cols <- splot.color(
            as.list(rep.int(round(lby / cl + .49), cl)),
            seed = seg$cols
          )
        }
      }
    }
    if (length(cba$x) == ck$orn) {
      cba$x <- cba$x[ck$omitted$all]
    }
    if (ck$cbb && length(cba$by) == ck$orn) {
      cba$by <- cba$by[ck$omitted$all]
    }
    if (seg$by$e || !"seed" %in% cn) {
      cba$seed <- seg$cols
      if ("seed" %in% cn) {
        warning(
          "colorby's seed is ignored because by is specified -- use colors to set seeds",
          call. = FALSE
        )
      }
    }
    cn <- names(cba)
    ckn <- cken <- is.numeric(cba$x)
    if ((ck$t == 1 || any(seg$by$e, seg$f1$e)) && length(cba$x) == nr) {
      seg$cbxls <- lvs(cba$x)
      if (ck$t != 3 && (!seg$by$e || seg$by$ll > lim)) {
        cba$x <- vapply(
          split(cba$x, if (seg$by$e) dat$by else dat$x),
          function(x) {
            if (ckn) {
              mean(x, na.rm = TRUE)
            } else {
              names(which.max(table(x)))
            }
          },
          if (ckn) 0 else ""
        )
        if (!ckn || length(seg$cbxls) <= lim) {
          cba$x <- if (ckn) {
            cba$x <- round(cba$x, 3)
            factor(cba$x, sort(unique(cba$x)))
          } else {
            factor(cba$x, seg$cbxls)
          }
          ckn <- FALSE
        }
        if (ck$cbb && length(cba$by) == nr) {
          cba$by <- factor(
            vapply(
              split(cba$by, if (seg$by$e) dat$by else dat$x),
              function(x) {
                names(which.max(table(x)))
              },
              ""
            ),
            lvs(cba$by)
          )
          if (length(cba$x) != length(cba$by)) {
            cba$by <- NULL
            ck$cbb <- FALSE
            warning(
              "colorby's by was dropped as it was not the same length as x after being aligned with the formula's x",
              call. = FALSE
            )
          }
        }
        if (ckn && !ck$b && ck$t == 1 && length(cba$x) == 2) {
          cba$x <- c(mean(cba$x), cba$x)
          if (ck$cbb) {
            cba$by <- factor(
              c(lvs(cba$by)[which.max(tabulate(cba$by))], as.character(cba$by)),
              lvs(cba$by)
            )
          }
        }
      } else if (!ck$cbb) {
        if (ck$t == 3) {
          cba$by <- dat$by
        } else {
          cba$x <- data.frame(cba$x, dat$by)
          if (ck$b && seg$ll != 1) {
            cba$x$x <- dat$x
          }
          cba$x <- unlist(
            lapply(split(cba$x, dsf), function(x) {
              lapply(
                split(x[, 1], x[, -1]),
                function(x) {
                  if (!length(x)) {
                    NA
                  } else if (ckn) {
                    mean(x, na.rm = TRUE)
                  } else {
                    names(which.max(table(x)))
                  }
                }
              )
            }),
            TRUE,
            FALSE
          )
          if (length(cba$x) == seg$by$ll) {
            names(cba$x) <- seg$by$l
          } else {
            seg$ill <- names(cba$x)
          }
          if (!ckn) {
            cba$x <- factor(cba$x, seg$cbxls)
          }
          cba$by <- factor(rep_len(seg$by$l, length(cba$x)), seg$by$l)
          if (ck$cblegm) ck$cbleg <- FALSE
        }
      }
    }
    if (ck$cbb) {
      if (length(cba$by) == nr && length(cba$x) == seg$by$ll) {
        tn <- lapply(split(cba$by, dat$by), unique)
        if (all(vapply(tn, length, 0) == 1)) {
          cba$by <- unlist(tn, use.names = FALSE)
        } else {
          cba$by <- NULL
          warning(
            "colorby's by was dropped as its levels within levels of by are not unique",
            call. = FALSE
          )
        }
      }
      if (ck$cbleg) {
        chl <- TRUE
        if (missing(leg.title)) {
          leg.title <- substitute(colorby)
          leg.title <- if (is.call(leg.title) && length(leg.title) > 2) {
            deparse(leg.title[[if (cn[2] == "by") 3 else 2]])
          } else {
            deparse(leg.title)
          }
        }
        ptxt$leg <- lvs(cba$by)
      }
    } else {
      if (ck$cbleg && (ck$t == 1 || !seg$by$e)) {
        chl <- TRUE
        tg <- ckn
        ll <- all(ck$t != 1 || (length(seg$x$l) > 2 || seg$by$ll > 2))
        if (ll) {
          if (is.call(cba$x)) {
            cba$x <- tdc(cba$x)
          }
          ll <- length(unique(cba$x)) > 2
        }
        if (missing(leg.title) && length(ptxt$cbo) == 1) {
          leg.title <- ptxt$cbo
        }
        ptxt$leg <- if (ckn) {
          formatC(
            c(min(cba$x), if (ll) mean(cba$x), max(cba$x)),
            2,
            format = "f"
          )
        } else {
          lvs(cba$x)
        }
      } else if (!seg$by$e) {
        ck$leg <- 0
      }
    }
    if (!ckn && length(cba$x) > lim && !"shuffle" %in% cn) {
      cba$shuffle <- TRUE
    }
    sca <- cn %in% sca
    if (any(!sca)) {
      warning(
        paste0("unused colorby arguments: ", paste(cn[!sca], collapse = ", ")),
        call. = FALSE
      )
    }
    seg$cols <- do.call(splot.color, cba[sca])
    if (!is.null(names(cba$x))) {
      names(seg$cols) <- names(cba$x)
    }
    if (!chl || ck$cbb) {
      ck$cbn <- TRUE
      ptxt$cbn <- paste0(
        "Colored by ",
        if (ckn || cken) "value of " else "levels of ",
        ptxt$cbo,
        ". "
      )
    }
    if (seg$by$e && !ck$cbb) {
      if (length(seg$cols) == length(ptxt$leg)) {
        seg$lcols <- seg$cols
      } else if (ckn && ck$cbb) {
        seg$lcols <- seg$cols[c(which.min(cba$x), which.max(cba$x))]
      }
    }
    if (chl) {
      if (ck$legm && !ck$leg) {
        ck$leg <- 1 + seg$ll > 1
      }
      if (
        (ck$ltym || length(lty) == length(seg$cbxls)) &&
          (!seg$by$e || seg$by$ll > length(ptxt$leg))
      ) {
        ck[c("lty", "ltym")] <- FALSE
        if (!is.numeric(lty)) {
          lty <- 1
        }
        seg$lty <- rep_len(lty, seg$by$ll)
        if (!ck$ltym) {
          lty <- seq_along(seg$cbxls)
        }
        if (ck$ltym && seg$by$e && !ckn) {
          cbl <- cba[[if (ck$cbb) "by" else "x"]]
          for (g in seq_along(seg$cbxls)) {
            seg$lty[cbl == seg$cbxls[[g]]] <- lty[[g]]
          }
        }
        lty <- unique(seg$lty)
      }
      if (tg) {
        l <- length(seg$cols)
        seg$lcols <- seg$cols[order(cba$x)[c(
          1,
          if (ll) round(mean(seq_len(l))),
          l
        )]]
      } else if (
        seg$by$e &&
          length(seg$cols) == seg$by$ll &&
          length(ptxt$leg) == seg$by$ll
      ) {
        seg$lcols <- seg$cols
      }
    } else {
      ptxt$leg <- if (
        length(seg$cols) == seg$by$ll && !is.null(names(seg$cols))
      ) {
        names(seg$cols)
      } else {
        seg$by$l
      }
      if (length(ptxt$leg) == length(seg$cols)) {
        seg$lcols <- seg$cols
      } else if (all(ptxt$leg %in% names(seg$cols))) {
        seg$lcols <- seg$cols[ptxt$leg]
      } else if (seg$by$e && length(seg$cols) == nr) {
        seg$lcols <- vapply(split(seg$cols, dat$by), csf, "")
      }
    }
  } else {
    if (!color.lock && cl < seg$by$ll) {
      seg$cols <-
        splot.color(
          as.list(rep.int(round(seg$by$ll / cl + .49), cl)),
          seed = seg$cols
        )
    }
    if (
      ck$t != 2 &&
        !any(length(seg$cols) == c(nr, seg$by$ll)) &&
        (!ck$b || seg$by$e)
    ) {
      seg$cols <- rep_len(seg$cols, seg$by$ll)
    }
  }
  if (seg$by$e && !all(seg$by$l %in% names(seg$cols))) {
    if (length(seg$cols) == seg$by$ll) {
      names(seg$cols) <- seg$by$l
      if (!ck$cbb && !chl) seg$lcols <- seg$cols
    } else if (length(seg$lcols) == seg$by$ll) {
      names(seg$lcols) <- seg$by$l
    } else if (length(ptxt$leg) == seg$by$ll) {
      if (length(seg$lcols) == nr) {
        seg$lcols <- split(seg$lcols, dat$by)
      } else {
        seg$lcols <- rep_len(seg$lcols, seg$by$ll)
        if (any(grepl(names(cdat)[1], names(seg$lcols), fixed = TRUE))) {
          for (g in names(cdat)) {
            names(seg$lcols) <- sub(
              paste0(g, "."),
              "",
              names(seg$lcols),
              fixed = TRUE
            )
          }
          if (all(seg$by$l %in% names(seg$lcols))) {
            seg$lcols <- seg$lcols[seg$by$l]
          }
        } else {
          names(seg$lcols) <- seg$by$l
        }
      }
    }
    if (ck$b && length(seg$cols) == nr) {
      seg$cols <- unlist(
        lapply(
          split(data.frame(seg$cols, dat$by), dat$x),
          function(d) vapply(split(d[, 1], d[, 2], drop = TRUE), csf, "")
        ),
        use.names = FALSE
      )
    }
  }
  if (ck$opacity && (ck$t != 3 || !points)) {
    if (is.list(seg$cols)) {
      lapply(seg$cols, adjustcolor, opacity)
    } else {
      seg$cols[] <- adjustcolor(seg$cols, opacity)
    }
  }
  if (lvn && length(ptxt$by)) {
    ptxt$l.by[] <- paste0(paste0(ptxt$by, ": "), ptxt$l.by)
  }
  if (length(seg$cols) == nr) {
    if (any(seg$by$e && !ck$b, seg$f1$e, seg$f2$e)) {
      seg$scols <- split(
        if (seg$by$e && !ck$b) data.frame(seg$cols, dat$by) else seg$cols,
        dsf
      )
      if (!ck$b) {
        if (seg$by$e) {
          seg$scols <- lapply(seg$scols, function(d) split(d[, 1], d[, 2]))
        }
        if (ck$t == 1) {
          seg$scols <- lapply(seg$scols, function(bl) {
            vapply(
              bl,
              function(bll) {
                if (length(bll)) csf(bll) else ""
              },
              ""
            )
          })
        }
      }
    }
  } else if (seg$ll != 1 && "ill" %in% names(seg)) {
    seg$scols <- lapply(
      names(cdat),
      function(n) seg$cols[grepl(n, names(seg$cols), fixed = TRUE)]
    )
    names(seg$scols) <- names(cdat)
  }
  if (ck$t == 2 && seg$by$ll > 1 && !all(seg$by$l %in% names(seg$cols))) {
    seg$cols <- if (length(seg$lcols) == seg$by$ll) {
      seg$lcols
    } else if (length(seg$cols) == 1) {
      splot.color(seq_len(seg$by$ll), seed = seg$cols)
    } else {
      rep_len(seg$cols, seg$by$ll)
    }
    if (is.null(names(seg$cols))) names(seg$cols) <- seg$by$l
  }
  # figuring out parts of the plot
  ylab <- if (ck$ly) ptxt$y else ""
  xlab <- if (ck$lx && length(ptxt$x)) ptxt$x else ""
  main <- if (is.logical(title) && title) {
    paste0(
      if (ck$t == 2) {
        paste("Density of", ptxt$x)
      } else {
        paste(
          ptxt$y,
          "by",
          ptxt$x
        )
      },
      if (seg$by$e && !ck$mv) paste(" at levels of", ptxt$by),
      if (length(ptxt$bet) != 0) {
        paste(
          " between",
          paste(ptxt$bet, collapse = " & ")
        )
      }
    )
  } else if (is.character(title)) {
    title
  } else {
    ""
  }
  if (!is.character(note)) {
    if (!is.logical(note) || note) {
      ck$er <- ck$t == 1 && ck$el
      ck$spm <- txt$split != "none"
      if (
        ck$er &&
          all(vapply(
            cdat,
            function(d) {
              if (!is.data.frame(d)) {
                all(vapply(d, function(dd) !anyDuplicated(dd$x), TRUE))
              } else {
                !anyDuplicated(d$x)
              }
            },
            TRUE
          ))
      ) {
        ck[c("el", "er")] <- FALSE
      }
      if (any(ck$cbn, ck$spm, ck$er, ck$t == 3 && ck$ltck)) {
        if (ck$spm) {
          tv <- unique(c(
            if (seg$x$s) ptxt$x,
            if (seg$by$s) ptxt$by,
            if (seg$f1$s) ptxt$bet[1],
            if (seg$f2$s) ptxt$bet[2],
            if ("cbos" %in% names(ptxt)) ptxt$cbos
          ))
          tv <- sub(
            ", (?=[A-z0-9]+$)",
            if (length(tv) > 2) ", & " else " & ",
            paste(tv, collapse = ", "),
            perl = TRUE
          )
        }
        note <- paste0(
          if (ck$spm) paste0(tv, " split by ", txt$split, ". "),
          if (ck$er) {
            paste(
              "Error bars show",
              ifelse(ck$e, "standard error. ", "95% confidence intervals. ")
            )
          },
          if (ck$cbn) ptxt$cbn,
          if (ck$t == 3 && ck$ltck) {
            paste0(
              "Line type: ",
              switch(
                ck$ltco,
                li = "lm",
                lo = "loess",
                sm = "spline",
                e = "connected",
                pr = "probability"
              ),
              "."
            )
          }
        )
      }
    } else {
      note <- ""
    }
  }
  ck$sud <- (!is.logical(sud) || sud) && (is.character(sud) || ck$su || ck$c)
  ck$sub <- (!is.logical(sub) || sub) &&
    (is.character(sub) || seg$ll > 1 || ndisp)
  pdo <- list(...)
  l2m <- function(l) {
    tl <- round(l^.5)
    c(tl + all(l > c(tl^2, tl * (tl - 1))), tl)
  }
  seg$dim <- if (any(ckl <- c("mfrow", "mfcol") %in% names(pdo))) {
    pdo[[if (ckl[1]) "mfrow" else "mfcol"]]
  } else if (!seg$f1$e) {
    c(1, 1)
  } else if (!seg$f2$e) {
    if (seg$f1$ll > 2) l2m(seg$f1$ll) else c(2, 1)
  } else {
    c(seg$f1$ll, seg$f2$ll)
  }
  seg$l <- t(data.frame(strsplit(names(cdat), ".^^.", fixed = TRUE)))
  if (seg$f1$e) {
    rownames(seg$l) <- match(seg$l[, 1], seg$f1$l)
    seg[c("f1", "f2")] <- lapply(c("f1", "f2"), function(n) {
      nl <- seg[[n]]
      if (nl$e) {
        nl$l <- unique(seg$l[, if (n == "f1") 1 else 2])
      }
      if (nl$e) {
        nl$ll <- length(nl$l)
      }
      nl
    })
  }
  nc <- seg$dim[1] * seg$dim[2]
  if (length(ptxt$leg) == 1 && ptxt$leg == "NA") {
    ck$leg <- 0
  }
  if (
    ck$leg == 1 &&
      ck$legm &&
      (dev.size(units = "in")[1] < 2 ||
        (all(seg$dim == 1) && (ck$t != 1 || seg$by$ll < 9)))
  ) {
    ck$leg <- 2
  }
  if (ck$leg == 1) {
    if (is.logical(leg) || is.character(leg)) leg <- nc + 1
  }
  dop <- par(no.readonly = TRUE)
  if (drop["bet"] && !any(ckl) && any(nc - seg$ll >= seg$dim)) {
    seg$dim <- l2m(seg$ll)
    nc <- seg$dim[1] * seg$dim[2]
  }
  seg$dmat <- matrix(seq_len(nc), seg$dim[2], seg$dim[1])
  if (!drop["bet"] && seg$f2$e) {
    seg$lc <- vapply(
      seg$f1$l,
      function(l) seg$f2$l %in% seg$l[seg$l[, 1] == l, 2],
      logical(seg$f2$ll)
    )
  } else {
    seg$lc <- seg$dmat == 0
    seg$lc[seq_len(seg$ll)] <- TRUE
  }
  if (nc > seg$ll) {
    if (any(ckl)) {
      tm <- lapply(dim(seg$lc), seq_len)
      mm <- matrix(FALSE, seg$dim[2], seg$dim[1])
      mm[tm[[1]], tm[[2]]] <- seg$lc
      seg$lc <- mm
    }
    if (!drop["bet"]) {
      seg$dmat[seg$lc] <- seq_len(seg$ll)
      seg$dmat[!seg$lc] <- seq_len(sum(!seg$lc)) + seg$ll
    }
  }
  ck$legcol <- FALSE
  if (lpos == "auto") {
    "topright"
  }
  lega <- list(
    x = lpos,
    col = seg$lcols,
    cex = cex["leg"],
    text.font = font["leg"],
    bty = "n",
    x.intersp = .5,
    xjust = .5,
    legend = ptxt$leg
  )
  if (
    ck$legt &&
      (is.character(leg.title) &&
        length(leg.title) == 1 ||
        length(ptxt$by) == 1)
  ) {
    lega$title <- if (is.character(leg.title)) leg.title else ptxt$by
  }
  l <- length(lega$legend)
  seg$lwd <- rep_len(if (is.numeric(lwd)) lwd else 2, seg$by$ll)
  if (!"lty" %in% names(seg)) {
    seg$lty <- rep_len(
      if (!ck$ltym && !ck$lty) {
        lty
      } else if (ck$cbleg && ck$cbb && seg$by$ll == length(cba$by)) {
        as.numeric(cba$by)
      } else if (ck$lty && lty) {
        seq_len(6)
      } else {
        1
      },
      seg$by$ll
    )
  }
  if (length(seg$cols) == length(seg$lcols)) {
    names(seg$lcols) <- names(seg$cols)
  }
  if (seg$by$e || ck$cbb) {
    names(seg$lwd) <- names(seg$lty) <- if (length(seg$lcols) == seg$by$ll) {
      names(seg$lcols)
    } else if (all(c(length(seg$lwd), length(seg$lty)) == length(seg$cols))) {
      names(seg$cols)
    } else {
      seg$by$l
    }
  }
  lega$lwd <- if (seg$by$ll == l) {
    seg$lwd
  } else {
    rep_len(if (is.numeric(lwd)) lwd else 2, l)
  }
  lega$lty <- if (seg$by$ll == l) {
    seg$lty
  } else {
    rep_len(
      if (!ck$ltym && !ck$lty) {
        lty
      } else if (ck$lty && lty) {
        seq_len(6)
      } else {
        1
      },
      l
    )
  }
  if (!missing(leg.args)) {
    lega[names(leg.args)] <- leg.args
  }
  if (any(tck <- !names(lega) %in% names(formals(legend)))) {
    warning(
      "dropped items from leg.args: ",
      paste(names(lega)[tck], collapse = ", "),
      call. = FALSE
    )
    lega <- lega[!tck]
  }
  if (
    (ck$legm || !ck$leg) &&
      missing(leg.args) &&
      (sum(strheight(lega$legend, "i")) *
        cex["leg"] *
        1.5 /
        if ("ncol" %in% names(pdo)) {
          pdo$ncol
        } else {
          1
        }) >
        dev.size()[2]
  ) {
    ck$leg <- 0
    if (ck$ltym) seg$lty[] <- 1
  }
  if (ck$leg == 1) {
    if (ck$legm && nc > seg$ll) {
      leg <- which(!seg$lc)[1]
    }
    if (nc > seg$ll && leg <= nc) {
      if (seg$lc[leg] && !drop["bet"]) {
        mm <- which(!seg$lc)
        leg <- mm[which.min(abs(mm - leg))]
      }
      if (seg$lc[leg]) {
        seg$lc[] <- TRUE
        seg$lc[leg] <- FALSE
        seg$lc[seg$lc][bsq <- seq_len(nc - seg$ll - 1) + seg$ll] <- FALSE
        seg$dmat[seg$lc] <- seq_len(seg$ll)
        seg$dmat[leg] <- seg$ll + 1
        seg$lc[leg] <- TRUE
        seg$dmat[!seg$lc] <- bsq + 1
      } else {
        seg$lc[leg] <- TRUE
        seg$dmat[leg] <- seg$ll + 1
        seg$dmat[!seg$lc] <- seq_len(sum(!seg$lc)) + seg$ll + 1
      }
      if (ck$lp) lega$x <- "center"
    } else if (ck$lp) {
      lega$x <- "right"
    }
    if (nc == seg$ll || leg > nc) {
      seg$dmat[seg$dmat == seg$ll + 1] <- nc + 1
      seg$dmat <- rbind(seg$dmat, rep.int(seg$ll + 1, seg$dim[1]))
      ck$legcol <- TRUE
    }
  }
  seg[c("dmat", "lc")] <- lapply(seg[c("dmat", "lc")], t)
  seg$prat <- if (missing(prat) && ck$legcol) {
    lw <- max(
      .4,
      if (ck$legt) strwidth(lega$title, "i"),
      strwidth(ptxt$leg, "i") / if (seg$ll > 1) 1.3 else 1.7
    ) +
      if (all(seg$dim == 1)) .5 else .2
    fw <- (dev.size(units = "in")[1] - lw) / seg$dim[2]
    c(fw, max(fw / 10, lw))
  } else {
    prat
  }
  op <- list(
    oma = c(
      sum(is.character(note) && note != "", ck$lx) + .15,
      ck$ly * .9,
      max(sum((main != "") * 1.8 + if (sum(seg$dim) > 2) .5 else 0, ck$sud), 1),
      .5
    ),
    mar = c(
      if (ck$lx) 2 else 1.5,
      if (ck$ly) 3 else 2.4,
      (ck$sud && (ck$su || ck$c)) *
        ifelse(seg$ll > 1, 2, 0) +
        (ck$sub && sum(seg$dim) > 2) * 1.3,
      0
    ),
    mgp = c(3, .3, 0),
    font.main = 1,
    font.lab = 2,
    cex.main = 1,
    cex.lab = 1,
    cex.axis = 1,
    tcl = -.2,
    pch = 19,
    xpd = NA
  )
  if (length(pdo) != 0) {
    if (any(cpdo <- (npdo <- names(pdo)) %in% names(dop))) {
      ck$mai <- "mai" %in% npdo
      op[npdo[cpdo]] <- pdo[cpdo]
      if ("font.sub" %in% names(op)) {
        op$font.main <- op$font.sub
      }
      if ("cex.sub" %in% names(op)) {
        op$cex.main <- op$cex.sub
      }
      if ("col.sub" %in% names(op)) op$col.main <- op$col.sub
    }
    pdo <- pdo[!cpdo]
  }
  if (!"horiz" %in% names(pdo) && !"ncol" %in% names(leg.args)) {
    lega$ncol <- 1
  }
  if (length(pdo) != 0) {
    if (
      any(
        cpdo <- (npdo %in% names(formals(legend)) & !npdo %in% names(leg.args))
      )
    ) {
      lega[npdo[cpdo]] <- pdo[cpdo]
    }
    if (any(!cpdo)) {
      warning(
        "unused argument",
        if (sum(!cpdo) == 1) ": " else "s: ",
        paste(names(pdo)[!cpdo], collapse = ", "),
        call. = FALSE
      )
    }
  }
  expand_color_code <- function(e) {
    if (is.character(e) && all(grepl("^#[0-9a-f]{3}$", e, TRUE))) {
      paste0(e, substring(e, 2))
    } else {
      e
    }
  }
  pdo <- lapply(pdo, expand_color_code)
  op <- lapply(op, expand_color_code)
  if (dark) {
    op$fg <- op$col <- op$col.axis <- op$col.main <- op$col.sub <- op$col.sub <- "white"
    if (is.null(op$bg) && par("bg") == "white") {
      warning("foreground and background are both white")
    }
  }
  par(op)
  on.exit(par(dop))
  layout(
    seg$dmat,
    c(
      rep.int(seg$prat[1], seg$dim[2]),
      if (ck$legcol) seg$prat[if (length(seg$prat) > 1) 2 else 1]
    )
  )
  success <- FALSE
  ck$scol <- "scols" %in% names(seg)
  for (i in names(cdat)) {
    tryCatch(
      {
        # plotting
        cl <- (if ("list" %in% class(cdat[[i]])) {
          vapply(cdat[[i]], NROW, 0)
        } else {
          nrow(cdat[[i]])
        }) >
          0
        if (any(!cl)) {
          cdat[[i]] <- cdat[[i]][cl]
          if (length(cdat[[i]]) == 0) next
        }
        if (ck$scol) {
          seg$cols <- seg$lcols <- seg$scols[[i]]
        }
        cl <- strsplit(i, ".^^.", fixed = TRUE)[[1]]
        ptxt$sub <- if (is.character(sub)) {
          sub
        } else if (ck$sub) {
          if (seg$ll > 1 || (!missing(ndisp) && ndisp)) {
            paste0(
              if (seg$f1$e) {
                paste0(
                  if (lvn || (ck$mlvn && grepl("^[0-9]", cl[1]))) {
                    paste0(ptxt$bet[1], ": ")
                  },
                  cl[1],
                  if (seg$f2$e) {
                    paste0(
                      ", ",
                      if (lvn || (ck$mlvn && grepl("^[0-9]", cl[2]))) {
                        paste0(ptxt$bet[2], ": ")
                      },
                      cl[2]
                    )
                  }
                )
              },
              if ((length(names(cdat)) > 1 || !missing(ndisp)) && ndisp) {
                paste(", n =", seg$n[i])
              }
            )
          } else {
            ""
          }
        }
        if (
          !is.null(sort) &&
            ck$t != 2 &&
            any(
              class(
                if (seg$by$e) cdat[[i]][[1]][, "x"] else cdat[[i]][, "x"]
              ) %in%
                c("factor", "character")
            )
        ) {
          nsl <- grepl("^[Ff]", as.character(sort))
          sdir <- grepl("^[DdTt]", as.character(sort))
          td <- if (seg$by$e) do.call(rbind, cdat[[i]]) else cdat[[i]]
          td[, "x"] <- as.character(td[, "x"])
          cdat[[i]] <- do.call(
            rbind,
            lapply(
              if (nsl) {
                lvs(td[, "x"])
              } else {
                names(sort(
                  vapply(split(td[, "y"], td[, "x"]), mean, 0, na.rm = TRUE),
                  sdir
                ))
              },
              function(l) td[td[, "x"] == l, , drop = FALSE]
            )
          )
          seg$x$l <- ptxt$l.x <- lvs(cdat[[i]][, "x"])
          cdat[[i]][, "x"] <- factor(cdat[[i]][, "x"], seg$x$l)
          if (seg$by$e) cdat[[i]] <- split(cdat[[i]], cdat[[i]][, "by"])
        }
        if (ck$t == 1) {
          # bar and line
          flipped <- FALSE
          if (
            missing(byx) &&
              ck$mv &&
              any(vapply(
                cdat[[i]],
                function(d) {
                  any(
                    vapply(
                      split(d$y, as.character(d$x)),
                      function(dl) if (length(dl) == 1) 0 else var(dl),
                      0
                    ) ==
                      0
                  )
                },
                TRUE
              ))
          ) {
            byx <- FALSE
          }
          if (
            byx &&
              lim < Inf &&
              seg$by$e &&
              (is.list(cdat[[i]]) && length(cdat[[i]]) > 1)
          ) {
            flipped <- TRUE
            cdat[[i]] <- do.call(rbind, cdat[[i]])
            cdat[[i]][c("x", "by")] <- cdat[[i]][c("by", "x")]
            if (is.numeric(cdat[[i]]$x)) {
              cdat[[i]]$x <- as.character(cdat[[i]]$x)
            }
            cdat[[i]] <- split(cdat[[i]], cdat[[i]]$by)[lvs(cdat[[i]]$by)]
          }
          dl <- if (cl <- "list" %in% class(cdat[[1]])) length(cdat[[i]]) else 1
          mot <- paste0(
            "y~0+",
            paste(
              names(if (cl) cdat[[i]][[1]] else cdat[[i]])[c(2, cvar)],
              collapse = "+"
            )
          )
          m <- pe <- ne <- matrix(
            NA,
            seg$by$ll,
            max(c(1, length(seg$x$l))),
            dimnames = list(seg$by$l, seg$x$l)
          )
          if (flipped) {
            m <- pe <- ne <- t(m)
          }
          rn <- if (nrow(m) == 1) 1 else rownames(m)
          cn <- if (seg$by$e && flipped) seg$by$l else colnames(m)
          for (l in seq_len(dl)) {
            ri <- rn[l]
            td <- if (cl) cdat[[i]][[ri]] else cdat[[i]]
            if (is.null(td)) {
              next
            }
            if (nrow(td) > 1 && length(unique(td$x)) > 1) {
              mo <- lm(mot, data = td)
              ccn <- sub("^x", "", names(mo$coef))
              sus <- which(ccn %in% cn)
              su <- ccn[sus]
              m[ri, su] <- mo$coef[sus]
              if (nrow(td) > 2 && anyDuplicated(td$x)) {
                if (ck$e) {
                  e <- suppressWarnings(summary(update(mo, ~ . - 0))$coef[
                    sus,
                    2
                  ])
                  e <- e[c(2, seq_along(e)[-1])]
                  pe[ri, su] <- m[l, su] + e
                  ne[ri, su] <- m[l, su] - e
                } else {
                  e <- confint(mo)[sus, ]
                  pe[ri, su] <- e[, 2]
                  ne[ri, su] <- e[, 1]
                }
              }
            } else {
              if (nrow(td) == 0) {
                next
              }
              mo <- lapply(
                split(td, td["x"]),
                function(s) {
                  if (nrow(s) == 0) NA else mean(s[is.finite(s[, "y"]), "y"])
                }
              )
              m[ri, ] <- unlist(mo[colnames(m)])
            }
          }
          re <- if (flipped) {
            list(m = t(m), ne = t(ne), pe = t(pe))
          } else {
            list(m = m, ne = ne, pe = pe)
          }
          if (ck$ltm && all(apply(is.na(re$m), 2, any))) {
            drop["x"] <- FALSE
            line.type <- "b"
          }
          dx <- !apply(is.na(re$m), 2, all)
          if (drop["x"]) {
            re <- lapply(re, function(s) s[, dx, drop = FALSE])
          }
          m <- re$m
          ne <- re$ne
          pe <- re$pe
          if (all(mna <- is.na(m))) {
            next
          }
          re <- lapply(re, function(s) {
            na <- is.na(s)
            s[na] <- m[na]
            s[!mna]
          })
          if (ck$el) {
            ck$el <- all(round(re$m - re$ne, 8) != 0)
          }
          lb <- min(re$m) -
            if (!ck$el) {
              round((max(re$m) - min(re$m)) / 10)
            } else {
              max(abs(re$m - re$ne)) * 1.2
            }
          if (ck$b && !ck$el) {
            lb <- lb - (max(re$m) - min(re$m)) * .1
          }
          dm <- dim(m)
          ylim <- if (missing(myl)) {
            c(lb, max(re$m) + if (ck$el) max(abs(re$m - re$pe)) else 0)
          } else {
            myl
          }
          if (ck$leg == 2 && ck$lp) {
            if (!seg$by$e && ncol(m) == 2) {
              lega$x <- "top"
            } else {
              lega$x <- apply(m, 2, function(r) {
                na <- !is.na(r)
                if (any(na)) max(r[na]) else -Inf
              })
              stw <- ncol(m)
              oyl <- if (stw %% 2) 3 else 2
              lega$x <- c("topleft", "top", "topright")[
                if (oyl == 2) -2 else 1:3
              ][which.min(vapply(
                split(
                  lega$x,
                  rep(seq_len(oyl), each = stw / oyl)[seq_len(stw)]
                ),
                mean,
                0,
                na.rm = TRUE
              ))]
              if (is.na(lega$x)) lega$x <- "topright"
            }
          }
          if (any(is.na(ylim))) {
            next
          }
          oyl <- axTicks(2, c(ylim[1], ylim[2], par("yaxp")[3]))
          rn <- if (nrow(m) == 1) colnames(m) else rownames(m)
          colnames(m) <- if (drop["x"] && sum(dx) == ncol(m)) {
            ptxt$l.x[dx]
          } else {
            ptxt$l.x
          }
          stw <- strwidth(colnames(m), "i")
          if (
            (missing(xlas) || xlas > 1) &&
              sum(stw) >
                par("fin")[1] - sum(par("omi")[c(2, 4)]) - dm[2] * .1 &&
              par("fin")[1] > 2.5
          ) {
            xlas <- 3
            if (missing(mxl)) {
              mxl <- c(1, dm[2])
            }
            mh <- c(par("fin")[2] / 2, max(stw))
            par(mai = if (ck$mai) op$mai else c(min(mh) + .25, par("mai")[-1]))
            if (mh[1] < mh[2] && missing(labels.trim)) {
              mh <- round(mh[1] / .1)
              n <- colnames(m)
              ln <- nchar(n) > mh
              colnames(m)[ln] <- sub("$", "...", strtrim(n[ln], mh))
            }
          }
          if (min(re$ne, na.rm = TRUE) >= 0) {
            autori <- FALSE
          }
          rck <- !is.list(seg$cols) && all(rn %in% names(seg$cols))
          if (rck && length(seg$cols) < dm[1]) {
            seg$cols <- rep_len(seg$cols, dm[1])
          }
          if (!rck && ck$ltm && !ck$el) {
            line.type <- "b"
          }
          if (ck$b) {
            if (autori) {
              a <- if (missing(myl)) lb else myl[1]
              a <- a * -1
              m <- m + a
              ne <- ne + a
              pe <- pe + a
              ayl <- oyl + a
              aj <- lapply(re, "+", a)
              ylim <- if (missing(myl)) {
                if (!ck$el) {
                  ylim + a
                } else {
                  c(
                    min(aj$m) - max(abs(aj$m - aj$ne)) * 1.2,
                    max(aj$m) +
                      max(abs(aj$m - aj$pe)) *
                        if (ck$leg == 2 && seg$by$ll > 1) {
                          seg$by$ll^.3 + .7
                        } else {
                          1.2
                        }
                  )
                }
              } else {
                myl + a
              }
            }
            if (dm[1] != 1) {
              rownames(m) <- ptxt$l.by[rn]
            }
            lega[c("lwd", "lty")] <- NULL
            lega[c("pch", "pt.cex", "x.intersp", "y.intersp", "adj")] <- list(
              15,
              2,
              1,
              1.2,
              c(0, .35)
            )
            p <- barplot(
              m,
              beside = TRUE,
              col = if (rck) seg$cols[rn] else seg$cols,
              axes = FALSE,
              axisnames = FALSE,
              border = NA,
              ylab = NA,
              xlab = NA,
              ylim = ylim,
              main = if (ck$sub) ptxt$sub else NA,
              xpd = if ("xpd" %in% names(pdo)) {
                pdo$xpd
              } else if (autori) {
                NA
              } else {
                FALSE
              }
            )
          } else {
            p <- matrix(
              rep.int(seq_len(dm[2]), dm[1]),
              nrow = dm[1],
              byrow = TRUE
            )
            plot(
              NA,
              ylim = ylim,
              xlim = if (missing(mxl)) {
                c(1 - stw[1] / 3, dm[2] + stw[length(stw)] / 3)
              } else {
                mxl
              },
              ylab = NA,
              xlab = NA,
              main = if (ck$sub) ptxt$sub else NA,
              axes = FALSE
            )
            for (a in if (dm[1] == 1) {
              1
            } else if (all(rn %in% names(seg$cols))) {
              rn
            } else {
              seq_len(dm[1])
            }) {
              graphics::lines(
                m[a, ],
                col = seg$cols[[a]],
                lty = seg$lty[[a]],
                lwd = seg$lwd[[a]],
                type = line.type
              )
            }
          }
          if (ck$ileg) {
            lega$legend <- rn
          }
          if (xaxis) {
            axis(
              1,
              colMeans(p),
              colnames(m),
              FALSE,
              las = xlas,
              cex = par("cex.axis"),
              fg = par("col.axis")
            )
          }
          a2a <- list(
            2,
            las = ylas,
            cex = par("cex.axis"),
            fg = par("col.axis")
          )
          if (ck$b && autori) {
            a2a$at <- ayl
            a2a$labels <- formatC(oyl, 2, format = "f")
          }
          if (yaxis) {
            do.call(axis, a2a)
          }
          if (ck$el) {
            te <- round(Reduce("-", list(ne, pe)), 8)
            te[is.na(te)] <- 0
            te <- te == 0
            if (any(te)) {
              ne[te] <- pe[te] <- NA
            }
            arrows(
              p,
              ne,
              p,
              pe,
              lwd = error.lwd,
              col = error.color,
              angle = 90,
              code = 3,
              length = .05
            )
          }
        } else if (ck$t == 2) {
          # density
          if (!is.list(density.args)) {
            density.args <- list()
          }
          fdan <- names(formals(stats::density.default))
          dan <- names(density.args)
          if (any(mdan <- !dan %in% fdan)) {
            warning(
              paste(
                "unused density argument(s):",
                paste(dan[mdan], collapse = ", ")
              ),
              call. = FALSE
            )
            density.args <- density.args[!mdan]
          }
          density.args$give.Rkern <- FALSE
          if (!missing(mxl)) {
            if (!"from" %in% dan) {
              density.args$from <- mxl[1]
            }
            if (!"to" %in% dan) density.args$to <- mxl[2]
          }
          if (!"n" %in% dan) {
            density.args$n <- 512
          }
          n <- density.args$n
          m <- list()
          dl <- if (cl <- "list" %in% class(cdat[[i]])) length(cdat[[i]]) else 1
          rnl <- logical(dl)
          rn <- if (is.data.frame(cdat[[i]])) {
            names(ptxt$l.by)
          } else {
            names(cdat[[i]])
          }
          dx <- dy <- numeric(n * seg$by$ll)
          for (l in seq_len(dl)) {
            tryCatch(
              {
                density.args$x <- (if (cl) cdat[[i]][[l]] else cdat[[i]])[, "y"]
                m[[l]] <- do.call(stats::density, density.args)
                dx[seq_len(n) + n * (l - 1)] <- m[[l]]$x
                dy[seq_len(n) + n * (l - 1)] <- m[[l]]$y
                rnl[l] <- TRUE
              },
              error = function(e) NULL
            )
          }
          names(m) <- rn <- rn[rnl]
          if (seg$by$ll > 1 || (ck$polyo && ck$poly)) {
            plot(
              NA,
              xlim = if (missing(mxl)) range(c(dx, dx)) else mxl,
              ylim = if (missing(myl)) c(0, max(dy)) else myl,
              main = if (ck$sub) ptxt$sub else NA,
              ylab = NA,
              xlab = NA,
              axes = FALSE,
              xpd = if ("xpd" %in% names(pdo)) pdo$xpd else FALSE
            )
            for (l in if (seg$by$ll > 1 && all(rn %in% names(seg$cols))) {
              rn
            } else {
              seq_along(m)
            }) {
              if (ck$poly) {
                polygon(
                  m[[l]],
                  col = adjustcolor(seg$cols[[l]], density.opacity),
                  border = NA
                )
              }
              if (!is.logical(lines) || lines) {
                graphics::lines(
                  m[[l]],
                  col = seg$cols[[l]],
                  lwd = seg$lwd[[l]],
                  lty = seg$lty[[l]]
                )
              }
            }
            if (ck$ileg) lega$legend <- rn
          } else {
            col <- if (length(seg$lcols) > 2) "#555555" else seg$lcols[1]
            if (ck$leg) {
              lega[c("lwd", "lty")] <- NULL
              lega[c("pch", "pt.cex", "x.intersp", "y.intersp", "adj")] <- list(
                15,
                2,
                1,
                1.2,
                c(0, .35)
              )
            }
            y <- (if (cl) cdat[[i]][[1]] else cdat[[i]])[, "y"]
            hp <- hist(y, breaks, plot = FALSE)
            if (ck$cb && length(seg$cols) == nr) {
              nb <- length(hp$counts)
              seg$cols <- vapply(
                split(seg$cols[order(y)], sort(rep_len(seq_len(nb), nr))),
                csf,
                ""
              )
              if (!ckn) {
                seg$cols <- adjustcolor(
                  seg$cols,
                  1,
                  color.offset,
                  color.offset,
                  color.offset
                )
              }
            } else if (!color.lock && (ck$co || length(seg$cols) == 1)) {
              seg$cols[2] <- adjustcolor(
                seg$cols[1],
                1,
                color.offset,
                color.offset,
                color.offset
              )
            }
            hist(
              y,
              breaks,
              FALSE,
              border = if ("border" %in% names(pdo)) pdo$border else par("bg"),
              main = if (ck$sub) ptxt$sub else NA,
              ylab = NA,
              xlab = NA,
              axes = FALSE,
              col = if (length(seg$cols) == 2) seg$cols[2] else seg$cols,
              xlim = if (missing(mxl)) range(hp$breaks) else mxl,
              ylim = if (missing(myl)) c(0, max(c(dy, hp$density))) else myl
            )
            if (!is.logical(lines) || lines) {
              graphics::lines(
                m[[1]],
                col = col,
                lwd = lwd,
                xpd = if ("xpd" %in% names(pdo)) {
                  pdo$xpd
                } else {
                  FALSE
                }
              )
            }
          }
          if (ck$lp && ck$leg == 2) {
            lega$x <- if (mean(dx) > mean(range(dx))) "topleft" else "topright"
          }
          if (xaxis) {
            axis(1, las = xlas, cex = par("cex.axis"), fg = par("col.axis"))
          }
          if (yaxis) {
            axis(2, las = ylas, cex = par("cex.axis"), fg = par("col.axis"))
          }
        } else {
          # scatter
          dl <- if (cl <- "list" %in% class(cdat[[i]])) length(cdat[[i]]) else 1
          rn <- if (is.data.frame(cdat[[i]])) seg$by$l else names(cdat[[i]])
          td <- if (cl) do.call(rbind, cdat[[i]]) else cdat[[i]]
          cx <- td[, "x"]
          cy <- td[, "y"]
          xch <- if (is.numeric(cx) || is.logical(cx)) {
            cx
          } else {
            as.numeric(factor(cx))
          }
          a2a <- list(cex = par("cex.axis"), fg = par("col.axis"))
          if (length(ptxt$l.x) != 0) {
            a2a$tick <- FALSE
            a2a$at <- seq_along(ptxt$l.x)
            a2a$labels <- ptxt$l.x
            if (missing(xlas) || xlas > 1) {
              xlas <- 3
              par(
                mai = if (ck$mai) {
                  op$mai
                } else {
                  c(
                    min(c(par("fin")[2] / 2, max(strwidth(ptxt$l.x, "i")))) +
                      .25,
                    par("mai")[-1]
                  )
                }
              )
            }
          }
          plot(
            NA,
            xlim = if (missing(mxl)) range(xch, na.rm = TRUE) else mxl,
            ylim = if (missing(myl)) {
              c(
                min(cy, na.rm = TRUE),
                max(cy, na.rm = TRUE) +
                  max(cy, na.rm = TRUE) *
                    if (ck$leg == 1 && seg$by$ll < lim) seg$by$ll / 20 else 0
              )
            } else {
              myl
            },
            main = if (ck$sub) ptxt$sub else NA,
            ylab = NA,
            xlab = NA,
            axes = FALSE
          )
          if (yaxis) {
            do.call(
              axis,
              c(
                list(2, las = ylas),
                c(
                  a2a[c("cex", "fg")],
                  if ("yax" %in% names(txt)) {
                    list(
                      at = seq_along(txt$yax),
                      labels = txt$yax,
                      tick = FALSE
                    )
                  }
                )
              )
            )
          }
          if (xaxis) {
            do.call(axis, c(list(1, las = xlas), a2a))
          }
          if (ck$leg > 1) {
            up <- xch[cy >= quantile(cy, na.rm = TRUE)[4]]
            mr <- quantile(xch, na.rm = TRUE)
            if (ck$lp) {
              lega$x <- if (sum(up < mr[2]) > sum(up > mr[4])) {
                "topright"
              } else {
                "topleft"
              }
            }
            if (ck$ileg) lega$legend <- rn
          }
          padj <- if (
            color.lock || ck$cb || (missing(color.offset) && !ck$ltck)
          ) {
            1
          } else {
            color.offset
          }
          ckcn <- all(rn %in% names(seg$cols))
          ckln <- all(rn %in% names(seg$lcols))
          if (!ckln) {
            if (ckcn) {
              seg$lcols <- seg$cols
            } else {
              seg$lcols[] <- if (opacity != 1) {
                adjustcolor("#555555", opacity)
              } else {
                "#555555"
              }
            }
          }
          lwd <- rep_len(if (is.numeric(lwd)) lwd else 2, dl)
          for (l in if (ckcn) rn else seq_len(dl)) {
            td <- if (cl) cdat[[i]][[l]] else cdat[[i]]
            if (is.null(td)) {
              next
            }
            x <- td[, "x"]
            y <- td[, "y"]
            col <- if (ckcn) seg$cols[[l]] else seg$cols
            if (opacity != 1 || padj != 1) {
              col <- adjustcolor(col, opacity, padj, padj, padj)
            }
            if (points && points.first) {
              points(x, y, col = col, cex = cex["points"])
            }
            if (ck$ltck) {
              lt <- if (ck$ltco == "pr" && length(unique(y)) != 2) {
                "li"
              } else {
                ck$ltco
              }
              fit <- if (lt == "e") {
                y
              } else {
                tryCatch(
                  {
                    if (ck$c) {
                      lm(y ~ x + as.matrix(td[, cvar, drop = FALSE]))$fitted
                    } else if (lt == "pr") {
                      yr <- range(y)
                      y <- factor(y, labels = c(0, 1))
                      fit <- predict(glm(y ~ x, binomial))
                      fit <- exp(fit) / (1 + exp(fit))
                      if (!all(yr == c(0, 1))) {
                        fit <- (fit - mean(fit)) * (yr[2] - yr[1]) + mean(yr)
                      }
                      if (max(fit) > yr[2]) fit - (max(fit) - yr[2]) else fit
                    } else {
                      predict(switch(
                        lt,
                        li = lm,
                        lo = loess,
                        sm = smooth.spline
                      )(y ~ x))
                    }
                  },
                  error = function(e) {
                    warning("error estimating line: ", e$message, call. = FALSE)
                    NULL
                  }
                )
              }
              if (!is.null(fit)) {
                if (lt == "e") {
                  xo <- x
                } else if (lt == "sm") {
                  xo <- fit$x
                  fit <- fit$y
                } else {
                  or <- order(x)
                  xo <- x[or]
                  fit <- fit[or]
                }
                graphics::lines(
                  xo,
                  fit,
                  col = seg$lcols[[l]],
                  lty = seg$lty[[l]],
                  lwd = seg$lwd[[l]]
                )
              }
            }
            if (points && !points.first) {
              points(x, y, col = col, cex = cex["points"])
            }
          }
        }
        if (ck$leg == 2) {
          if (ck$lpm) {
            message("click to place the legend")
            lega[c("x", "y")] <- locator(1)
            if (is.null(lega$x)) {
              warning("placing the legend with locator(1) failed")
              lega$y <- NULL
              lega$x <- if (seg$ll > 1) "topright" else "right"
            }
          }
          tf <- par("font")
          par(font = font["leg.title"])
          do.call(legend, lega)
          par(font = tf)
        }
        success <- TRUE
        if (!missing(add)) {
          add_attempt <- tryCatch(
            eval(substitute(add), fdat),
            error = function(e) list(failed = TRUE)
          )
          if (is.list(add_attempt) && isTRUE(add_attempt$failed)) {
            tryCatch(
              eval(substitute(add), parent.frame(1)),
              error = function(e) {
                warning("error from add: ", e$message, call. = FALSE)
              }
            )
          }
        }
      },
      error = function(e) {
        dev.off()
        stop(e)
      }
    )
  }
  if (!success) {
    stop("failed to make any plots with the current input", call. = FALSE)
  }
  if (ck$leg == 1) {
    if (all(par("mfg")[1:2] != 0)) {
      plot.new()
      if (ck$b) {
        lega[c("pch", "pt.cex", "x.intersp", "y.intersp", "adj")] <- list(
          15,
          2,
          1,
          1.2,
          c(0, .35)
        )
      }
      if (ck$lpm) {
        message("click to place the legend")
        lega[c("x", "y")] <- locator(1)
        if (is.null(lega$x)) {
          warning("placing the legend with locator(1) failed")
          lega$y <- NULL
          lega$x <- if (seg$ll > 1) "topright" else "right"
        }
      }
      tf <- par("font")
      par(font = font["leg.title"])
      do.call(legend, lega)
      par(font = tf)
    } else {
      warning("legend positioning failed", call. = FALSE)
    }
  }
  if (ck$sud && any(ck$su, ck$c, is.character(sud))) {
    mtext(
      if (is.character(sud)) {
        sud
      } else {
        gsub(
          ", (?=[A-z0-9 ]+$)",
          ifelse(length(ptxt$cov) > 2, ", & ", " & "),
          gsub(
            "^ | $",
            "",
            paste0(
              if (ck$su) {
                paste(
                  "Subset:",
                  paste0(txt$su[1], if (length(txt$su) != 1) "...")
                )
              },
              if (ck$su && ck$c) ", ",
              if (ck$c) {
                paste(
                  if (ck$t == 1) "Covariates:" else "Line adjustment:",
                  paste(ptxt$cov, collapse = ", ")
                )
              }
            )
          ),
          TRUE,
          TRUE
        )
      },
      3,
      0,
      TRUE,
      cex = cex["sud"],
      font = font["sud"]
    )
  }
  mtext(
    main,
    3,
    if (ck$sud) 1.5 else .5,
    TRUE,
    cex = cex["title"],
    font = font["title"]
  )
  mtext(ylab, 2, -.2, TRUE, cex = par("cex.lab"), font = par("font.lab"))
  mtext(xlab, 1, 0, TRUE, cex = par("cex.lab"), font = par("font.lab"))
  if (is.character(note)) {
    mtext(
      note,
      1,
      ck$lx,
      TRUE,
      adj = if (ck$ly) 0 else .01,
      font = font["note"],
      cex = cex["note"]
    )
  }
  if (
    save ||
      (missing(save) &&
        any(!missing(format), !missing(file.name), !missing(dims)))
  ) {
    tryCatch(
      {
        if (is.character(format) || is.name(format)) {
          t <- as.character(format)
          format <- eval(parse(text = t))
        } else {
          t <- deparse(substitute(format))
        }
        if (is.function(format)) {
          t <- sub("^[^:]*::", "", t)
        }
        tt <- if (any(grepl("cairo", t, TRUE))) {
          paste0(".", tolower(strsplit(t, "_|Cairo")[[1]][2]))
        } else if (t == "postscript") {
          ".ps"
        } else {
          paste0(".", t)
        }
        if (missing(dims) && grepl("jpeg|png|tiff|bmp|bit", t, TRUE)) {
          dims <- dev.size(units = "px")
        }
        fn <- paste0(
          if (main == "" || !missing(file.name)) {
            sub("\\.[^.]+$", "", file.name)
          } else {
            gsub("\\s+", "_", gsub("^ +| +$|  ", "", main))
          },
          tt
        )
        dev.copy(format, fn, width = dims[1], height = dims[2])
        dev.off()
        if (file.exists(fn)) {
          message("image saved: ", fn)
        } else {
          warning("failed to save image")
        }
      },
      error = function(e) {
        warning("unable to save image: ", e$message, call. = FALSE)
      }
    )
  }
  invisible(list(
    dat = dat,
    cdat = cdat,
    txt = txt,
    ptxt = ptxt,
    seg = seg,
    ck = ck,
    lega = lega,
    fmod = fmod
  ))
}

#' splot colors
#'
#' Get a prespecified set of 9 colors, or a set of graded or random, potentially grouped colors.
#' @param x dictates the number and shade of colors. If a single value, returns that many samples of the
#'   first \code{seed} entry. If a vector, returns a color for each entry. If numeric, a single seed color
#'   is sampled in order of the vector. If a character or factor, a separate seed color is assigned to
#'   each level, then sampled within levels. Values or vectors in a list are each assigned a seed color.
#' @param by a vector to group \code{x} by; each level is assigned a seed color.
#' @param seed a vector of color names or codes to adjust from, lining up with levels of \code{x} or
#'   \code{by}, or the name of a palette, partially matching \code{'bright'}, \code{'dark'},
#'   \code{'pastel'}, or \code{'grey'}.
#' @param brightness adjusts the RGB values of the seed color, usually between -1 and 1.
#' @param luminance adjusts the white levels of the seed color, usually between -1 and 1.
#' @param opacity sets the opacity of the seed color, between 0 and 1.
#' @param extend if \code{method='scale'}, extends the range of the gradient beyond the sampled range,
#'   making for more similar colors (defaults is .5, with 0 sampling the full range). If
#'   \code{method='related'}, increases the amount any of the RGB values can be adjusted, making for
#'   potentially more different colors (default is 2).
#' @param lighten logical; if \code{TRUE}, scaled colors are lightened instead of darkened. Only
#'   applicable if \code{method='scale'}.
#' @param shuffle logical; if \code{TRUE}, scaled colors are shuffled. Only applicable if
#'   \code{method='scale'}.
#' @param flat logical; if \code{FALSE} and \code{x} is a character, factor, or list, or \code{by} is not
#'   missing, a list is returned.
#' @param method a character setting the sampling method: If \code{'related'} (\code{'^rel|^ran|^o'}),
#'   RGB values are freely adjusted, resulting in similar colors. If \code{'none'} (\code{'^no|^f|^bin'}),
#'   Seed colors are simply repeated in each level (sampling is off). Otherwise, RGB values are adjusted
#'   together, resulting in a gradient.
#' @param grade logical; if \code{TRUE}, seeds are adjusted on the scale of numeric \code{x}s.
#'   Otherwise, seeds are adjusted in even steps along numeric \code{x}s.
#' @param decreasing logical; if \code{FALSE}, assigns colors to numeric \code{x}s in increasing order.
#' @param nas value to replace missing values with.
#' @return A character vector of color codes, or a list of such vectors if \code{flat} if \code{FALSE}.
#' @details
#' If \code{x} and \code{by} are not specified (or are characters with a length of 1, in which case they
#' are treated as \code{seed}), only the seed palette is returned.
#'
#' To expand on a palette, seed colors are assigned to groups, and variants of each seed are assigned to
#' values or levels within groups, or randomly or as a gradient if there are no values or level to assign to.
#'
#' Seed colors are assigned to groups. If \code{x} is a character or factor and no \code{by} has been
#' specified, groups are the unique levels of \code{x}. If \code{by} is specified and is a character or
#' factor, or has fewer than 10 unique levels, groups are levels of \code{by}. If \code{x} is a list,
#' groups are list entries.
#'
#' The number of variants for each seed color is determined either by a value (if the value has a length
#' of 1; e.g., \code{x=10}), the vector's length (if \code{x} is numeric), or the count of the given level
#' (if \code{x} is a factor or character vector).
#'
#' @examples
#' # including no arguments or just a palette name will only return
#' # the palette as a character vector
#' pastel_palette <- splot.color()
#' dark_palette <- splot.color("dark")
#'
#' # entering a number for x will generate that many variants of the first seed color
#' red_scale <- splot.color(10, "red")
#'
#' # entering a list of values as x will return that many variants of the associated seed
#' red_and_green_scales <- splot.color(list(10, 10), seed = c("red", "green"))
#'
#' # this shows gradients of each color in the default palette
#' # a list entered as colorby is treated as arguments to splot.color
#' # periods before the position name refer to the internally assembled data
#' splot(
#'   rep(splot.color(), each = 100) ~ rep.int(seq.int(.01, 1, .01), 9),
#'   colorby = list(.x, .y),
#'   lines = FALSE, mar = c(2, 4, 0, 0), cex = c(points = 3), leg = FALSE, pch = 15,
#'   title = "'pastel' palette", labx = "value of x", laby = "seed color"
#' )
#'
#' # colors graded by value, entered in a list
#' plot(
#'   1:30, numeric(30),
#'   pch = 15, cex = 10,
#'   col = splot.color(list(1:8, c(7:1, 1:7), 8:1))
#' )
#'
#' # comparing sampling methods:
#' #   on top are 1000 similar colors, with different RGB ratios
#' #   on bottom are 268 colors with the same RGB ratio at different levels
#' splot(
#'   c(rnorm(1000), rnorm(1000, 10)) ~ rnorm(2000),
#'   lines = FALSE,
#'   colors = c(splot.color(1000), splot.color(1000, method = "related"))
#' )
#'
#' @export

splot.color <- function(
  x = NULL,
  by = NULL,
  seed = "pastel",
  brightness = 0,
  luminance = 0,
  opacity = 1,
  extend = .7,
  lighten = FALSE,
  shuffle = FALSE,
  flat = TRUE,
  method = "scale",
  grade = FALSE,
  decreasing = FALSE,
  nas = "#000000"
) {
  sets <- list(
    bright = c(
      "#45FF00",
      "#BA00FF",
      "#000000",
      "#FF0000",
      "#FFFD00",
      "#003DFF",
      "#00F2F8",
      "#999999",
      "#FF891B"
    ),
    dark = c(
      "#1B8621",
      "#681686",
      "#2A2A2A",
      "#7C0D0D",
      "#B5BC00",
      "#241C80",
      "#1A7E8B",
      "#666666",
      "#B06622"
    ),
    pastel = c(
      "#82C473",
      "#A378C0",
      "#616161",
      "#9F5C61",
      "#D3D280",
      "#6970B2",
      "#78C4C2",
      "#454744",
      "#D98C82"
    ),
    grey = function(n) grey(.2:n / (n + n * if (n < 10) .1 else .3))
  )
  if (
    missing(seed) &&
      is.character(x) &&
      (length(x) == 1 || all(tolower(x) %in% colors()))
  ) {
    seed <- x
    x <- numeric(length(seed)) + 1
  }
  if (missing(seed) && is.character(by) && length(by) == 1) {
    seed <- by
    by <- NULL
  }
  seed <- tolower(seed)
  ox <- NULL
  lvs <- function(x) {
    if (is.factor(x)) base::levels(x) else sort(unique(x[!is.na(x)]))
  }
  cn <- ncol(x)
  if (!is.null(cn) && !is.na(cn) && cn > 1) {
    if (is.null(by)) {
      by <- x[, 2]
    }
    x <- x[, 1]
  } else if (is.list(x) && length(x) == 1) {
    x <- x[[1]]
  }
  if (!is.null(by)) {
    ol <- length(x)
    if (is.null(x)) {
      x <- by
      by <- NULL
    } else if (ol != length(by)) {
      if (is.numeric(by) && length(by) == 1 && by < ol) {
        by <- rep_len(seq_len(by), ol)
      } else {
        by <- NULL
        warning(
          "splot.color: by was dropped as it is not the same length as x",
          call. = FALSE
        )
      }
    }
  }
  if (
    !is.null(x) &&
      (!(is.list(x) || is.numeric(x)) || (is.numeric(x) && !is.null(by)))
  ) {
    if (is.null(by)) {
      ox <- x
      x <- as.list(table(x))[lvs(ox)]
    } else {
      if (is.numeric(by) && length(lvs(by)) > 9) {
        warning("splot.color: only non-numeric bys are accepted", call. = FALSE)
      } else {
        ox <- by <- factor(by, lvs(by))
        x <- split(x, by)
      }
    }
  }
  ol <- length(x)
  if (ol == 1 && is.list(x)) {
    x <- x[[1]]
    ol <- length(x)
    ox <- NULL
  }
  n <- if (ol == 1) x else ol
  if (length(seed) == 1 && grepl("^bri|^dar|^pas|^gr[ae]y", seed)) {
    seed <- match.arg(seed, names(sets))
    seed <- if (seed == "grey") {
      if (n == 1) {
        "#666666"
      } else if (ol == 1) {
        return(sets$grey(n))
      } else {
        sets$grey(n)
      }
    } else {
      sets[[seed]]
    }
    if (is.null(x) || (ol == 1 && n < 2)) {
      return(seed)
    }
  }
  ckno <- grepl("^no|^f|^bin", method, TRUE)
  sc <- if (grepl("^rel|^ran|^o", method, TRUE)) {
    r <- if (missing(extend)) 2 else max(.001, extend)
    function(cc, n) {
      cc <- adjustcolor(cc)
      hdc <- c(0:9, LETTERS[1:6])
      hdc <- outer(hdc, hdc, paste0)
      ccord <- function(cc) {
        cc <- strsplit(cc, "")[[1]][2:7]
        cc <- paste0(cc[c(TRUE, FALSE)], cc[c(FALSE, TRUE)])
        vapply(cc, function(c) which(hdc == c, TRUE), c(0, 0))
      }
      ccode <- function(m) {
        s <- seq_len(16)
        paste0(
          "#",
          paste(
            apply(m, 2, function(cc) {
              hdc[which.min(abs(s - cc[1])), which.min(abs(s - cc[2]))]
            }),
            collapse = ""
          )
        )
      }
      csamp <- function(code, n) {
        n <- max(1, n - 1)
        ocs <- NULL
        code <- ccord(code)
        if (any(ck <- code > 14)) {
          code[ck] <- code[ck] - (code[ck] - 14)
        }
        if (any(ck <- code < 2)) {
          code[ck] <- code[ck] + (2 - code[ck])
        }
        i <- 1
        while (length(ocs) <= n && i < 9999) {
          s <- sample(1:6, 3)
          nc <- code
          nc[s] <- nc[s] + sample(-r:r, 3, TRUE)
          nc <- ccode(nc)
          if (!nc %in% ocs) {
            ocs <- c(ocs, nc)
          }
          i <- i + 1
        }
        if (any(opacity != 1, brightness != 0, luminance != 0)) {
          adj <- 1 + brightness
          ocs <- adjustcolor(
            ocs,
            opacity,
            adj,
            adj,
            adj,
            c(rep(luminance, 3), 0)
          )
        }
        if (length(ocs) != n + 1) {
          ocs <- rep_len(ocs, n + 1)
        }
        ocs
      }
      csamp(cc, n)
    }
  } else if (ckno) {
    function(cc, n) {
      ns <- length(n)
      vapply(
        seq_len(ns),
        function(i) {
          adj <- ns / (ns + i - 1) + brightness
          if (lighten) {
            adj <- 1.8 - adj
          }
          adjustcolor(cc, opacity, adj, adj, adj, c(rep(luminance, 3), 0))
        },
        ""
      )
    }
  } else {
    function(cc, n) {
      s <- abs(n - max(n, na.rm = TRUE))
      n <- length(s)
      s <- s / max(s, na.rm = TRUE) * (n - 1) + 1
      r <- max(n, n + n * extend)
      if (!lighten) {
        s <- s + r - max(s, na.rm = TRUE)
      }
      vapply(
        s,
        function(i) {
          adj <- i / r + brightness
          if (lighten) {
            adj <- adj + 1
          }
          adjustcolor(cc, opacity, adj, adj, adj, c(rep(luminance, 3), 0))
        },
        ""
      )
    }
  }
  asc <- function(v, si) {
    n <- length(v)
    if (is.numeric(v)) {
      v <- round(v, 3)
    }
    if (!is.numeric(v) || (n != 1 && !grade)) {
      v <- as.numeric(factor(v, lvs(v)))
    }
    if (!ckno) {
      if (n == 1) {
        v <- seq_len(max(1, v))
      } else if (length(lvs(v)) == 1) {
        v <- seq_along(v)
      }
    }
    n <- length(v)
    l <- lvs(v)
    u <- sort(unique(v), decreasing)
    nu <- length(u)
    pr <- rep(nas, n)
    cols <- if (nu < 2 && (!length(u) || u < 2)) si else sc(si, u)
    v <- factor(v[is.finite(v)], u)
    if (n != nu) {
      cols <- rep(cols, tabulate(v))
    }
    if (shuffle) {
      sample(cols)
    } else {
      cols[order(order(v, decreasing = decreasing))]
    }
  }
  if (!is.list(x)) {
    seed <- asc(x, seed[1])
  } else {
    if (length(seed) < n) {
      seed <- rep_len(seed, n)
    }
    seed <- lapply(seq_len(n), function(i) asc(x[[i]], seed[i]))
    names(seed) <- if (!is.null(names(x))) {
      names(x)
    } else {
      vapply(seed, "[[", "", 1)
    }
    if (flat) {
      seed <- if (!is.null(ox) && all(lvs(ox) %in% names(seed))) {
        by <- as.character(ox)
        for (g in lvs(ox)) {
          su <- !is.na(by) & !is.nan(by) & by == g
          ssu <- sum(su)
          if (is.finite(ssu) && ssu) by[su] <- rep_len(seed[[g]], ssu)
        }
        by
      } else {
        unlist(seed)
      }
    }
  }
  if (!is.list(seed)) {
    seed[
      is.na(seed) | is.nan(seed) | seed %in% c("NA", "NaN", "Inf", "-Inf")
    ] <- nas
  }
  if (opacity == 1) {
    seed <- if (is.list(seed)) {
      lapply(seed, function(s) sub("FF$", "", s))
    } else {
      sub("FF$", "", seed)
    }
  }
  seed
}

#' splot benchmarker
#'
#' Time one or more expressions over several iteration, then plot the distributions of their times.
#' @param ... accepts any number of expressions to be timed. See examples.
#' @param runs the number of overall iterations. Increase to stabilize estimates.
#' @param runsize the number of times each expression is evaluated within each run. Increase to
#'   differentiate estimates (particularly for very fast operations).
#' @param cleanup logical; if \code{TRUE}, garbage collection will be performed before each run.
#'   Garbage collection greatly increases run time, but may result in more stable timings.
#' @param print.names logical; if \code{FALSE}, the entered expressions will be included in the plot
#'   as legend names. Otherwise, (and if the number of expressions is over 5 or the length of any
#'   expression is over 50 characters) expressions are replaced with numbers corresponding to their
#'   entered position.
#' @param limit.outliers logical; if \code{TRUE} (default), times over an upper bound for the given
#'   expression will be set to that upper bound, removing aberrant extremes.
#' @param check_output logical; if \code{TRUE}, the output of each expression is checked with
#'   \code{\link[base]{all.equal}} against that of the first. A warning indicates if any are not
#'   equal, and results are invisibly returned.
#' @param check_args a list of arguments to be passed to \code{\link[base]{all.equal}}, if
#'   \code{check_output} is \code{TRUE}.
#' @param options a list of options to pass on to splot.
#' @return A list:
#' \tabular{ll}{
#'   plot \tab splot output\cr
#'   checks \tab a list of result from all.equal, if \code{check_output} was \code{TRUE}\cr
#'   expressions \tab a list of the entered expressions \cr
#'   summary \tab a matrix of the printed results \cr
#' }
#' @examples
#' # increase the number of runs for more stable estimates
#'
#' # compare ways of looping through a vector
#' splot.bench(
#'   sapply(1:100, "*", 10),
#'   mapply("*", 1:100, 10),
#'   vapply(1:100, "*", 0, 10),
#'   unlist(lapply(1:100, "*", 10)),
#'   runs = 20, runsize = 200
#' )
#'
#' # compare ways of setting all but the maximum value of each row in a matrix to 0
#' if (FALSE) {
#'
#' mat <- matrix(c(rep(1, 4), rep(0, 8)), 4, 3)
#' splot.bench(
#'   t(vapply(seq_len(4), function(r) {
#'     mat[r, mat[r, ] < max(mat[r, ])] <- 0
#'     mat[r, ]
#'   }, numeric(ncol(mat)))),
#'   do.call(rbind, lapply(seq_len(4), function(r) {
#'     mat[r, mat[r, ] < max(mat[r, ])] <- 0
#'     mat[r, ]
#'   })),
#'   do.call(rbind, lapply(seq_len(4), function(r) {
#'     nr <- mat[r, ]
#'     nr[nr < max(nr)] <- 0
#'     nr
#'   })),
#'   {
#'     nm <- mat
#'     for (r in seq_len(4)) {
#'       nr <- nm[r, ]
#'       nm[r, nr < max(nr)] <- 0
#'     }
#'     nm
#'   },
#'   {
#'     nm <- mat
#'     for (r in seq_len(4)) nm[r, nm[r, ] < max(nm[r, ])] <- 0
#'     nm
#'   },
#'   {
#'     nm <- matrix(0, dim(mat)[1], dim(mat)[2])
#'     for (r in seq_len(4)) {
#'       m <- which.max(mat[r, ])
#'       nm[r, m] <- mat[r, m]
#'     }
#'     nm
#'   },
#'   {
#'     ck <- do.call(rbind, lapply(seq_len(4), function(r) {
#'       nr <- mat[r, ]
#'       nr < max(nr)
#'     }))
#'     nm <- mat
#'     nm[ck] <- 0
#'     nm
#'   },
#'   t(apply(mat, 1, function(r) {
#'     r[r < max(r)] <- 0
#'     r
#'   })),
#'   runs = 50,
#'   runsize = 200
#' )
#'
#' }
#' @export

splot.bench <- function(
  ...,
  runs = 20,
  runsize = 200,
  cleanup = FALSE,
  print.names = FALSE,
  limit.outliers = TRUE,
  check_output = TRUE,
  check_args = list(),
  options = list()
) {
  e <- sapply(
    as.character(substitute(list(...)))[-1],
    function(t) parse(text = t)
  )
  e <- e[!duplicated(names(e))]
  es <- length(e)
  if (!es) {
    stop("no expressions found", call. = FALSE)
  }
  ne <- names(e)
  seconds <- matrix(NA, runs, es, dimnames = list(NULL, ne))
  rs <- seq_len(runsize)
  ops <- tryCatch(
    lapply(e, eval, parent.frame(3)),
    error = function(e) {
      stop("one of your expressions breaks:\n", e, call. = FALSE)
    }
  )
  checks <- if (check_output && length(e) != 1) {
    if (!"check.attributes" %in% names(check_args)) {
      check_args$check.attributes <- FALSE
    }
    if (!"check.names" %in% names(check_args)) {
      check_args$check.names <- FALSE
    }
    lapply(ops[-1], function(r) {
      tryCatch(
        do.call(all.equal, c(list(r), list(ops[[1]]), check_args)),
        error = function(e) FALSE
      )
    })
  } else {
    NULL
  }
  if (!is.null(checks) && !all(vapply(checks, isTRUE, TRUE))) {
    warning(
      "some of your expressions do not seem to have similar results as the first;",
      " see the `checks` output.",
      call. = FALSE
    )
  }
  ost <- proc.time()[3]
  cat(
    "benchmarking",
    es,
    "expression(s) in chunks of",
    runsize,
    "per run... \nrun 0 of",
    runs
  )
  fun <- function(e) {
    eval(e, .GlobalEnv)
    NULL
  }
  for (r in seq_len(runs)) {
    for (f in sample(seq_len(es))) {
      if (cleanup) {
        gc(FALSE)
      }
      st <- proc.time()[[3]]
      for (i in rs) {
        fun(e[[f]])
      }
      seconds[r, f] <- proc.time()[[3]] - st
    }
    cat("\rrun", r, "of", runs)
  }
  cat(
    "\rfinished",
    runs,
    "runs in",
    round(proc.time()[3] - ost, 2),
    "seconds       \n\n"
  )
  cat("expressions:\n\n")
  icn <- seq_len(es)
  ne <- gsub("\n", "\n   ", ne, fixed = TRUE)
  for (i in icn) {
    cat(i, ". ", ne[i], "\n", sep = "")
  }
  cat("\n")
  res <- rbind(colSums(seconds), colMeans(seconds))
  res <- rbind(
    res,
    if (min(res[1, ], na.rm = TRUE) == 0) {
      res[1, ] + 1
    } else {
      res[1, ] / min(res[1, ], na.rm = TRUE)
    }
  )
  dimnames(res) <- list(
    c("total time (seconds)", "mean time per run", "times the minimum"),
    icn
  )
  print(round(res, 4))
  if (!print.names) {
    if (!missing(print.names) || es > 5 || any(nchar(names(e)) > 50)) {
      colnames(seconds) <- icn
    }
  }
  if (limit.outliers) {
    for (f in seq_len(es)) {
      qr <- quantile(seconds[, f], c(.25, .75), TRUE)
      qrc <- qr[2] + (qr[2] - qr[1]) * 1.5
      seconds[seconds[, f] > qrc, f] <- qrc
    }
  }
  if (es == 1 && runs == 1) {
    return(list(plot = NULL, summary = res))
  }
  title <- paste("timing of", runs, "runs of", runsize, "calls each")
  if (nrow(seconds) == 1) {
    options$x <- colnames(seconds)
    seconds <- seconds[1, ]
  }
  invisible(list(
    plot = splot(
      seconds,
      title = title,
      labels.filter = FALSE,
      labels.trim = FALSE,
      options = options
    ),
    checks = checks,
    expressions = as.list(unname(e)),
    summary = res
  ))
}

#' splot color contrast ratio
#'
#' Calculates the color contrast ratio between two sets of colors, as defined by the
#' \href{https://www.w3.org/TR/WCAG20/#contrast-ratiodef}{World Wide Web Consortium}.
#' @param color,background A character vector of colors, or a matrix with RGB values across rows.
#' @param plot Logical; if \code{FALSE}, will not plot the results.
#' @return A list with entries for \code{ratio} (contrast ratio),
#' \code{AA} (ratios of at least 4.5), and \code{AAA} (ratios of at least 7).
#' Each entry contains a matrix with colors in rows and backgrounds in columns.
#' @examples
#' # check colors against dark and light backgrounds
#' splot.colorcontrast(c("#FF0000", "#00FF00", "#0000FF"), c("black", "white"))
#'
#' # check contrast between colors
#' splot.colorcontrast(c("red", "green", "blue"), c("red", "green", "blue"))
#'
#' # see when shades of a color cross thresholds on a given background
#' splot.colorcontrast(splot.color(1:10, seed = "#a388b5"), "#101010")
#' @export

splot.colorcontrast <- function(color, background = "#ffffff", plot = TRUE) {
  oc <- color
  ob <- background
  adj <- c(0.2126, 0.7152, 0.0722)
  if (is.character(color)) {
    color <- col2rgb(color)
  }
  if (is.null(dim(color))) {
    color <- matrix(color, 3)
  }
  if (is.character(background)) {
    background <- col2rgb(background)
  }
  if (is.null(dim(background))) {
    background <- matrix(background, 3)
  }
  color <- color / 255
  su <- color <= .03928
  if (any(su)) {
    color[su] <- color[su] / 12.92
  }
  color[!su] <- ((color[!su] + .055) / 1.055)^2.4
  color <- colSums(color * adj)
  background <- background / 255
  su <- background <= .03928
  if (any(su)) {
    background[su] <- background[su] / 12.92
  }
  background[!su] <- ((background[!su] + .055) / 1.055)^2.4
  background <- colSums(background * adj)
  r <- vapply(
    background,
    function(bg) {
      su <- bg > color
      color[su] <- (bg + .05) / (color[su] + .05)
      color[!su] <- (color[!su] + .05) / (bg + .05)
      color
    },
    color
  )
  if (is.null(dimnames(r))) {
    r <- matrix(r, length(color))
  }
  rownames(r) <- if (is.character(oc)) {
    oc
  } else {
    paste0("color_", seq_along(color))
  }
  colnames(r) <- if (is.character(ob)) {
    ob
  } else {
    paste0("background_", seq_along(background))
  }
  if (plot) {
    data <- data.frame(
      Contrast = as.numeric(r),
      Background = rep(colnames(r), each = nrow(r)),
      Color = rep(rownames(r), ncol(r))
    )
    splot(
      Contrast ~ Color,
      data,
      between = "Background",
      type = "bar",
      title = FALSE,
      colors = data$Color,
      ndisp = FALSE,
      sort = FALSE,
      add = {
        abline(h = 4.5, col = "#a52600", xpd = FALSE)
        abline(h = 7, col = "#0050a5", xpd = FALSE, lty = 2)
      },
      note = "The solid red line is the AA threshold, and the dashed blue line is the AAA threshold."
    )
  }
  list(ratio = r, AA = r >= 4.5, AAA = r >= 7)
}

#' splot color average
#'
#' Calculates the average of a set of colors, returning its Hex code.
#' @param ... color codes or names as characters.
#' @return The calculated color code.
#' @examples
#' # average of red and blue
#' plot(
#'   1:3, numeric(3),
#'   pch = 15, cex = 20, xlim = c(0, 4),
#'   col = c("red", splot.colormean("red", "blue"), "blue")
#' )
#'
#' # average of a set
#' x <- rnorm(100)
#' set <- splot.color(x, method = "related")
#' splot(
#'   x ~ rnorm(100),
#'   colors = set,
#'   add = points(0, 0, pch = 15, cex = 10, col = splot.colormean(set))
#' )
#' @export

splot.colormean <- function(...) {
  hdc <- c(0:9, LETTERS[1:6])
  hdc <- outer(hdc, hdc, paste0)
  s <- seq_len(16)
  ccs <- adjustcolor(unlist(list(...), use.names = FALSE))
  paste(
    c(
      "#",
      apply(
        Reduce(
          "+",
          lapply(ccs, function(cc) {
            cc <- strsplit(cc, "")[[1]][2:7]
            cc <- paste0(cc[c(TRUE, FALSE)], cc[c(FALSE, TRUE)])
            vapply(cc, function(c) which(hdc == c, TRUE), numeric(2))
          })
        ) /
          length(ccs),
        2,
        function(cc) {
          hdc[which.min(abs(s - cc[1])), which.min(abs(s - cc[2]))]
        }
      )
    ),
    collapse = ""
  )
}

1		#' splot colors
2		#'
3		#' Get a prespecified set of 9 colors, or a set of graded or random, potentially grouped colors.
4		#' @param x dictates the number and shade of colors. If a single value, returns that many samples of the
5		#' first \code{seed} entry. If a vector, returns a color for each entry. If numeric, a single seed color
6		#' is sampled in order of the vector. If a character or factor, a separate seed color is assigned to
7		#' each level, then sampled within levels. Values or vectors in a list are each assigned a seed color.
8		#' @param by a vector to group \code{x} by; each level is assigned a seed color.
9		#' @param seed a vector of color names or codes to adjust from, lining up with levels of \code{x} or
10		#' \code{by}, or the name of a palette, partially matching \code{'bright'}, \code{'dark'},
11		#' \code{'pastel'}, or \code{'grey'}.
12		#' @param brightness adjusts the RGB values of the seed color, usually between -1 and 1.
13		#' @param luminance adjusts the white levels of the seed color, usually between -1 and 1.
14		#' @param opacity sets the opacity of the seed color, between 0 and 1.
15		#' @param extend if \code{method='scale'}, extends the range of the gradient beyond the sampled range,
16		#' making for more similar colors (defaults is .5, with 0 sampling the full range). If
17		#' \code{method='related'}, increases the amount any of the RGB values can be adjusted, making for
18		#' potentially more different colors (default is 2).
19		#' @param lighten logical; if \code{TRUE}, scaled colors are lightened instead of darkened. Only
20		#' applicable if \code{method='scale'}.
21		#' @param shuffle logical; if \code{TRUE}, scaled colors are shuffled. Only applicable if
22		#' \code{method='scale'}.
23		#' @param flat logical; if \code{FALSE} and \code{x} is a character, factor, or list, or \code{by} is not
24		#' missing, a list is returned.
25		#' @param method a character setting the sampling method: If \code{'related'} (\code{'^rel\|^ran\|^o'}),
26		#' RGB values are freely adjusted, resulting in similar colors. If \code{'none'} (\code{'^no\|^f\|^bin'}),
27		#' Seed colors are simply repeated in each level (sampling is off). Otherwise, RGB values are adjusted
28		#' together, resulting in a gradient.
29		#' @param grade logical; if \code{TRUE}, seeds are adjusted on the scale of numeric \code{x}s.
30		#' Otherwise, seeds are adjusted in even steps along numeric \code{x}s.
31		#' @param decreasing logical; if \code{FALSE}, assigns colors to numeric \code{x}s in increasing order.
32		#' @param nas value to replace missing values with.
33		#' @return A character vector of color codes, or a list of such vectors if \code{flat} if \code{FALSE}.
34		#' @details
35		#' If \code{x} and \code{by} are not specified (or are characters with a length of 1, in which case they
36		#' are treated as \code{seed}), only the seed palette is returned.
37		#'
38		#' To expand on a palette, seed colors are assigned to groups, and variants of each seed are assigned to
39		#' values or levels within groups, or randomly or as a gradient if there are no values or level to assign to.
40		#'
41		#' Seed colors are assigned to groups. If \code{x} is a character or factor and no \code{by} has been
42		#' specified, groups are the unique levels of \code{x}. If \code{by} is specified and is a character or
43		#' factor, or has fewer than 10 unique levels, groups are levels of \code{by}. If \code{x} is a list,
44		#' groups are list entries.
45		#'
46		#' The number of variants for each seed color is determined either by a value (if the value has a length
47		#' of 1; e.g., \code{x=10}), the vector's length (if \code{x} is numeric), or the count of the given level
48		#' (if \code{x} is a factor or character vector).
49		#'
50		#' @examples
51		#' # including no arguments or just a palette name will only return
52		#' # the palette as a character vector
53		#' pastel_palette <- splot.color()
54		#' dark_palette <- splot.color("dark")
55		#'
56		#' # entering a number for x will generate that many variants of the first seed color
57		#' red_scale <- splot.color(10, "red")
58		#'
59		#' # entering a list of values as x will return that many variants of the associated seed
60		#' red_and_green_scales <- splot.color(list(10, 10), seed = c("red", "green"))
61		#'
62		#' # this shows gradients of each color in the default palette
63		#' # a list entered as colorby is treated as arguments to splot.color
64		#' # periods before the position name refer to the internally assembled data
65		#' splot(
66		#' rep(splot.color(), each = 100) ~ rep.int(seq.int(.01, 1, .01), 9),
67		#' colorby = list(.x, .y),
68		#' lines = FALSE, mar = c(2, 4, 0, 0), cex = c(points = 3), leg = FALSE, pch = 15,
69		#' title = "'pastel' palette", labx = "value of x", laby = "seed color"
70		#' )
71		#'
72		#' # colors graded by value, entered in a list
73		#' plot(
74		#' 1:30, numeric(30),
75		#' pch = 15, cex = 10,
76		#' col = splot.color(list(1:8, c(7:1, 1:7), 8:1))
77		#' )
78		#'
79		#' # comparing sampling methods:
80		#' # on top are 1000 similar colors, with different RGB ratios
81		#' # on bottom are 268 colors with the same RGB ratio at different levels
82		#' splot(
83		#' c(rnorm(1000), rnorm(1000, 10)) ~ rnorm(2000),
84		#' lines = FALSE,
85		#' colors = c(splot.color(1000), splot.color(1000, method = "related"))
86		#' )
87		#'
88		#' @export
89
90		splot.color <- function(
91		x = NULL,
92		by = NULL,
93		seed = "pastel",
94		brightness = 0,
95		luminance = 0,
96		opacity = 1,
97		extend = .7,
98		lighten = FALSE,
99		shuffle = FALSE,
100		flat = TRUE,
101		method = "scale",
102		grade = FALSE,
103		decreasing = FALSE,
104		nas = "#000000"
105		) {
106	44x	sets <- list(
107	44x	bright = c(
108	44x	"#45FF00",
109	44x	"#BA00FF",
110	44x	"#000000",
111	44x	"#FF0000",
112	44x	"#FFFD00",
113	44x	"#003DFF",
114	44x	"#00F2F8",
115	44x	"#999999",
116	44x	"#FF891B"
117		),
118	44x	dark = c(
119	44x	"#1B8621",
120	44x	"#681686",
121	44x	"#2A2A2A",
122	44x	"#7C0D0D",
123	44x	"#B5BC00",
124	44x	"#241C80",
125	44x	"#1A7E8B",
126	44x	"#666666",
127	44x	"#B06622"
128		),
129	44x	pastel = c(
130	44x	"#82C473",
131	44x	"#A378C0",
132	44x	"#616161",
133	44x	"#9F5C61",
134	44x	"#D3D280",
135	44x	"#6970B2",
136	44x	"#78C4C2",
137	44x	"#454744",
138	44x	"#D98C82"
139		),
140	44x	grey = function(n) grey(.2:n / (n + n * if (n < 10) .1 else .3))
141		)
142		if (
143	44x	missing(seed) &&
144	44x	is.character(x) &&
145	44x	(length(x) == 1 \|\| all(tolower(x) %in% colors()))
146		) {
147	!	seed <- x
148	!	x <- numeric(length(seed)) + 1
149		}
150	44x	if (missing(seed) && is.character(by) && length(by) == 1) {
151	!	seed <- by
152	!	by <- NULL
153		}
154	44x	seed <- tolower(seed)
155	44x	ox <- NULL
156	44x	lvs <- function(x) {
157	36x	if (is.factor(x)) base::levels(x) else sort(unique(x[!is.na(x)]))
158		}
159	44x	cn <- ncol(x)
160	44x	if (!is.null(cn) && !is.na(cn) && cn > 1) {
161	!	if (is.null(by)) {
162	!	by <- x[, 2]
163		}
164	!	x <- x[, 1]
165	44x	} else if (is.list(x) && length(x) == 1) {
166	!	x <- x[[1]]
167		}
168	44x	if (!is.null(by)) {
169	2x	ol <- length(x)
170	2x	if (is.null(x)) {
171	!	x <- by
172	!	by <- NULL
173	2x	} else if (ol != length(by)) {
174	!	if (is.numeric(by) && length(by) == 1 && by < ol) {
175	!	by <- rep_len(seq_len(by), ol)
176		} else {
177	!	by <- NULL
178	!	warning(
179	!	"splot.color: by was dropped as it is not the same length as x",
180	!	call. = FALSE
181		)
182		}
183		}
184		}
185		if (
186	44x	!is.null(x) &&
187	44x	(!(is.list(x) \|\| is.numeric(x)) \|\| (is.numeric(x) && !is.null(by)))
188		) {
189	2x	if (is.null(by)) {
190	!	ox <- x
191	!	x <- as.list(table(x))[lvs(ox)]
192		} else {
193	2x	if (is.numeric(by) && length(lvs(by)) > 9) {
194	!	warning("splot.color: only non-numeric bys are accepted", call. = FALSE)
195		} else {
196	2x	ox <- by <- factor(by, lvs(by))
197	2x	x <- split(x, by)
198		}
199		}
200		}
201	44x	ol <- length(x)
202	44x	if (ol == 1 && is.list(x)) {
203	!	x <- x[[1]]
204	!	ol <- length(x)
205	!	ox <- NULL
206		}
207	44x	n <- if (ol == 1) x else ol
208	44x	if (length(seed) == 1 && grepl("^bri\|^dar\|^pas\|^gr[ae]y", seed)) {
209	41x	seed <- match.arg(seed, names(sets))
210	41x	seed <- if (seed == "grey") {
211	12x	if (n == 1) {
212	12x	"#666666"
213	!	} else if (ol == 1) {
214	!	return(sets$grey(n))
215		} else {
216	!	sets$grey(n)
217		}
218		} else {
219	29x	sets[[seed]]
220		}
221	41x	if (is.null(x) \|\| (ol == 1 && n < 2)) {
222	33x	return(seed)
223		}
224		}
225	11x	ckno <- grepl("^no\|^f\|^bin", method, TRUE)
226	11x	sc <- if (grepl("^rel\|^ran\|^o", method, TRUE)) {
227	1x	r <- if (missing(extend)) 2 else max(.001, extend)
228	1x	function(cc, n) {
229	1x	cc <- adjustcolor(cc)
230	1x	hdc <- c(0:9, LETTERS[1:6])
231	1x	hdc <- outer(hdc, hdc, paste0)
232	1x	ccord <- function(cc) {
233	1x	cc <- strsplit(cc, "")[[1]][2:7]
234	1x	cc <- paste0(cc[c(TRUE, FALSE)], cc[c(FALSE, TRUE)])
235	1x	vapply(cc, function(c) which(hdc == c, TRUE), c(0, 0))
236		}
237	1x	ccode <- function(m) {
238	5x	s <- seq_len(16)
239	5x	paste0(
240		"#",
241	5x	paste(
242	5x	apply(m, 2, function(cc) {
243	15x	hdc[which.min(abs(s - cc[1])), which.min(abs(s - cc[2]))]
244		}),
245	5x	collapse = ""
246		)
247		)
248		}
249	1x	csamp <- function(code, n) {
250	1x	n <- max(1, n - 1)
251	1x	ocs <- NULL
252	1x	code <- ccord(code)
253	1x	if (any(ck <- code > 14)) {
254	!	code[ck] <- code[ck] - (code[ck] - 14)
255		}
256	1x	if (any(ck <- code < 2)) {
257	!	code[ck] <- code[ck] + (2 - code[ck])
258		}
259	1x	i <- 1
260	1x	while (length(ocs) <= n && i < 9999) {
261	5x	s <- sample(1:6, 3)
262	5x	nc <- code
263	5x	nc[s] <- nc[s] + sample(-r:r, 3, TRUE)
264	5x	nc <- ccode(nc)
265	5x	if (!nc %in% ocs) {
266	5x	ocs <- c(ocs, nc)
267		}
268	5x	i <- i + 1
269		}
270	1x	if (any(opacity != 1, brightness != 0, luminance != 0)) {
271	!	adj <- 1 + brightness
272	!	ocs <- adjustcolor(
273	!	ocs,
274	!	opacity,
275	!	adj,
276	!	adj,
277	!	adj,
278	!	c(rep(luminance, 3), 0)
279		)
280		}
281	1x	if (length(ocs) != n + 1) {
282	!	ocs <- rep_len(ocs, n + 1)
283		}
284	1x	ocs
285		}
286	1x	csamp(cc, n)
287		}
288	11x	} else if (ckno) {
289	1x	function(cc, n) {
290	!	ns <- length(n)
291	!	vapply(
292	!	seq_len(ns),
293	!	function(i) {
294	!	adj <- ns / (ns + i - 1) + brightness
295	!	if (lighten) {
296	!	adj <- 1.8 - adj
297		}
298	!	adjustcolor(cc, opacity, adj, adj, adj, c(rep(luminance, 3), 0))
299		},
300		""
301		)
302		}
303		} else {
304	9x	function(cc, n) {
305	7x	s <- abs(n - max(n, na.rm = TRUE))
306	7x	n <- length(s)
307	7x	s <- s / max(s, na.rm = TRUE) * (n - 1) + 1
308	7x	r <- max(n, n + n * extend)
309	7x	if (!lighten) {
310	7x	s <- s + r - max(s, na.rm = TRUE)
311		}
312	7x	vapply(
313	7x	s,
314	7x	function(i) {
315	3330x	adj <- i / r + brightness
316	3330x	if (lighten) {
317	!	adj <- adj + 1
318		}
319	3330x	adjustcolor(cc, opacity, adj, adj, adj, c(rep(luminance, 3), 0))
320		},
321		""
322		)
323		}
324		}
325	11x	asc <- function(v, si) {
326	14x	n <- length(v)
327	14x	if (is.numeric(v)) {
328	14x	v <- round(v, 3)
329		}
330	14x	if (!is.numeric(v) \|\| (n != 1 && !grade)) {
331	10x	v <- as.numeric(factor(v, lvs(v)))
332		}
333	14x	if (!ckno) {
334	12x	if (n == 1) {
335	4x	v <- seq_len(max(1, v))
336	8x	} else if (length(lvs(v)) == 1) {
337	2x	v <- seq_along(v)
338		}
339		}
340	14x	n <- length(v)
341	14x	l <- lvs(v)
342	14x	u <- sort(unique(v), decreasing)
343	14x	nu <- length(u)
344	14x	pr <- rep(nas, n)
345	14x	cols <- if (nu < 2 && (!length(u) \|\| u < 2)) si else sc(si, u)
346	14x	v <- factor(v[is.finite(v)], u)
347	14x	if (n != nu) {
348	4x	cols <- rep(cols, tabulate(v))
349		}
350	14x	if (shuffle) {
351	1x	sample(cols)
352		} else {
353	13x	cols[order(order(v, decreasing = decreasing))]
354		}
355		}
356	11x	if (!is.list(x)) {
357	8x	seed <- asc(x, seed[1])
358		} else {
359	3x	if (length(seed) < n) {
360	!	seed <- rep_len(seed, n)
361		}
362	3x	seed <- lapply(seq_len(n), function(i) asc(x[[i]], seed[i]))
363	3x	names(seed) <- if (!is.null(names(x))) {
364	2x	names(x)
365		} else {
366	1x	vapply(seed, "[[", "", 1)
367		}
368	3x	if (flat) {
369	2x	seed <- if (!is.null(ox) && all(lvs(ox) %in% names(seed))) {
370	1x	by <- as.character(ox)
371	1x	for (g in lvs(ox)) {
372	2x	su <- !is.na(by) & !is.nan(by) & by == g
373	2x	ssu <- sum(su)
374	2x	if (is.finite(ssu) && ssu) by[su] <- rep_len(seed[[g]], ssu)
375		}
376	1x	by
377		} else {
378	1x	unlist(seed)
379		}
380		}
381		}
382	11x	if (!is.list(seed)) {
383	10x	seed[
384	10x	is.na(seed) \| is.nan(seed) \| seed %in% c("NA", "NaN", "Inf", "-Inf")
385	10x	] <- nas
386		}
387	11x	if (opacity == 1) {
388	11x	seed <- if (is.list(seed)) {
389	1x	lapply(seed, function(s) sub("FF$", "", s))
390		} else {
391	10x	sub("FF$", "", seed)
392		}
393		}
394	11x	seed
395		}

1		#' splot benchmarker
2		#'
3		#' Time one or more expressions over several iteration, then plot the distributions of their times.
4		#' @param ... accepts any number of expressions to be timed. See examples.
5		#' @param runs the number of overall iterations. Increase to stabilize estimates.
6		#' @param runsize the number of times each expression is evaluated within each run. Increase to
7		#' differentiate estimates (particularly for very fast operations).
8		#' @param cleanup logical; if \code{TRUE}, garbage collection will be performed before each run.
9		#' Garbage collection greatly increases run time, but may result in more stable timings.
10		#' @param print.names logical; if \code{FALSE}, the entered expressions will be included in the plot
11		#' as legend names. Otherwise, (and if the number of expressions is over 5 or the length of any
12		#' expression is over 50 characters) expressions are replaced with numbers corresponding to their
13		#' entered position.
14		#' @param limit.outliers logical; if \code{TRUE} (default), times over an upper bound for the given
15		#' expression will be set to that upper bound, removing aberrant extremes.
16		#' @param check_output logical; if \code{TRUE}, the output of each expression is checked with
17		#' \code{\link[base]{all.equal}} against that of the first. A warning indicates if any are not
18		#' equal, and results are invisibly returned.
19		#' @param check_args a list of arguments to be passed to \code{\link[base]{all.equal}}, if
20		#' \code{check_output} is \code{TRUE}.
21		#' @param options a list of options to pass on to splot.
22		#' @return A list:
23		#' \tabular{ll}{
24		#' plot \tab splot output\cr
25		#' checks \tab a list of result from all.equal, if \code{check_output} was \code{TRUE}\cr
26		#' expressions \tab a list of the entered expressions \cr
27		#' summary \tab a matrix of the printed results \cr
28		#' }
29		#' @examples
30		#' # increase the number of runs for more stable estimates
31		#'
32		#' # compare ways of looping through a vector
33		#' splot.bench(
34		#' sapply(1:100, "*", 10),
35		#' mapply("*", 1:100, 10),
36		#' vapply(1:100, "*", 0, 10),
37		#' unlist(lapply(1:100, "*", 10)),
38		#' runs = 20, runsize = 200
39		#' )
40		#'
41		#' # compare ways of setting all but the maximum value of each row in a matrix to 0
42		#' if (FALSE) {
43		#'
44		#' mat <- matrix(c(rep(1, 4), rep(0, 8)), 4, 3)
45		#' splot.bench(
46		#' t(vapply(seq_len(4), function(r) {
47		#' mat[r, mat[r, ] < max(mat[r, ])] <- 0
48		#' mat[r, ]
49		#' }, numeric(ncol(mat)))),
50		#' do.call(rbind, lapply(seq_len(4), function(r) {
51		#' mat[r, mat[r, ] < max(mat[r, ])] <- 0
52		#' mat[r, ]
53		#' })),
54		#' do.call(rbind, lapply(seq_len(4), function(r) {
55		#' nr <- mat[r, ]
56		#' nr[nr < max(nr)] <- 0
57		#' nr
58		#' })),
59		#' {
60		#' nm <- mat
61		#' for (r in seq_len(4)) {
62		#' nr <- nm[r, ]
63		#' nm[r, nr < max(nr)] <- 0
64		#' }
65		#' nm
66		#' },
67		#' {
68		#' nm <- mat
69		#' for (r in seq_len(4)) nm[r, nm[r, ] < max(nm[r, ])] <- 0
70		#' nm
71		#' },
72		#' {
73		#' nm <- matrix(0, dim(mat)[1], dim(mat)[2])
74		#' for (r in seq_len(4)) {
75		#' m <- which.max(mat[r, ])
76		#' nm[r, m] <- mat[r, m]
77		#' }
78		#' nm
79		#' },
80		#' {
81		#' ck <- do.call(rbind, lapply(seq_len(4), function(r) {
82		#' nr <- mat[r, ]
83		#' nr < max(nr)
84		#' }))
85		#' nm <- mat
86		#' nm[ck] <- 0
87		#' nm
88		#' },
89		#' t(apply(mat, 1, function(r) {
90		#' r[r < max(r)] <- 0
91		#' r
92		#' })),
93		#' runs = 50,
94		#' runsize = 200
95		#' )
96		#'
97		#' }
98		#' @export
99
100		splot.bench <- function(
101		...,
102		runs = 20,
103		runsize = 200,
104		cleanup = FALSE,
105		print.names = FALSE,
106		limit.outliers = TRUE,
107		check_output = TRUE,
108		check_args = list(),
109		options = list()
110		) {
111	1x	e <- sapply(
112	1x	as.character(substitute(list(...)))[-1],
113	1x	function(t) parse(text = t)
114		)
115	1x	e <- e[!duplicated(names(e))]
116	1x	es <- length(e)
117	1x	if (!es) {
118	!	stop("no expressions found", call. = FALSE)
119		}
120	1x	ne <- names(e)
121	1x	seconds <- matrix(NA, runs, es, dimnames = list(NULL, ne))
122	1x	rs <- seq_len(runsize)
123	1x	ops <- tryCatch(
124	1x	lapply(e, eval, parent.frame(3)),
125	1x	error = function(e) {
126	!	stop("one of your expressions breaks:\n", e, call. = FALSE)
127		}
128		)
129	1x	checks <- if (check_output && length(e) != 1) {
130	1x	if (!"check.attributes" %in% names(check_args)) {
131	1x	check_args$check.attributes <- FALSE
132		}
133	1x	if (!"check.names" %in% names(check_args)) {
134	1x	check_args$check.names <- FALSE
135		}
136	1x	lapply(ops[-1], function(r) {
137	1x	tryCatch(
138	1x	do.call(all.equal, c(list(r), list(ops[[1]]), check_args)),
139	1x	error = function(e) FALSE
140		)
141		})
142		} else {
143	!	NULL
144		}
145	1x	if (!is.null(checks) && !all(vapply(checks, isTRUE, TRUE))) {
146	!	warning(
147	!	"some of your expressions do not seem to have similar results as the first;",
148	!	" see the `checks` output.",
149	!	call. = FALSE
150		)
151		}
152	1x	ost <- proc.time()[3]
153	1x	cat(
154	1x	"benchmarking",
155	1x	es,
156	1x	"expression(s) in chunks of",
157	1x	runsize,
158	1x	"per run... \nrun 0 of",
159	1x	runs
160		)
161	1x	fun <- function(e) {
162	40x	eval(e, .GlobalEnv)
163	40x	NULL
164		}
165	1x	for (r in seq_len(runs)) {
166	20x	for (f in sample(seq_len(es))) {
167	40x	if (cleanup) {
168	!	gc(FALSE)
169		}
170	40x	st <- proc.time()[[3]]
171	40x	for (i in rs) {
172	40x	fun(e[[f]])
173		}
174	40x	seconds[r, f] <- proc.time()[[3]] - st
175		}
176	20x	cat("\rrun", r, "of", runs)
177		}
178	1x	cat(
179	1x	"\rfinished",
180	1x	runs,
181	1x	"runs in",
182	1x	round(proc.time()[3] - ost, 2),
183	1x	"seconds \n\n"
184		)
185	1x	cat("expressions:\n\n")
186	1x	icn <- seq_len(es)
187	1x	ne <- gsub("\n", "\n ", ne, fixed = TRUE)
188	1x	for (i in icn) {
189	2x	cat(i, ". ", ne[i], "\n", sep = "")
190		}
191	1x	cat("\n")
192	1x	res <- rbind(colSums(seconds), colMeans(seconds))
193	1x	res <- rbind(
194	1x	res,
195	1x	if (min(res[1, ], na.rm = TRUE) == 0) {
196	!	res[1, ] + 1
197		} else {
198	1x	res[1, ] / min(res[1, ], na.rm = TRUE)
199		}
200		)
201	1x	dimnames(res) <- list(
202	1x	c("total time (seconds)", "mean time per run", "times the minimum"),
203	1x	icn
204		)
205	1x	print(round(res, 4))
206	1x	if (!print.names) {
207	1x	if (!missing(print.names) \|\| es > 5 \|\| any(nchar(names(e)) > 50)) {
208	!	colnames(seconds) <- icn
209		}
210		}
211	1x	if (limit.outliers) {
212	1x	for (f in seq_len(es)) {
213	2x	qr <- quantile(seconds[, f], c(.25, .75), TRUE)
214	2x	qrc <- qr[2] + (qr[2] - qr[1]) * 1.5
215	2x	seconds[seconds[, f] > qrc, f] <- qrc
216		}
217		}
218	1x	if (es == 1 && runs == 1) {
219	!	return(list(plot = NULL, summary = res))
220		}
221	1x	title <- paste("timing of", runs, "runs of", runsize, "calls each")
222	1x	if (nrow(seconds) == 1) {
223	!	options$x <- colnames(seconds)
224	!	seconds <- seconds[1, ]
225		}
226	1x	invisible(list(
227	1x	plot = splot(
228	1x	seconds,
229	1x	title = title,
230	1x	labels.filter = FALSE,
231	1x	labels.trim = FALSE,
232	1x	options = options
233		),
234	1x	checks = checks,
235	1x	expressions = as.list(unname(e)),
236	1x	summary = res
237		))
238		}

1		#' splot color contrast ratio
2		#'
3		#' Calculates the color contrast ratio between two sets of colors, as defined by the
4		#' \href{https://www.w3.org/TR/WCAG20/#contrast-ratiodef}{World Wide Web Consortium}.
5		#' @param color,background A character vector of colors, or a matrix with RGB values across rows.
6		#' @param plot Logical; if \code{FALSE}, will not plot the results.
7		#' @return A list with entries for \code{ratio} (contrast ratio),
8		#' \code{AA} (ratios of at least 4.5), and \code{AAA} (ratios of at least 7).
9		#' Each entry contains a matrix with colors in rows and backgrounds in columns.
10		#' @examples
11		#' # check colors against dark and light backgrounds
12		#' splot.colorcontrast(c("#FF0000", "#00FF00", "#0000FF"), c("black", "white"))
13		#'
14		#' # check contrast between colors
15		#' splot.colorcontrast(c("red", "green", "blue"), c("red", "green", "blue"))
16		#'
17		#' # see when shades of a color cross thresholds on a given background
18		#' splot.colorcontrast(splot.color(1:10, seed = "#a388b5"), "#101010")
19		#' @export
20
21		splot.colorcontrast <- function(color, background = "#ffffff", plot = TRUE) {
22	1x	oc <- color
23	1x	ob <- background
24	1x	adj <- c(0.2126, 0.7152, 0.0722)
25	1x	if (is.character(color)) {
26	1x	color <- col2rgb(color)
27		}
28	1x	if (is.null(dim(color))) {
29	!	color <- matrix(color, 3)
30		}
31	1x	if (is.character(background)) {
32	1x	background <- col2rgb(background)
33		}
34	1x	if (is.null(dim(background))) {
35	!	background <- matrix(background, 3)
36		}
37	1x	color <- color / 255
38	1x	su <- color <= .03928
39	1x	if (any(su)) {
40	!	color[su] <- color[su] / 12.92
41		}
42	1x	color[!su] <- ((color[!su] + .055) / 1.055)^2.4
43	1x	color <- colSums(color * adj)
44	1x	background <- background / 255
45	1x	su <- background <= .03928
46	1x	if (any(su)) {
47	!	background[su] <- background[su] / 12.92
48		}
49	1x	background[!su] <- ((background[!su] + .055) / 1.055)^2.4
50	1x	background <- colSums(background * adj)
51	1x	r <- vapply(
52	1x	background,
53	1x	function(bg) {
54	1x	su <- bg > color
55	1x	color[su] <- (bg + .05) / (color[su] + .05)
56	1x	color[!su] <- (color[!su] + .05) / (bg + .05)
57	1x	color
58		},
59	1x	color
60		)
61	1x	if (is.null(dimnames(r))) {
62	1x	r <- matrix(r, length(color))
63		}
64	1x	rownames(r) <- if (is.character(oc)) {
65	1x	oc
66		} else {
67	!	paste0("color_", seq_along(color))
68		}
69	1x	colnames(r) <- if (is.character(ob)) {
70	1x	ob
71		} else {
72	!	paste0("background_", seq_along(background))
73		}
74	1x	if (plot) {
75	1x	data <- data.frame(
76	1x	Contrast = as.numeric(r),
77	1x	Background = rep(colnames(r), each = nrow(r)),
78	1x	Color = rep(rownames(r), ncol(r))
79		)
80	1x	splot(
81	1x	Contrast ~ Color,
82	1x	data,
83	1x	between = "Background",
84	1x	type = "bar",
85	1x	title = FALSE,
86	1x	colors = data$Color,
87	1x	ndisp = FALSE,
88	1x	sort = FALSE,
89	1x	add = {
90	1x	abline(h = 4.5, col = "#a52600", xpd = FALSE)
91	1x	abline(h = 7, col = "#0050a5", xpd = FALSE, lty = 2)
92		},
93	1x	note = "The solid red line is the AA threshold, and the dashed blue line is the AAA threshold."
94		)
95		}
96	1x	list(ratio = r, AA = r >= 4.5, AAA = r >= 7)
97		}

1		#' splot color average
2		#'
3		#' Calculates the average of a set of colors, returning its Hex code.
4		#' @param ... color codes or names as characters.
5		#' @return The calculated color code.
6		#' @examples
7		#' # average of red and blue
8		#' plot(
9		#' 1:3, numeric(3),
10		#' pch = 15, cex = 20, xlim = c(0, 4),
11		#' col = c("red", splot.colormean("red", "blue"), "blue")
12		#' )
13		#'
14		#' # average of a set
15		#' x <- rnorm(100)
16		#' set <- splot.color(x, method = "related")
17		#' splot(
18		#' x ~ rnorm(100),
19		#' colors = set,
20		#' add = points(0, 0, pch = 15, cex = 10, col = splot.colormean(set))
21		#' )
22		#' @export
23
24		splot.colormean <- function(...) {
25	1x	hdc <- c(0:9, LETTERS[1:6])
26	1x	hdc <- outer(hdc, hdc, paste0)
27	1x	s <- seq_len(16)
28	1x	ccs <- adjustcolor(unlist(list(...), use.names = FALSE))
29	1x	paste(
30	1x	c(
31		"#",
32	1x	apply(
33	1x	Reduce(
34		"+",
35	1x	lapply(ccs, function(cc) {
36	2x	cc <- strsplit(cc, "")[[1]][2:7]
37	2x	cc <- paste0(cc[c(TRUE, FALSE)], cc[c(FALSE, TRUE)])
38	2x	vapply(cc, function(c) which(hdc == c, TRUE), numeric(2))
39		})
40		) /
41	1x	length(ccs),
42	1x	2,
43	1x	function(cc) {
44	3x	hdc[which.min(abs(s - cc[1])), which.min(abs(s - cc[2]))]
45		}
46		)
47		),
48	1x	collapse = ""
49		)
50		}