Movatterモバイル変換

#' 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

}

#' 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) {