| 1 |
#' Split Plot |
|
| 2 |
#' |
|
| 3 |
#' A plotting function aimed at automating some common visualization tasks in order to ease data exploration. |
|
| 4 |
#' @param y a formula (see note), or the primary variable(s) to be shown on the y axis (unless \code{x} is not specified).
|
|
| 5 |
#' When not a formula, this can be one or more variables as objects, or names in \code{data}.
|
|
| 6 |
#' @param data a \code{data.frame} to pull variables from. If variables aren't found in \code{data}, they will be looked
|
|
| 7 |
#' for in the environment. |
|
| 8 |
#' @param su a subset to all variables, applied after they are all retrieved from \code{data} or the environment.
|
|
| 9 |
#' @param type determines the type of plot to make, between \code{"bar"}, \code{"line"}, \code{"density"}, or
|
|
| 10 |
#' \code{"scatter"}. If \code{"density"}, \code{x} is ignored. Anything including the first letter of each is accepted
|
|
| 11 |
#' (e.g., \code{type='l'}).
|
|
| 12 |
#' @param split how to split any continuous variables (those with more than \code{lim} levels as factors). Default is
|
|
| 13 |
#' \code{"median"}, with \code{"mean"}, \code{"standard deviation"}, \code{"quantile"}, or numbers as options. If
|
|
| 14 |
#' numbers, the variable is either cut at each value in a vector, or broken into roughly equal chunks. Entering an |
|
| 15 |
#' integer (e.g., \code{split = 3L}) that is greater than 1 will force splitting into segments. Otherwise variables will
|
|
| 16 |
#' 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 |
|
| 17 |
#' greater than the split, or if you enter more than 1 value for split. If a numeric split is not compatible with |
|
| 18 |
#' splitting by value or segment, splitting will default to the median. |
|
| 19 |
#' @param levels a list with entries corresponding to variable names, used to rename and/or reorder factor levels. To |
|
| 20 |
#' reorder a factor, enter a vector of either numbers or existing level names in the new order (e.g., |
|
| 21 |
#' \code{levels =} \code{list(var =} \code{c(3,2,1))}). To rename levels of a factor, enter a character vector the same
|
|
| 22 |
#' length as the number of levels. To rename and reorder, enter a list, with names as the first entry, and order as the |
|
| 23 |
#' second entry (e.g., \code{levels =} \code{list(var =} \code{list(c('a','b','c'),} \code{c(3,2,1)))}). This happens
|
|
| 24 |
#' after variables are split, so names and orders should correspond to the new split levels of split variables. For |
|
| 25 |
#' example, if a continuous variable is median split, it now has two levels ('Under Median' and 'Over Median'), which are
|
|
| 26 |
#' the levels reordering or renaming would apply to. Multiple variables entered as \code{y} can be renamed and sorted
|
|
| 27 |
#' with an entry titled \code{'mv'}.
|
|
| 28 |
#' @param sort specified the order of character or factor \code{x} levels. By default, character or factor \code{x} levels
|
|
| 29 |
#' are sorted alphabetically. \code{FALSE} will prevent this (preserving entered order). \code{TRUE} or \code{'d'} will
|
|
| 30 |
#' sort by levels of \code{y} in decreasing order, and anything else will sort in increasing order.
|
|
| 31 |
#' @param error string; sets the type of error bars to show in bar or line plots, or turns them off. If \code{FALSE}, no
|
|
| 32 |
#' error bars will be shown. Otherwise, the default is \code{"standard error"} (\code{'^s'}), with \code{"confidence
|
|
| 33 |
#' intervals"} (anything else) as an option. |
|
| 34 |
#' @param error.color color of the error bars. Default is \code{'#585858'}.
|
|
| 35 |
#' @param error.lwd line weight of error bars. Default is 2. |
|
| 36 |
#' @param lim numeric; checked against the number of factor levels of each variable. Used to decide which variables should |
|
| 37 |
#' be split, which colors to use, and when to turn off the legend. Default is \code{9}. If set over \code{20}, \code{lim}
|
|
| 38 |
#' is treated as infinite (set to \code{Inf}).
|
|
| 39 |
#' @param lines logical or a string specifying the type of lines to be drawn in scatter plots. By default (and whenever |
|
| 40 |
#' \code{cov} is not missing, or if \code{lines} matches \code{'^li|^lm|^st'}), a prediction line is fitted with
|
|
| 41 |
#' \code{\link[stats]{lm}}. For (potentially) bendy lines, \code{'loess'} (matching \code{'^loe|^po|^cu'}) will use
|
|
| 42 |
#' \code{\link[stats]{loess}}, and \code{'spline'} (\code{'^sm|^sp|^in'}) will use \code{\link[stats]{smooth.spline}}.
|
|
| 43 |
#' If \code{y} is not numeric and has only 2 levels, \code{'probability'} (\code{'^pr|^log'}) will draw probabilities
|
|
| 44 |
#' estimated by a logistic regression (\code{glm(y ~} \code{x, binomial)}). \code{'connected'} (\code{'^e|^co|^d'}) will
|
|
| 45 |
#' draw lines connecting all points, and \code{FALSE} will not draw any lines.
|
|
| 46 |
#' @param colors sets a color theme or manually specifies colors. Default theme is \code{"pastel"}, with \code{"dark"} and
|
|
| 47 |
#' \code{"bright"} as options; these are passed to \code{\link{splot.color}}. If set to \code{"grey"}, or if \code{by}
|
|
| 48 |
#' has more than 9 levels, a grey scale is calculated using \code{\link[grDevices]{gray}}. See the \code{col} parameter
|
|
| 49 |
#' in \code{\link[graphics]{par}} for acceptable manual inputs. To set text and axis colors, \code{col} sets outside
|
|
| 50 |
#' texts (title, sud, labx, laby, and note), \code{col.sub} or \code{col.main} sets the frame titles, and \code{col.axis}
|
|
| 51 |
#' sets the axis text and line colors. To set the color of error bars, use \code{error.color}. For histograms, a vector of
|
|
| 52 |
#' two colors would apply to the density line and bars separately (e.g., for \code{color =} \code{c('red','green')}, the
|
|
| 53 |
#' density line would be red and the histogram bars would be green). See the \code{color.lock} and \code{color.offset}
|
|
| 54 |
#' arguments for more color controls. |
|
| 55 |
#' @param colorby a variable or list of arguments used to set colors and the legend, alternatively to \code{by}. If
|
|
| 56 |
#' \code{by} is not missing, \code{colorby} will be reduced to only the unique combinations of \code{by} and \code{colorby}.
|
|
| 57 |
#' For example, if \code{by} is a participant ID with multiple observations per participant, and \code{by} is a condition
|
|
| 58 |
#' ID which is the same for all observations from a given participant, \code{colorby} would assign a single color to each
|
|
| 59 |
#' participant based on their condition. A list will be treated as a call to \code{\link{splot.color}}, so arguments can be
|
|
| 60 |
#' entered positionally or by name. Data entered directly into splot can be accessed by position name preceded by a |
|
| 61 |
#' period. For example, \code{splot(rnorm(100),} \code{colorby=.y)} would draw a histogram, with bars colored by the value
|
|
| 62 |
#' of \code{y} (\code{rnorm(100)} in this case).
|
|
| 63 |
#' @param ... passes additional arguments to \code{\link[graphics]{par}} or \code{\link[graphics]{legend}}. Arguments before
|
|
| 64 |
#' this can be named partially; those after must by fully named. |
|
| 65 |
#' @param colorby.leg logical; if \code{FALSE}, a legend for \code{colorby} is never drawn. Otherwise, a legend for
|
|
| 66 |
#' \code{colorby} will be drawn if there is no specified \code{by}, or for non-scatter plots (overwriting the usual legend).
|
|
| 67 |
#' @param color.lock logical; if \code{FALSE}, colors will not be adjusted to offset lines from points or histogram bars.
|
|
| 68 |
#' @param color.offset how much points or histogram bars should be offset from the initial color used for lines. Default is |
|
| 69 |
#' 1.1; values greater than 1 lighten, and less than 1 darken. |
|
| 70 |
#' @param color.summary specifies the function used to collapse multiple colors for a single display. Either a string |
|
| 71 |
#' matching one of \code{'mean'} (which uses \code{\link{splot.colormean}} to average RGB values), \code{'median'} (
|
|
| 72 |
#' which treats codes as ordered, and selects that at the rounded median), or \code{'mode'} (which selects the most
|
|
| 73 |
#' common code), or a function which takes color codes in its first argument, and outputs a single color code as a |
|
| 74 |
#' character. |
|
| 75 |
#' @param opacity a number between 0 and 1; sets the opacity of points, lines, and bars. Semi-opaque lines will sometimes |
|
| 76 |
#' not be displayed in the plot window, but will show up when the plot is written to a file. |
|
| 77 |
#' @param dark logical; if \code{TRUE}, sets text and axis colors to \code{"white"}. Defaults to the \code{splot.dark}
|
|
| 78 |
#' option. |
|
| 79 |
#' @param x secondary variable, to be shown in on the x axis. If not specified, \code{type} will be set to \code{'density'}.
|
|
| 80 |
#' If \code{x} is a factor or vector of characters, or has fewer than \code{lim} levels when treated as a factor,
|
|
| 81 |
#' \code{type} will be set to \code{'line'} unless specified.
|
|
| 82 |
#' @param by the 'splitting' variable within each plot, by which the plotted values of \code{x} and \code{y} will be
|
|
| 83 |
#' grouped. |
|
| 84 |
#' @param between a single object or name, or two in a vector (e.g., \code{c(b1, b2)}), the levels of which will determine
|
|
| 85 |
#' the number of plot windows to be shown at once (the cells in a matrix of plots; levels of the first variable as rows, |
|
| 86 |
#' and levels of the second as columns). |
|
| 87 |
#' @param cov additional variables used for adjustment. Bar and line plots include all \code{cov} variables in their
|
|
| 88 |
#' regression models (via \code{\link[stats]{lm}}, e.g., \code{lm(y ~ 0 + x + cov1 + cov2)}) as covariates. Scatter plots
|
|
| 89 |
#' with lines include all \code{cov} variables in the regression model to adjust the prediction line (e.g.,
|
|
| 90 |
#' \code{lm(y ~ x + x^2)}).
|
|
| 91 |
#' \code{\link[graphics]{par}} options \code{col}, \code{mfrow}, \code{oma}, \code{mar}, \code{mgp}, \code{font.main},
|
|
| 92 |
#' \code{cex.main}, \code{font.lab}, \code{tcl}, \code{pch}, \code{lwd}, and \code{xpd} are all set within the function,
|
|
| 93 |
#' but will be overwritten if they are included in the call. For example, \code{col} sets font colors in this case
|
|
| 94 |
#' (as opposed to \code{colors} which sets line and point colors). The default is \code{'#303030'} for a nice dark grey,
|
|
| 95 |
#' but maybe you want to lighten that up: \code{col='#606060'}. After arguments have been applied to
|
|
| 96 |
#' \code{\link[graphics]{par}}, if any have not been used and match a \code{\link[graphics]{legend}} argument, these will
|
|
| 97 |
#' be applied to \code{\link[graphics]{legend}}.
|
|
| 98 |
#' @param line.type a character setting the style of line (e.g., with points at joints) to be drawn in line plots. Default |
|
| 99 |
#' is \code{'b'} if \code{error} is \code{FALSE}, and \code{'l'} otherwise. See the \code{line} argument of
|
|
| 100 |
#' \code{\link[graphics]{plot.default}} for options. \code{line.type='c'} can look nice when there aren't a lot of
|
|
| 101 |
#' overlapping error bars. |
|
| 102 |
#' @param mv.scale determines whether to center and scale multiple \code{y} variables. Does not center or scale by default.
|
|
| 103 |
#' Anything other than \code{'none'} will mean center each numeric \code{y} variable. Anything matching \code{'^t|z|sc'}
|
|
| 104 |
#' will also scale. |
|
| 105 |
#' @param mv.as.x logical; if \code{TRUE}, variable names are displayed on the x axis, and \code{x} is treated as \code{by}.
|
|
| 106 |
#' @param save logical; if \code{TRUE}, an image of the plot is saved to the current working directory.
|
|
| 107 |
#' @param format the type of file to save plots as. Default is \code{cairo_pdf}; see
|
|
| 108 |
#' \code{\link[grDevices]{Devices}} for options.
|
|
| 109 |
#' @param dims a vector of 2 values (\code{c(width, height)}) specifying the dimensions of a plot to save in inches or
|
|
| 110 |
#' pixels depending on \code{format}. Defaults to the dimensions of the plot window.
|
|
| 111 |
#' @param file.name a string with the name of the file to be save (excluding the extension, as this is added depending on |
|
| 112 |
#' \code{format}).
|
|
| 113 |
#' @param myl sets the range of the y axis (\code{ylim} of \code{\link{plot}} or \code{\link[graphics]{barplot}}).
|
|
| 114 |
#' If not specified, this will be calculated from the data. |
|
| 115 |
#' @param mxl sets the range of the x axis (\code{xlim} of \code{\link{plot}}). If not specified, this will be
|
|
| 116 |
#' calculated from the data. |
|
| 117 |
#' @param autori logical; if \code{FALSE}, the origin of plotted bars will be set to 0. Otherwise, bars are adjusted such
|
|
| 118 |
#' that they extend to the bottom of the y axis. |
|
| 119 |
#' @param xlas,ylas numeric; sets the orientation of the x- and y-axis labels. See \code{\link[graphics]{par}}.
|
|
| 120 |
#' @param xaxis,yaxis logical; if \code{FALSE}, the axis will not be drawn.
|
|
| 121 |
#' @param breaks determines the width of histogram bars. See \code{\link[graphics]{hist}}.
|
|
| 122 |
#' @param density.fill logical; \code{FALSE} will turn off polygon fills when they are displayed, \code{TRUE} will replace
|
|
| 123 |
#' histograms with polygons. |
|
| 124 |
#' @param density.opacity opacity of the density polygons, between 0 and 1. |
|
| 125 |
#' @param density.args list of arguments to be passed to \code{\link[stats]{density}}.
|
|
| 126 |
#' @param leg sets the legend inside or outside the plot frames (when a character matching \code{'^i'}, or a character
|
|
| 127 |
#' matching \code{'^o'} or a number respectively), or turns it off (when \code{FALSE}). When inside, a legend is drawn in
|
|
| 128 |
#' each plot frame. When outside, a single legend is drawn either to the right of all plot frames, or within an empty |
|
| 129 |
#' plot frame. By default, this will be determined automatically, tending to set legends outside when there are multiple |
|
| 130 |
#' levels of \code{between}. A number will try and set the legend in an empty frame within the grid of plot frames. If
|
|
| 131 |
#' there are no empty frames, the legend will just go to the side as if \code{leg='outside'}.
|
|
| 132 |
#' @param lpos sets the position of the legend within its frame (whether inside or outside of the plot frames) based on |
|
| 133 |
#' keywords (see \code{\link[graphics]{legend}}. By default, when the legend is outside, \code{lpos} is either
|
|
| 134 |
#' \code{'right'} when the legend is in a right-hand column, or \code{'center'} when in an empty plot frame. When the
|
|
| 135 |
#' legend is inside and \code{lpos} is not specified, the legend will be placed automatically based on the data. Set to
|
|
| 136 |
#' \code{'place'} to manually place the legend; clicking the plot frame will set the top left corner of the legend.
|
|
| 137 |
#' @param lvn level variable name. Logical: if \code{FALSE}, the names of by and between variables will not be shown
|
|
| 138 |
#' before their level (e.g., for a sex variable with a "female" level, "sex: female" would become "female" above each |
|
| 139 |
#' plot window). |
|
| 140 |
#' @param leg.title sets the title of the legend (which is the by variable name by default), or turns it off with |
|
| 141 |
#' \code{FALSE}.
|
|
| 142 |
#' @param leg.args a list passing arguments to the \code{\link[graphics]{legend}} call.
|
|
| 143 |
#' @param title logical or a character: if \code{FALSE}, the main title is turned off. If a character, this will be shown
|
|
| 144 |
#' as the main title. |
|
| 145 |
#' @param labx,laby logical or a character: if \code{FALSE}, the label on the x axis is turned off. If a character, this
|
|
| 146 |
#' will be shown as the axis label. |
|
| 147 |
#' @param lty logical or a vector: if \code{FALSE}, lines are always solid. If a vector, changes line type based on each
|
|
| 148 |
#' value. Otherwise loops through available line types, see \code{\link[graphics]{par}}.
|
|
| 149 |
#' @param lwd numeric; sets the weight of lines in line, density, and scatter plots. Default is 2. See |
|
| 150 |
#' \code{\link[graphics]{par}}.
|
|
| 151 |
#' @param sub affects the small title above each plot showing \code{between} levels; text replaces it, and \code{FALSE}
|
|
| 152 |
#' turns it off. |
|
| 153 |
#' @param note logical; if \code{FALSE}, the note at the bottom about splits and/or lines or error bars is turned off.
|
|
| 154 |
#' @param font named numeric vector: \code{c(title,sud,leg,leg.title,note)}. Sets the font of the title, su display, legend
|
|
| 155 |
#' levels and title, and note. In addition, \code{font.lab} sets the x and y label font, \code{font.sub} sets the font of
|
|
| 156 |
#' the little title in each panel, \code{font.axis} sets the axis label font, and \code{font.main} sets the between level/n
|
|
| 157 |
#' heading font; these are passed to \code{\link[graphics]{par}}. See the input section.
|
|
| 158 |
#' @param cex named numeric vector: \code{c(title,sud,leg,note,points)}. Sets the font size of the title, su display, legend,
|
|
| 159 |
#' note, and points. In addition, \code{cex.lab} sets the x and y label size, \code{cex.sub} sets the size of the little
|
|
| 160 |
#' title in each panel, \code{cex.axis} sets the axis label size, and \code{cex.main} sets the between level/n heading size;
|
|
| 161 |
#' these are passed to \code{\link[graphics]{par}}. See the input section.
|
|
| 162 |
#' @param sud affects the heading for subset and covariates/line adjustments (su display); text replaces it, and |
|
| 163 |
#' \code{FALSE} turns it off.
|
|
| 164 |
#' @param ndisp logical; if \code{FALSE}, n per level is no longer displayed in the subheadings.
|
|
| 165 |
#' @param labels logical; if \code{FALSE}, sets all settable text surrounding the plot to \code{FALSE} (just so you don't
|
|
| 166 |
#' have to set all of them if you want a clean frame). |
|
| 167 |
#' @param labels.filter a regular expression string to be replaced in label texts with a blank space. Default is |
|
| 168 |
#' \code{'_'}, so underscores appearing in the text of labels are replace with blank spaces. Set to
|
|
| 169 |
#' \code{FALSE} to prevent all filtering.
|
|
| 170 |
#' @param labels.trim numeric or logical; the maximum length of label texts (in number of characters). Default is 20, with |
|
| 171 |
#' any longer labels being trimmed. Set to \code{FALSE} to prevent any trimming.
|
|
| 172 |
#' @param points logical; if \code{FALSE}, the points in a scatter plot are no longer drawn.
|
|
| 173 |
#' @param points.first logical; if \code{FALSE}, points are plotted after lines are drawn in a scatter plot, placing lines
|
|
| 174 |
#' behind points. This does not apply to points or lines added in \code{add}, as that is always evaluated after the main
|
|
| 175 |
#' points and lines are drawn. |
|
| 176 |
#' @param byx logical; if \code{TRUE} (default) and \code{by} is specified, regressions for bar or line plots compare
|
|
| 177 |
#' levels of \code{by} for each level of \code{x}. This makes for more intuitive error bars when comparing levels of
|
|
| 178 |
#' \code{by} within a level of \code{x}; otherwise, the model is comparing the difference between the first level of
|
|
| 179 |
#' \code{x} and each of its other levels.
|
|
| 180 |
#' @param drop named logical vector: \code{c(x,by,bet)}. Specifies how levels with no data should be treated. All are
|
|
| 181 |
#' \code{TRUE} by default, meaning only levels with data will be presented, and the layout of \code{between} levels
|
|
| 182 |
#' will be minimized. \code{x} only applies to bar or line plots. \code{by} relates to levels presented in the legend.
|
|
| 183 |
#' If \code{bet} is \code{FALSE}, the layout of \code{between} variables will be strict, with levels of \code{between[1]}
|
|
| 184 |
#' as rows, and levels of \code{between[2]} as columns -- if there are no data at an intersection of levels, the
|
|
| 185 |
#' corresponding panel will be blank. See the input section. |
|
| 186 |
#' @param prat panel ratio, referring to the ratio between plot frames and the legend frame when the legend is out. A |
|
| 187 |
#' single number will make all panels of equal width. A vector of two numbers will adjust the ratio between plot panels |
|
| 188 |
#' and the legend panel. For example, \code{prat=c(3,1)} makes all plot panels a relative width of 3, and the legend frame
|
|
| 189 |
#' a relative width of 1. |
|
| 190 |
#' @param check.height logical; if \code{FALSE}, the height of the plot frame will not be checked before plotting is
|
|
| 191 |
#' attempted. The check tries to avoid later errors, but may prevent plotting when a plot is possible. |
|
| 192 |
#' @param model logical; if \code{TRUE}, the summary of an interaction model will be printed. This model won't always align
|
|
| 193 |
#' with what is plotted since variables may be treated differently, particularly in the case of interactions. |
|
| 194 |
#' @param options a list with named arguments, useful for setting temporary defaults if you plan on using some of the same |
|
| 195 |
#' options for multiple plots (e.g., \code{opt = list(}\code{type = 'bar',} \code{colors = 'grey',}
|
|
| 196 |
#' \code{bg = '#999999');} \code{splot(x ~ y,} \code{options = opt)}).
|
|
| 197 |
#' use \code{\link{quote}} to include options that are to be evaluated within the function (e.g.,
|
|
| 198 |
#' \code{opt =} \code{list(su =} \code{quote(y > 0))}).
|
|
| 199 |
#' @param add evaluated within the function, so you can refer to the objects that are returned, to variable names (those |
|
| 200 |
#' from an entered data frame or entered as arguments), or entered data by their position, preceded by '.' (e.g., |
|
| 201 |
#' \code{mod =} \code{lm(.y~.x)}). Useful for adding things like lines to a plot while the parameters are still
|
|
| 202 |
#' those set by the function (e.g., \code{add =} \code{abline(v =} \code{mean(x),} \code{xpd = FALSE)} for a vertical
|
|
| 203 |
#' line at the mean of x). |
|
| 204 |
#' |
|
| 205 |
#' @return A list containing data and settings is invisibly returned, which might be useful to check for errors. |
|
| 206 |
#' Each of these objects can also be pulled from within \code{add}:
|
|
| 207 |
#' \tabular{ll}{
|
|
| 208 |
#' \code{dat} \tab a \code{data.frame} of processed, unsegmented data.\cr
|
|
| 209 |
#' \code{cdat} \tab a \code{list} of \code{list}s of \code{data.frame}s of processed, segmented data.\cr
|
|
| 210 |
#' \code{txt} \tab a \code{list} of variable names. used mostly to pull variables from \code{data} or the environment.\cr
|
|
| 211 |
#' \code{ptxt} \tab a \code{list} of processed variable and level names. Used mostly for labeling.\cr
|
|
| 212 |
#' \code{seg} \tab a \code{list} containing segmentation information (such as levels) for each variable.\cr
|
|
| 213 |
#' \code{ck} \tab a \code{list} of settings.\cr
|
|
| 214 |
#' \code{lega} \tab a \code{list} of arguments that were or would have been passed to \code{\link[graphics]{legend}}.\cr
|
|
| 215 |
#' \code{fmod} \tab an \code{lm} object if \code{model} is \code{TRUE}, and the model succeeded.
|
|
| 216 |
#' } |
|
| 217 |
#' |
|
| 218 |
#' @section Input: |
|
| 219 |
#' \strong{formulas}
|
|
| 220 |
#' |
|
| 221 |
#' When \code{y} is a formula (has a \code{~}), other variables will be pulled from it:
|
|
| 222 |
#' |
|
| 223 |
#' \code{y ~ x * by * between[1] * between[2] + cov[1] + cov[2] + cov[n]}
|
|
| 224 |
#' |
|
| 225 |
#' If \code{y} has multiple variables, \code{by} is used to identify the variable (it becomes a factor with variable names
|
|
| 226 |
#' as levels), so anything entered as \code{by} is treated as \code{between[1]}, \code{between[1]} is moved to
|
|
| 227 |
#' \code{between[2]}, and \code{between[2]} is discarded with a message.
|
|
| 228 |
#' |
|
| 229 |
#' \strong{named vectors}
|
|
| 230 |
#' |
|
| 231 |
#' Named vector arguments like \code{font}, \code{cex}, and \code{drop} can be set with a single value, positionally, or
|
|
| 232 |
#' with names. If a single value is entered (e.g., \code{drop = FALSE}), this will be applied to each level (i.e.,
|
|
| 233 |
#' \code{c(x = FALSE, by = FALSE, bet = FALSE)}). If more than one value is entered, these will be treated positionally
|
|
| 234 |
#' (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)}).
|
|
| 235 |
#' If values are named, only named values will be set, with other defaults retained (e.g., \code{cex =} \code{c(note = 1.2)}
|
|
| 236 |
#' would be read as \code{c(title = 1.5, sud = .9, leg = .9, note = 1.2, points = 1)}).
|
|
| 237 |
#' |
|
| 238 |
#' @note |
|
| 239 |
#' \strong{x-axis levels text}
|
|
| 240 |
#' |
|
| 241 |
#' If the text of x-axis levels (those corresponding to the levels of \code{x}) are too long, they are hidden before
|
|
| 242 |
#' overlapping. To try and avoid this, by default longer texts are trimmed (dictated by \code{labels.trim}), and at some
|
|
| 243 |
#' point the orientation of level text is changed (settable with \code{xlas}), but you may still see level text missing.
|
|
| 244 |
#' To make these visible, you can reduce \code{labels.trim} from the default of 20 (or rename the levels of that variable),
|
|
| 245 |
#' make the level text vertical (\code{xlas = 3}), or expand your plot window if possible.
|
|
| 246 |
#' |
|
| 247 |
#' \strong{missing levels, lines, and/or error bars}
|
|
| 248 |
#' |
|
| 249 |
#' By default (if \code{drop = TRUE}), levels of \code{x} with no data are dropped, so you may not see every level of your
|
|
| 250 |
#' variable, at all or at a level of \code{by} or \code{between}. Sometimes error bars cannot be estimated (if, say, there
|
|
| 251 |
#' is only one observation at the given level), but lines are still drawn in these cases, so you may sometimes see levels |
|
| 252 |
#' without error bars even when error bars are turned on. Sometimes (particularly when \code{drop['x']} is \code{FALSE}),
|
|
| 253 |
#' you might see floating error bars with no lines drawn to them, or what appear to be completely empty levels. This |
|
| 254 |
#' happens when there is a missing level of \code{x} between two non-missing levels, potentially making an orphaned level
|
|
| 255 |
#' (if a non-missing level is surrounded by missing levels). If there are no error bars for this orphaned level, by default |
|
| 256 |
#' nothing will be drawn to indicate it. If you set \code{line.type} to \code{'b'} (or any other type with points), a point
|
|
| 257 |
#' will be drawn at such error-bar-less, orphaned levels. |
|
| 258 |
#' |
|
| 259 |
#' \strong{unexpected failures}
|
|
| 260 |
#' |
|
| 261 |
#' splot tries to clean up after itself in the case of an error, but you may still run into errors that break things before |
|
| 262 |
#' 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 |
|
| 263 |
#' old ones, you might try entering \code{dev.off()} into the console. If new plots look off (splot's
|
|
| 264 |
#' \code{\link[graphics]{par}} settings didn't get reset), you may have to close the plot window to reset
|
|
| 265 |
#' \code{\link[graphics]{par}} (if you're using RStudio, Plots > "Remove Plot..." or "Clear All..."), or restart R.
|
|
| 266 |
#' |
|
| 267 |
#' @examples |
|
| 268 |
#' # simulating data |
|
| 269 |
#' n <- 2000 |
|
| 270 |
#' dat <- data.frame(sapply(c("by", "bet1", "bet2"), function(c) sample(0:1, n, TRUE)))
|
|
| 271 |
#' dat$x <- with( |
|
| 272 |
#' dat, |
|
| 273 |
#' rnorm(n) + by * -.4 + by * bet1 * -.3 + by * bet2 * |
|
| 274 |
#' .3 + bet1 * bet2 * .9 - .8 + rnorm(n, 0, by) |
|
| 275 |
#' ) |
|
| 276 |
#' dat$y <- with( |
|
| 277 |
#' dat, |
|
| 278 |
#' x * .2 + by * .3 + bet2 * -.6 + bet1 * bet2 * .8 + x * |
|
| 279 |
#' by * bet1 * -.5 + x * by * bet1 * bet2 * -.5 |
|
| 280 |
#' + rnorm(n, 5) + rnorm(n, -1, .1 * x^2) |
|
| 281 |
#' ) |
|
| 282 |
#' |
|
| 283 |
#' # looking at the distribution of y between bets split by by |
|
| 284 |
#' splot(y, by = by, between = c(bet1, bet2), data = dat) |
|
| 285 |
#' |
|
| 286 |
#' # looking at quantile splits of y in y by x |
|
| 287 |
#' splot(y ~ x * y, dat, split = "quantile") |
|
| 288 |
#' |
|
| 289 |
#' # looking at y by x between bets |
|
| 290 |
#' splot(y ~ x, dat, between = c(bet1, bet2)) |
|
| 291 |
#' |
|
| 292 |
#' # sequentially adding levels of split |
|
| 293 |
#' splot(y ~ x * by, dat) |
|
| 294 |
#' splot(y ~ x * by * bet1, dat) |
|
| 295 |
#' splot(y ~ x * by * bet1 * bet2, dat) |
|
| 296 |
#' |
|
| 297 |
#' # same as the last but entered by name |
|
| 298 |
#' splot(y, x = x, by = by, between = c(bet1, bet2), data = dat) |
|
| 299 |
#' |
|
| 300 |
#' # zooming in on one of the windows |
|
| 301 |
#' splot(y ~ x * by, dat, bet1 == 1 & bet2 == 0) |
|
| 302 |
#' |
|
| 303 |
#' # comparing an adjusted lm prediction line with a loess line |
|
| 304 |
#' # this could also be entered as y ~ poly(x,3) |
|
| 305 |
#' splot(y ~ x + x^2 + x^3, dat, bet1 == 1 & bet2 == 0 & by == 1, add = {
|
|
| 306 |
#' lines(x[order(x)], loess(y ~ x)$fitted[order(x)], lty = 2) |
|
| 307 |
#' legend("topright", c("lm", "loess"), lty = c(1, 2), lwd = c(2, 1), bty = "n")
|
|
| 308 |
#' }) |
|
| 309 |
#' |
|
| 310 |
#' # looking at different versions of x added to y |
|
| 311 |
#' splot(cbind( |
|
| 312 |
#' Raw = y + x, |
|
| 313 |
#' Sine = y + sin(x), |
|
| 314 |
#' Cosine = y + cos(x), |
|
| 315 |
#' Tangent = y + tan(x) |
|
| 316 |
#' ) ~ x, dat, myl = c(-10, 15), lines = "loess", laby = "y + versions of x") |
|
| 317 |
#' |
|
| 318 |
#' @export |
|
| 319 |
#' @importFrom grDevices grey dev.copy dev.size dev.off cairo_pdf adjustcolor colors col2rgb |
|
| 320 |
#' @importFrom graphics axis axTicks hist legend lines text mtext plot barplot par points arrows strwidth layout plot.new |
|
| 321 |
#' locator strheight polygon abline |
|
| 322 |
#' @importFrom stats density median quantile sd lm glm confint update loess smooth.spline formula as.formula predict |
|
| 323 |
#' var binomial |
|
| 324 | ||
| 325 |
splot <- function( |
|
| 326 |
y, |
|
| 327 |
data = NULL, |
|
| 328 |
su = NULL, |
|
| 329 |
type = "", |
|
| 330 |
split = "median", |
|
| 331 |
levels = list(), |
|
| 332 |
sort = NULL, |
|
| 333 |
error = "standard", |
|
| 334 |
error.color = "#585858", |
|
| 335 |
error.lwd = 2, |
|
| 336 |
lim = 9, |
|
| 337 |
lines = TRUE, |
|
| 338 |
..., |
|
| 339 |
colors = "pastel", |
|
| 340 |
colorby = NULL, |
|
| 341 |
colorby.leg = TRUE, |
|
| 342 |
color.lock = FALSE, |
|
| 343 |
color.offset = 1.1, |
|
| 344 |
color.summary = "mean", |
|
| 345 |
opacity = 1, |
|
| 346 |
dark = getOption("splot.dark", FALSE),
|
|
| 347 |
x = NULL, |
|
| 348 |
by = NULL, |
|
| 349 |
between = NULL, |
|
| 350 |
cov = NULL, |
|
| 351 |
line.type = "l", |
|
| 352 |
mv.scale = "none", |
|
| 353 |
mv.as.x = FALSE, |
|
| 354 |
save = FALSE, |
|
| 355 |
format = cairo_pdf, |
|
| 356 |
dims = dev.size(), |
|
| 357 |
file.name = "splot", |
|
| 358 |
myl = NULL, |
|
| 359 |
mxl = NULL, |
|
| 360 |
autori = TRUE, |
|
| 361 |
xlas = 0, |
|
| 362 |
ylas = 1, |
|
| 363 |
xaxis = TRUE, |
|
| 364 |
yaxis = TRUE, |
|
| 365 |
breaks = "sturges", |
|
| 366 |
density.fill = TRUE, |
|
| 367 |
density.opacity = .4, |
|
| 368 |
density.args = list(), |
|
| 369 |
leg = "outside", |
|
| 370 |
lpos = "auto", |
|
| 371 |
lvn = TRUE, |
|
| 372 |
leg.title = TRUE, |
|
| 373 |
leg.args = list(), |
|
| 374 |
title = TRUE, |
|
| 375 |
labx = TRUE, |
|
| 376 |
laby = TRUE, |
|
| 377 |
lty = TRUE, |
|
| 378 |
lwd = 2, |
|
| 379 |
sub = TRUE, |
|
| 380 |
ndisp = TRUE, |
|
| 381 |
note = TRUE, |
|
| 382 |
font = c(title = 2, sud = 1, leg = 1, leg.title = 2, note = 3), |
|
| 383 |
cex = c(title = 1.5, sud = .9, leg = .9, note = .7, points = 1), |
|
| 384 |
sud = TRUE, |
|
| 385 |
labels = TRUE, |
|
| 386 |
labels.filter = "_", |
|
| 387 |
labels.trim = 20, |
|
| 388 |
points = TRUE, |
|
| 389 |
points.first = TRUE, |
|
| 390 |
byx = TRUE, |
|
| 391 |
drop = c(x = TRUE, by = TRUE, bet = TRUE), |
|
| 392 |
prat = c(1, 1), |
|
| 393 |
check.height = TRUE, |
|
| 394 |
model = FALSE, |
|
| 395 |
options = NULL, |
|
| 396 |
add = NULL |
|
| 397 |
) {
|
|
| 398 |
# parsing input and preparing data |
|
| 399 | 33x |
if (check.height && dev.size()[2] < 1.7) {
|
| 400 | ! |
stop( |
| 401 | ! |
"the plot window seems too short; increase the height of the plot window, or set check.height to FALSE", |
| 402 | ! |
call. = FALSE |
| 403 |
) |
|
| 404 |
} |
|
| 405 | 33x |
if (!missing(options) && is.list(options) && length(options) != 0) {
|
| 406 | ! |
a <- as.list(match.call())[-1] |
| 407 | ! |
options <- tryCatch(options, error = function(e) NULL) |
| 408 | ! |
if (is.null(options)) {
|
| 409 | ! |
stop("could not find options")
|
| 410 |
} |
|
| 411 | ! |
return(do.call( |
| 412 | ! |
splot, |
| 413 | ! |
c(a[names(a) != "options"], options[!names(options) %in% names(a)]), |
| 414 | ! |
envir = parent.frame() |
| 415 |
)) |
|
| 416 |
} |
|
| 417 | 33x |
if (!labels) {
|
| 418 | ! |
title <- sud <- sub <- labx <- laby <- note <- FALSE |
| 419 |
} |
|
| 420 | 33x |
opt_saf <- getOption("stringsAsFactors")
|
| 421 | 33x |
on.exit(options(stringsAsFactors = opt_saf)) |
| 422 | 33x |
options(stringsAsFactors = FALSE) |
| 423 | 33x |
ck <- list( |
| 424 | 33x |
ff = list(bet = FALSE, cov = FALSE), |
| 425 | 33x |
t = if (grepl("^b|^l", type, TRUE)) {
|
| 426 | 5x |
1 |
| 427 | 33x |
} else if (grepl("^d", type, TRUE)) {
|
| 428 | 2x |
2 |
| 429 |
} else {
|
|
| 430 | 26x |
3 |
| 431 |
}, |
|
| 432 | 33x |
b = grepl("^b", type, TRUE),
|
| 433 | 33x |
tt = !missing(type) && !grepl("^b|^l", type, TRUE),
|
| 434 | 33x |
d = !missing(data) && !is.null(data), |
| 435 | 33x |
su = !missing(su), |
| 436 | 33x |
c = !missing(cov), |
| 437 | 33x |
co = missing(colors), |
| 438 | 33x |
cb = !missing(colorby), |
| 439 | 33x |
cblegm = missing(colorby.leg), |
| 440 | 33x |
cbleg = is.logical(colorby.leg) && colorby.leg, |
| 441 | 33x |
poly = missing(density.fill) || (!is.logical(density.fill) || density.fill), |
| 442 | 33x |
polyo = !missing(density.fill) || !missing(density.opacity), |
| 443 | 33x |
e = grepl("^s", error, TRUE),
|
| 444 | 33x |
el = !(is.logical(error) && !error), |
| 445 | 33x |
sp = if (!is.character(split)) {
|
| 446 | ! |
4 |
| 447 | 33x |
} else if (grepl("^mea|^av", split, TRUE)) {
|
| 448 | 2x |
1 |
| 449 | 33x |
} else if (grepl("^q", split, TRUE)) {
|
| 450 | ! |
2 |
| 451 |
} else {
|
|
| 452 | 31x |
ifelse(grepl("^s", split, TRUE), 3, 4)
|
| 453 |
}, |
|
| 454 | 33x |
ly = !(is.logical(laby) && !laby) || is.character(laby), |
| 455 | 33x |
lys = is.character(laby), |
| 456 | 33x |
lx = !(is.logical(labx) && !labx) || is.character(labx), |
| 457 | 33x |
line = substitute(lines), |
| 458 | 33x |
lty = is.logical(lty), |
| 459 | 33x |
ltym = missing(lty), |
| 460 | 33x |
ltm = missing(line.type), |
| 461 | 33x |
leg = if (is.logical(leg) && !leg) {
|
| 462 | ! |
0 |
| 463 | 33x |
} else if (!is.character(leg) || grepl("^o", leg, TRUE)) {
|
| 464 | 33x |
1 |
| 465 |
} else {
|
|
| 466 | ! |
2 |
| 467 |
}, |
|
| 468 | 33x |
legm = missing(leg), |
| 469 | 33x |
legt = !(is.logical(leg.title) && !leg.title), |
| 470 | 33x |
lp = is.character(lpos) && grepl("^a", lpos, TRUE),
|
| 471 | 33x |
lpm = is.character(lpos) && grepl("^p|^m", lpos, TRUE),
|
| 472 | 33x |
mod = !missing(x) && model, |
| 473 | 33x |
note = !is.character(note), |
| 474 | 33x |
mv = FALSE, |
| 475 | 33x |
mlvn = missing(lvn), |
| 476 | 33x |
opacity = !missing(opacity) && opacity <= 1 && opacity > 0, |
| 477 | 33x |
mai = FALSE |
| 478 |
) |
|
| 479 | 33x |
if (ck$lpm) {
|
| 480 | ! |
lpos <- "center" |
| 481 |
} |
|
| 482 | 33x |
if (ck$d && !is.data.frame(data)) {
|
| 483 | ! |
data <- if (!is.matrix(data) && !is.list(data)) {
|
| 484 | ! |
as.data.frame(as.matrix(data)) |
| 485 |
} else {
|
|
| 486 | ! |
as.data.frame(data) |
| 487 |
} |
|
| 488 |
} |
|
| 489 | 33x |
ck$ltck <- (is.logical(ck$line) && ck$line) || !grepl("^F", ck$line)
|
| 490 | 33x |
if (!ck$ltck && ck$note) {
|
| 491 | ! |
note <- FALSE |
| 492 |
} |
|
| 493 | 33x |
ck$ltco <- if (ck$ltck) {
|
| 494 | 33x |
if (is.logical(ck$line) || ck$c || grepl("^li|^lm|^st", ck$line, TRUE)) {
|
| 495 | 33x |
"li" |
| 496 | ! |
} else if (grepl("^loe|^po|^cu", ck$line, TRUE)) {
|
| 497 | ! |
"lo" |
| 498 | ! |
} else if (grepl("^sm|^sp|^in", ck$line, TRUE)) {
|
| 499 | ! |
"sm" |
| 500 | ! |
} else if (grepl("^e|^co|^d", ck$line, TRUE)) {
|
| 501 | ! |
"e" |
| 502 | ! |
} else if (grepl("^pr|^log", ck$line, TRUE)) {
|
| 503 | ! |
"pr" |
| 504 |
} else {
|
|
| 505 | ! |
"li" |
| 506 |
} |
|
| 507 |
} else {
|
|
| 508 | ! |
"li" |
| 509 |
} |
|
| 510 | 33x |
if (any(!missing(font), !missing(cex), !missing(drop))) {
|
| 511 | ! |
dop <- formals(splot)[c("font", "cex", "drop")]
|
| 512 | ! |
oco <- function(s, d) {
|
| 513 | ! |
od <- d <- eval(d) |
| 514 | ! |
if (length(s) != length(d)) {
|
| 515 | ! |
n <- NULL |
| 516 | ! |
if (!is.null(n <- names(s)) || length(s) != 1) {
|
| 517 | ! |
if (!is.null(n)) d[n] <- s[n] else d[seq_along(s)] <- s |
| 518 |
} else {
|
|
| 519 | ! |
d[] <- s |
| 520 |
} |
|
| 521 | ! |
s <- d |
| 522 |
} |
|
| 523 | ! |
s <- s[names(od)] |
| 524 | ! |
names(s) <- names(od) |
| 525 | ! |
if (any(n <- is.na(s))) {
|
| 526 | ! |
s[n] <- od[n] |
| 527 |
} |
|
| 528 | ! |
s |
| 529 |
} |
|
| 530 | ! |
if (!missing(font)) {
|
| 531 | ! |
font <- oco(font, dop$font) |
| 532 |
} |
|
| 533 | ! |
if (!missing(cex)) {
|
| 534 | ! |
cex <- oco(cex, dop$cex) |
| 535 |
} |
|
| 536 | ! |
if (!missing(drop)) drop <- oco(drop, dop$drop) |
| 537 |
} |
|
| 538 | 33x |
dn <- if (ck$d) names(data) else "" |
| 539 |
if ( |
|
| 540 | 33x |
any(grepl( |
| 541 |
"~", |
|
| 542 | 33x |
c( |
| 543 | 33x |
substitute(y), |
| 544 | 33x |
if ( |
| 545 | 33x |
paste(deparse(substitute(y)), collapse = "") %in% |
| 546 | 33x |
ls(envir = globalenv()) |
| 547 |
) {
|
|
| 548 | ! |
y |
| 549 |
} |
|
| 550 |
), |
|
| 551 | 33x |
fixed = TRUE |
| 552 |
)) |
|
| 553 |
) {
|
|
| 554 | 24x |
f <- as.character(as.formula(y))[-1] |
| 555 | 24x |
y <- as.formula(y)[[2]] |
| 556 | 24x |
bl <- function(x) {
|
| 557 | 24x |
cs <- strsplit(x, "")[[1]] |
| 558 | 24x |
rs <- lapply(c("(", ")", "[", "]"), grep, cs, fixed = TRUE)
|
| 559 | 24x |
l <- vapply(rs, length, 0) |
| 560 | 24x |
cr <- TRUE |
| 561 | 24x |
if (any(l != 0)) {
|
| 562 | ! |
if (l[1] != l[2] || l[3] != l[4]) {
|
| 563 | ! |
stop("invalid parentheses or brackets in ", x)
|
| 564 |
} |
|
| 565 | ! |
cr <- !seq_along(cs) %in% |
| 566 | ! |
c( |
| 567 | ! |
unlist(lapply( |
| 568 | ! |
seq_len(l[1]), |
| 569 | ! |
function(r) do.call(seq, lapply(rs[1:2], "[[", r)) |
| 570 |
)), |
|
| 571 | ! |
unlist(lapply( |
| 572 | ! |
seq_len(l[3]), |
| 573 | ! |
function(r) do.call(seq, lapply(rs[3:4], "[[", r)) |
| 574 |
)) |
|
| 575 |
) |
|
| 576 |
} |
|
| 577 | 24x |
cs[cr] <- sub( |
| 578 |
"*", |
|
| 579 | 24x |
"_VAR_", |
| 580 | 24x |
sub("+", "_COV_", cs[cr], fixed = TRUE),
|
| 581 | 24x |
fixed = TRUE |
| 582 |
) |
|
| 583 | 24x |
paste(cs, collapse = "") |
| 584 |
} |
|
| 585 | 24x |
f <- strsplit(bl(f[-1]), " _COV_ ", fixed = TRUE)[[1]] |
| 586 | 24x |
if (any(grepl(" _VAR_ ", f, fixed = TRUE))) {
|
| 587 | 7x |
r <- strsplit(f[1], " _VAR_ ", fixed = TRUE)[[1]] |
| 588 | 7x |
if (length(r)) {
|
| 589 | 7x |
x <- r[1] |
| 590 |
} |
|
| 591 | 7x |
if (length(r) > 1) {
|
| 592 | 7x |
by <- r[2] |
| 593 |
} |
|
| 594 | 7x |
if (length(r) > 2) {
|
| 595 | 4x |
ck$ff$bet <- TRUE |
| 596 | 4x |
between <- r[3] |
| 597 |
} |
|
| 598 | 7x |
if (length(r) > 3) {
|
| 599 | 2x |
between <- c(r[3], r[4]) |
| 600 |
} |
|
| 601 | 7x |
f <- f[!grepl(" _VAR_ ", f, fixed = TRUE)]
|
| 602 |
} else {
|
|
| 603 | 17x |
x <- f[1] |
| 604 | 17x |
f <- f[-1] |
| 605 |
} |
|
| 606 | 24x |
if (length(f)) {
|
| 607 | ! |
cov <- f |
| 608 | ! |
ck$c <- ck$ff$cov <- TRUE |
| 609 |
} |
|
| 610 |
} |
|
| 611 | 33x |
txt <- list( |
| 612 | 33x |
split = "none", |
| 613 | 33x |
y = substitute(y), |
| 614 | 33x |
x = substitute(x), |
| 615 | 33x |
by = substitute(by), |
| 616 | 33x |
bet = as.list(substitute(between)), |
| 617 | 33x |
cov = as.list(substitute(cov)), |
| 618 | 33x |
su = deparse(substitute(su)) |
| 619 |
) |
|
| 620 | 33x |
txt[c("bet", "cov")] <- lapply(c("bet", "cov"), function(l) {
|
| 621 | 66x |
paste(if (!ck$ff[[l]] && length(txt[[l]]) > 1) txt[[l]][-1] else txt[[l]]) |
| 622 |
}) |
|
| 623 | 33x |
txt <- lapply( |
| 624 | 33x |
txt, |
| 625 | 33x |
function(e) if (is.call(e)) paste(deparse(e), collapse = "\n") else e |
| 626 |
) |
|
| 627 | 33x |
if (length(txt$bet) > 2) {
|
| 628 | ! |
txt$bet <- txt$bet[1:2] |
| 629 |
} |
|
| 630 | 33x |
tdc <- function(x, l = NULL) {
|
| 631 | 90x |
if (!is.call(x)) {
|
| 632 | 89x |
if ((is.null(l) && length(x) != 1) || (!is.null(l) && length(x) == l)) {
|
| 633 | ! |
return(x) |
| 634 |
} |
|
| 635 |
} |
|
| 636 | 90x |
if (is.character(x)) {
|
| 637 | 60x |
x <- parse(text = x) |
| 638 |
} |
|
| 639 | 90x |
tx <- tryCatch(eval(x, data, parent.frame(2)), error = function(e) NULL) |
| 640 | 90x |
if (is.character(tx) && length(tx) < 2) {
|
| 641 | ! |
x <- parse(text = tx) |
| 642 | ! |
tx <- tryCatch(eval(x, data, parent.frame(2)), error = function(e) NULL) |
| 643 | 90x |
} else if (is.null(tx)) {
|
| 644 | ! |
tx <- tryCatch(eval(x, data, parent.frame(3)), error = function(e) NULL) |
| 645 |
} |
|
| 646 | 33x |
if ( |
| 647 | 90x |
is.null(tx) || |
| 648 | 90x |
any(class(tx) %in% c("name", "call", "expression", "function"))
|
| 649 |
) {
|
|
| 650 | ! |
stop("could not find ", x, call. = FALSE)
|
| 651 |
} |
|
| 652 | 90x |
if (!is.null(l) && is.null(ncol(tx))) {
|
| 653 | 56x |
if (length(tx) != l) {
|
| 654 | ! |
tx <- rep_len(tx, l) |
| 655 | ! |
if (is.call(x)) {
|
| 656 | ! |
x <- deparse(x) |
| 657 |
} |
|
| 658 | ! |
warning(x, " is not the same length as y", call. = FALSE) |
| 659 |
} |
|
| 660 |
} |
|
| 661 | 90x |
if (!is.null(dim(tx)) && !is.matrix(tx) && !is.data.frame(tx)) {
|
| 662 | ! |
tx <- as.matrix(tx) |
| 663 |
} |
|
| 664 | 90x |
tx |
| 665 |
} |
|
| 666 | 33x |
if (!missing(data) && !any(class(data) %in% c("matrix", "data.frame"))) {
|
| 667 | ! |
data <- if (is.character(data)) {
|
| 668 | ! |
eval(parse(text = data)) |
| 669 |
} else {
|
|
| 670 | ! |
eval(data, globalenv()) |
| 671 |
} |
|
| 672 |
} |
|
| 673 | 33x |
dat <- data.frame(y = tdc(txt$y), check.names = FALSE) |
| 674 | 33x |
if (ncol(dat) == 1) {
|
| 675 | 32x |
names(dat) <- "y" |
| 676 |
} |
|
| 677 | 33x |
nr <- nrow(dat) |
| 678 | 33x |
lvs <- function(x, s = FALSE) {
|
| 679 | 101x |
if (is.factor(x)) {
|
| 680 | 64x |
base::levels(x) |
| 681 | 37x |
} else if (s) {
|
| 682 | ! |
sort(unique(x[!is.na(x)])) |
| 683 |
} else {
|
|
| 684 | 37x |
unique(x[!is.na(x)]) |
| 685 |
} |
|
| 686 |
} |
|
| 687 | 33x |
for (n in names(txt)[-c(1, 2, 7)]) {
|
| 688 | 132x |
l <- length(txt[[n]]) |
| 689 | 132x |
if (l == 0) {
|
| 690 | 81x |
next |
| 691 |
} |
|
| 692 | 51x |
if (l == nr) {
|
| 693 | ! |
dat[, n] <- txt[[n]] |
| 694 | ! |
txt[[n]] <- n |
| 695 | 51x |
} else if (l == 1) {
|
| 696 | 46x |
dat[, n] <- tdc(txt[[n]], nr) |
| 697 |
} else {
|
|
| 698 | 5x |
for (i in seq_along(txt[[n]])) {
|
| 699 | 10x |
dat[, paste0(n, ".", i)] <- tdc(txt[[n]][[i]], nr) |
| 700 |
} |
|
| 701 |
} |
|
| 702 |
} |
|
| 703 | 33x |
if (length(txt$y) == nr) {
|
| 704 | ! |
txt$y <- "y" |
| 705 |
} |
|
| 706 | 33x |
if (missing(x) && !is.null(dat$y) && !is.numeric(dat$y)) {
|
| 707 | 1x |
dat$x <- dat$y |
| 708 | 1x |
sl <- grepl("^(y|by|bet[.12]{,2})$", colnames(dat))
|
| 709 | 1x |
dat$y <- if (sum(sl) == 1) dat[, sl] else do.call(paste, dat[, sl]) |
| 710 | 1x |
dat$y <- table(dat$y)[dat$y] |
| 711 | 1x |
if (sum(sl) != 1) {
|
| 712 | ! |
dat <- dat[, c("y", "x", colnames(dat)[!colnames(dat) %in% c("y", "x")])]
|
| 713 |
} |
|
| 714 | 1x |
if (ck$t != 2) {
|
| 715 | 1x |
txt[c("y", "x")] <- c("count", txt$y)
|
| 716 |
} |
|
| 717 | 1x |
ck$el <- FALSE |
| 718 | 1x |
if (missing(type)) {
|
| 719 | 1x |
ck$b <- TRUE |
| 720 | 1x |
ck$t <- 1 |
| 721 | 1x |
ck[c("b", "t", "tt")] <- list(TRUE, 1, FALSE)
|
| 722 |
} |
|
| 723 | 1x |
if (missing(autori)) autori <- FALSE |
| 724 |
} |
|
| 725 | 33x |
if (NCOL(dat$x) > 1) {
|
| 726 | ! |
ck$c <- TRUE |
| 727 | ! |
txt$cov <- c(txt$x, txt$cov) |
| 728 | ! |
dat$cov <- cbind(dat$cov, dat$x[, -1]) |
| 729 | ! |
dat$x <- dat$x[, 1] |
| 730 |
} |
|
| 731 | 33x |
ck$orn <- nr |
| 732 | 33x |
su <- substitute(su) |
| 733 | 33x |
if (ck$su && length(su) != nr) {
|
| 734 | ! |
tsu <- tryCatch(eval(su, if (ck$d) data), error = function(e) NULL) |
| 735 | ! |
if (is.null(tsu) || length(tsu) != nr) {
|
| 736 | ! |
odat <- dat |
| 737 | ! |
colnames(odat) <- sub("^y\\.", "", colnames(dat))
|
| 738 | ! |
tsu <- tryCatch(eval(su, odat), error = function(e) NULL) |
| 739 |
} |
|
| 740 | ! |
if (!is.null(tsu)) {
|
| 741 | ! |
tsu[is.na(tsu)] <- FALSE |
| 742 | ! |
su <- tsu |
| 743 |
} |
|
| 744 | ! |
if (is.logical(tsu) && sum(tsu) == 0 || length(tsu) == 0) {
|
| 745 | ! |
ck$su <- FALSE |
| 746 | ! |
warning("su excludes all rows, so it was ignored.", .call = FALSE)
|
| 747 |
} |
|
| 748 |
} |
|
| 749 | 33x |
tsu <- vapply(dat, is.numeric, TRUE) |
| 750 | 33x |
ck$omitted <- list( |
| 751 | 33x |
na = apply(dat, 1, function(r) any(is.na(r))), |
| 752 | 33x |
inf = apply(dat[, tsu, drop = FALSE], 1, function(r) any(is.infinite(r))) |
| 753 |
) |
|
| 754 | 33x |
if (ck$su) {
|
| 755 | ! |
ck$omitted$su <- !su |
| 756 |
} |
|
| 757 | 33x |
ck$omitted$all <- !Reduce("|", ck$omitted)
|
| 758 | 33x |
if (any(!ck$omitted$all)) {
|
| 759 | ! |
if (any(ck$omitted$all)) {
|
| 760 | ! |
odat <- dat[ck$omitted$all, , drop = FALSE] |
| 761 | ! |
dat <- odat |
| 762 | ! |
dn <- colnames(dat) |
| 763 | ! |
if ("x" %in% dn && length(unique(dat$x)) == 1) {
|
| 764 | ! |
ck$t <- 2 |
| 765 | ! |
dat$x <- NULL |
| 766 | ! |
warning("after omitting, x only had 1 level, so it was dropped")
|
| 767 |
} |
|
| 768 | ! |
if ("by" %in% dn && length(unique(dat$by)) == 1) {
|
| 769 | ! |
txt$by <- dat$by <- NULL |
| 770 | ! |
warning("after omitting, by only had 1 level, so it was dropped")
|
| 771 |
} |
|
| 772 | ! |
if (ck$d) data <- data[ck$omitted$all, , drop = FALSE] |
| 773 |
} else {
|
|
| 774 | ! |
stop("this combination of variables/splits has no complete cases")
|
| 775 |
} |
|
| 776 |
} |
|
| 777 | 33x |
dn <- colnames(dat) |
| 778 | 33x |
nr <- nrow(dat) |
| 779 | 33x |
if (sum(grepl("^y", dn)) > 1) {
|
| 780 |
# setting up multiple y variables |
|
| 781 | 1x |
dn <- grep("^y\\.", dn)
|
| 782 | 1x |
ck$mvn <- colnames(dat)[dn] |
| 783 | 1x |
ck$mvnl <- length(ck$mvn) |
| 784 | 1x |
if (any(tcn <- grepl("(V\\d+$|c\\(|y\\.(\\d+$|.*\\.))", ck$mvn))) {
|
| 785 | 1x |
ncn <- substitute(y) |
| 786 |
if ( |
|
| 787 | 1x |
length(ncn) > 1 && length(ncn <- as.character(ncn[-1])) == length(dn) |
| 788 |
) {
|
|
| 789 | ! |
ck$mvn[tcn] <- paste0("y.", ncn[tcn])
|
| 790 |
} |
|
| 791 |
} |
|
| 792 | 1x |
ck$mv <- TRUE |
| 793 | 1x |
if (ck$mlvn) {
|
| 794 | 1x |
lvn <- FALSE |
| 795 |
} |
|
| 796 | 1x |
if (!missing(by)) {
|
| 797 | ! |
txt$bet <- c(txt$by, txt$bet) |
| 798 | ! |
if (length(txt$bet) > 2) {
|
| 799 | ! |
warning( |
| 800 | ! |
"multiple y variables moves by to between, so the second level of between was dropped" |
| 801 |
) |
|
| 802 | ! |
txt$bet <- txt$bet[1:2] |
| 803 | ! |
dat <- dat[-grep("bet", colnames(dat))[2]]
|
| 804 |
} |
|
| 805 | ! |
if (length(txt$bet) > 1) {
|
| 806 | ! |
dat$bet.1 <- if (is.factor(dat$by)) dat$by else as.character(dat$by) |
| 807 | ! |
dat$bet.2 <- if (is.factor(dat$bet)) dat$bet else as.character(dat$bet) |
| 808 | ! |
dat$bet <- NULL |
| 809 |
} else {
|
|
| 810 | ! |
dat$bet <- if (is.factor(dat$by)) dat$by else as.character(dat$by) |
| 811 |
} |
|
| 812 |
} |
|
| 813 | 1x |
td <- dat |
| 814 | 1x |
if (any(ckn <- duplicated(ck$mvn))) {
|
| 815 | ! |
ck$mvn[ckn] <- paste0(ck$mvn[ckn], "_", seq_len(sum(ckn))) |
| 816 |
} |
|
| 817 | 1x |
by <- sub("^y\\.", "", ck$mvn)
|
| 818 | 1x |
if (any(by == "")) {
|
| 819 | ! |
by[by == ""] <- seq_len(sum(by == "")) |
| 820 |
} |
|
| 821 | 1x |
by <- factor(rep(by, each = nr), levels = by) |
| 822 | 1x |
cncls <- vapply( |
| 823 | 1x |
dat[, dn], |
| 824 | 1x |
function(v) is.numeric(v) || is.integer(v) || is.factor(v), |
| 825 | 1x |
TRUE |
| 826 |
) |
|
| 827 | 1x |
if (any(cncls) && any(!cncls)) {
|
| 828 | ! |
for (cnc in which(!cncls)) {
|
| 829 | ! |
dat[, cnc] <- as.numeric(factor(dat[, cnc], lvs(dat[, cnc]))) |
| 830 |
} |
|
| 831 |
} |
|
| 832 | 1x |
dat <- data.frame(y = unlist(dat[, dn], use.names = FALSE)) |
| 833 | 1x |
if (ncol(td) > length(dn)) {
|
| 834 | ! |
dat <- cbind( |
| 835 | ! |
dat, |
| 836 | ! |
do.call( |
| 837 | ! |
rbind, |
| 838 | ! |
lapply(seq_along(dn), function(i) td[, -dn, drop = FALSE]) |
| 839 |
) |
|
| 840 |
) |
|
| 841 |
} |
|
| 842 | 1x |
if (mv.as.x) {
|
| 843 | ! |
txt$by <- txt$x |
| 844 | ! |
txt$x <- if (missing(labx)) {
|
| 845 | ! |
"variable" |
| 846 | ! |
} else if (labx == txt$by) {
|
| 847 | ! |
paste0(labx, ".1") |
| 848 |
} else {
|
|
| 849 | ! |
labx |
| 850 |
} |
|
| 851 | ! |
dat$by <- dat$x |
| 852 | ! |
dat$x <- by |
| 853 |
} else {
|
|
| 854 | 1x |
txt$by <- "variable" |
| 855 | 1x |
dat$by <- by |
| 856 |
} |
|
| 857 | 1x |
if (missing(leg.title) && !mv.as.x) {
|
| 858 | 1x |
ck$legt <- FALSE |
| 859 |
} |
|
| 860 | 1x |
if (!missing(levels) && "mv" %in% names(levels)) {
|
| 861 | ! |
names(levels)[names(levels) == "mv"] <- txt[[if (mv.as.x) "x" else "by"]] |
| 862 |
} |
|
| 863 | 1x |
dn <- colnames(dat) |
| 864 | 1x |
if (!missing(mv.scale) && mv.scale != "none") {
|
| 865 | ! |
tv <- if (mv.as.x) dat$x else dat$by |
| 866 | ! |
for (g in levels(as.factor(tv))) {
|
| 867 | ! |
svar <- tv == g |
| 868 | ! |
cvar <- scale(dat[svar, 1], scale = grepl("^t|z|sc", mv.scale, TRUE))
|
| 869 | ! |
if (any(is.na(cvar))) {
|
| 870 | ! |
cvar <- dat[svar, 1] - mean(dat[svar, 1], na.rm = TRUE) |
| 871 |
} |
|
| 872 | ! |
dat[svar, 1] <- cvar |
| 873 |
} |
|
| 874 |
} |
|
| 875 | 1x |
nr <- nrow(dat) |
| 876 |
} else {
|
|
| 877 | 32x |
ck$mv <- FALSE |
| 878 |
} |
|
| 879 | 33x |
if (!"x" %in% dn) {
|
| 880 | 8x |
ck$t <- 2 |
| 881 | 8x |
if (!missing(type) && !grepl("^d", type, TRUE)) {
|
| 882 | 1x |
warning("x must be included to show other types of splots")
|
| 883 |
} |
|
| 884 |
} |
|
| 885 | 33x |
if (!ck$cb && !"by" %in% dn) {
|
| 886 | 13x |
ck$leg <- 0 |
| 887 |
} |
|
| 888 | 33x |
if (lim > 20 || (is.logical(lim) && !lim)) {
|
| 889 | ! |
lim <- Inf |
| 890 | ! |
if (ck$legm && !ck$cb) {
|
| 891 | ! |
ck$leg <- 0 |
| 892 |
} |
|
| 893 | ! |
if (missing(error)) ck$el <- FALSE |
| 894 |
} |
|
| 895 | 33x |
if (ck$ltm && !ck$el) {
|
| 896 | 1x |
line.type <- "b" |
| 897 |
} |
|
| 898 | 33x |
if (ck$ltym && is.logical(lines) && !lines) {
|
| 899 | ! |
ck$lty <- FALSE |
| 900 | ! |
lty <- 1 |
| 901 |
} |
|
| 902 | 33x |
if (!is.numeric(dat$y)) {
|
| 903 | ! |
txt$yax <- lvs(dat$y) |
| 904 | ! |
if (!is.logical(dat$y) && !is.factor(dat$y)) {
|
| 905 | ! |
dat$y <- factor(dat$y, lvs(dat$y)) |
| 906 |
} |
|
| 907 | ! |
dat$y <- as.numeric(dat$y) |
| 908 |
} |
|
| 909 | 33x |
if ("by" %in% dn && is.character(dat$by) && all(!grepl("[^0-9]", dat$by))) {
|
| 910 | ! |
dat$by <- gsub( |
| 911 |
" ", |
|
| 912 | ! |
"0", |
| 913 | ! |
base::format(dat$by, justify = "right"), |
| 914 | ! |
fixed = TRUE |
| 915 |
) |
|
| 916 |
} |
|
| 917 | 33x |
odat <- dat |
| 918 |
# splitting and parsing variables |
|
| 919 | 33x |
splt_type <- function(x, s) {
|
| 920 | 5x |
if (s == 1) {
|
| 921 | 2x |
"mean" |
| 922 | 3x |
} else if (s == 3) {
|
| 923 | ! |
"standard deviation" |
| 924 | 3x |
} else if (s == 2) {
|
| 925 | ! |
"quantile" |
| 926 | 33x |
} else if ( |
| 927 | 3x |
s == 4 && |
| 928 | 3x |
is.double(split) && |
| 929 | 3x |
(length(split) != 1 || |
| 930 | 3x |
all( |
| 931 | 3x |
c( |
| 932 | 3x |
sum(split >= x, na.rm = TRUE), |
| 933 | 3x |
sum(split <= x, na.rm = TRUE) |
| 934 |
) > |
|
| 935 | 3x |
1 |
| 936 |
)) |
|
| 937 |
) {
|
|
| 938 | ! |
paste(split, collapse = ", ") |
| 939 | 3x |
} else if (s == 4 && is.numeric(split) && split > 1) {
|
| 940 | ! |
split <- min(length(x), round(split), na.rm = TRUE) |
| 941 | ! |
paste0("segments (", split, ")")
|
| 942 |
} else {
|
|
| 943 | 3x |
"median" |
| 944 |
} |
|
| 945 |
} |
|
| 946 | 33x |
splt <- function(x, s) {
|
| 947 | 5x |
if (s == 1) {
|
| 948 | 2x |
factor( |
| 949 | 2x |
x >= mean(x, na.rm = TRUE) * 1, |
| 950 | 2x |
labels = c("Below Average", "Above Average")
|
| 951 |
) |
|
| 952 | 3x |
} else if (s == 3) {
|
| 953 | ! |
m <- mean(x, na.rm = TRUE) |
| 954 | ! |
s <- sd(x, TRUE) |
| 955 | ! |
cut(x, c(-Inf, m - s, m + s, Inf), labels = c("-1 SD", "Mean", "+1 SD"))
|
| 956 | 3x |
} else if (s == 2) {
|
| 957 | ! |
cut( |
| 958 | ! |
x, |
| 959 | ! |
c(-Inf, quantile(x, na.rm = TRUE)[c(2, 4)], Inf), |
| 960 | ! |
labels = c("2nd Quantile", "Median", "4th Quantile")
|
| 961 |
) |
|
| 962 | 33x |
} else if ( |
| 963 | 3x |
s == 4 && |
| 964 | 3x |
is.double(split) && |
| 965 | 3x |
(length(split) != 1 || |
| 966 | 3x |
all( |
| 967 | 3x |
c( |
| 968 | 3x |
sum(split >= x, na.rm = TRUE), |
| 969 | 3x |
sum(split <= x, na.rm = TRUE) |
| 970 |
) > |
|
| 971 | 3x |
1 |
| 972 |
)) |
|
| 973 |
) {
|
|
| 974 | ! |
cut( |
| 975 | ! |
x, |
| 976 | ! |
c(-Inf, split, Inf), |
| 977 | ! |
paste0("<=", c(split, "Inf")),
|
| 978 | ! |
ordered_result = TRUE |
| 979 |
) |
|
| 980 | 3x |
} else if (s == 4 && is.numeric(split) && split > 1) {
|
| 981 | ! |
n <- length(x) |
| 982 | ! |
split <- min(n, round(split), na.rm = TRUE) |
| 983 | ! |
factor(paste( |
| 984 | ! |
"seg", |
| 985 | ! |
rep(seq_len(split), each = round(n / split + .49))[order(order(x))] |
| 986 |
)) |
|
| 987 |
} else {
|
|
| 988 | 3x |
factor( |
| 989 | 3x |
x >= median(x, TRUE) * 1, |
| 990 | 3x |
labels = c("Under Median", "Over Median")
|
| 991 |
) |
|
| 992 |
} |
|
| 993 |
} |
|
| 994 | 33x |
seg <- list( |
| 995 | 33x |
x = list(e = !missing(x), s = FALSE, i = 2), |
| 996 | 33x |
f1 = list(e = FALSE, s = FALSE, l = "", ll = 1), |
| 997 | 33x |
f2 = list(e = FALSE, s = FALSE, l = "", ll = 1), |
| 998 | 33x |
by = list(e = FALSE, s = FALSE, l = "", ll = 1) |
| 999 |
) |
|
| 1000 | 33x |
if (seg$x$e && ck$t != 2) {
|
| 1001 |
if ( |
|
| 1002 | 22x |
(ck$t == 1 || |
| 1003 | 22x |
is.character(dat$x) || |
| 1004 | 22x |
is.factor(dat$x) || |
| 1005 | 22x |
(missing(type) && length(unique(dat$x)) < lim)) |
| 1006 |
) {
|
|
| 1007 | 11x |
dat$x <- if ( |
| 1008 | 11x |
!is.character(dat$x) && !is.factor(dat$x) && length(unique(dat$x)) > lim |
| 1009 |
) {
|
|
| 1010 | 4x |
seg$x$s <- TRUE |
| 1011 | 4x |
if (missing(type)) {
|
| 1012 | ! |
ck$t <- 1 |
| 1013 |
} |
|
| 1014 | 4x |
txt$split <- splt_type(dat$x, ck$sp) |
| 1015 | 4x |
splt(dat$x, ck$sp) |
| 1016 |
} else {
|
|
| 1017 | 7x |
if (missing(type)) {
|
| 1018 | 6x |
ck$t <- 1 |
| 1019 |
} |
|
| 1020 | 7x |
as.factor(dat$x) |
| 1021 |
} |
|
| 1022 |
} |
|
| 1023 |
} |
|
| 1024 | 33x |
if (ck$t == 1 || (is.character(dat$x) || is.factor(dat$x))) {
|
| 1025 | 12x |
seg$x$l <- lvs(dat$x) |
| 1026 | ! |
if (length(seg$x$l) == 1) ck$t <- 3 |
| 1027 |
} |
|
| 1028 | 33x |
svar <- NULL |
| 1029 | 33x |
cvar <- if (any(grepl("^c", dn))) which(grepl("^c", dn)) else NULL
|
| 1030 | 33x |
if (any(grepl("^b", dn))) {
|
| 1031 | 18x |
svar <- which(grepl("^b", dn))
|
| 1032 | 18x |
for (i in svar) {
|
| 1033 | 33x |
e <- if (grepl("bet", dn[i])) {
|
| 1034 | 5x |
if (!seg$f1$e) "f1" else "f2" |
| 1035 |
} else {
|
|
| 1036 | 17x |
"by" |
| 1037 |
} |
|
| 1038 | 33x |
seg[[e]]$e <- TRUE |
| 1039 | 33x |
seg[[e]]$i <- i |
| 1040 | 33x |
seg[[e]]$l <- lvs(dat[, i]) |
| 1041 | 33x |
if (is.factor(dat[, i]) && drop[[dn[i]]]) {
|
| 1042 | 1x |
seg[[e]]$l <- seg[[e]]$l[seg[[e]]$l %in% dat[, i]] |
| 1043 |
} |
|
| 1044 | 33x |
seg[[e]]$ll <- length(seg[[e]]$l) |
| 1045 |
if ( |
|
| 1046 | 33x |
seg[[e]]$ll > lim && !(is.character(dat[, i]) || is.factor(dat[, i])) |
| 1047 |
) {
|
|
| 1048 | 1x |
txt$split <- splt_type(dat[, i], ck$sp) |
| 1049 | 1x |
dat[, i] <- splt(dat[, i], ck$sp) |
| 1050 | 1x |
seg[[e]]$s <- TRUE |
| 1051 | 1x |
seg[[e]]$l <- lvs(dat[, i]) |
| 1052 | 1x |
seg[[e]]$ll <- length(seg[[e]]$l) |
| 1053 |
} |
|
| 1054 | 33x |
if (!is.factor(dat[, i])) {
|
| 1055 | 31x |
dat[, i] <- if (is.character(dat[, i])) {
|
| 1056 | 1x |
factor(dat[, i], lvs(dat[, i])) |
| 1057 |
} else {
|
|
| 1058 | 30x |
as.factor(dat[, i]) |
| 1059 |
} |
|
| 1060 |
} |
|
| 1061 |
} |
|
| 1062 |
} |
|
| 1063 | 33x |
if (seg$by$l[1] == "") {
|
| 1064 | 16x |
seg$by$l <- "NA" |
| 1065 |
} |
|
| 1066 | 33x |
fmod <- NULL |
| 1067 | 33x |
vs <- c(y = txt$y, x = txt$x, by = txt$by, bet = txt$bet, cov = txt$cov) |
| 1068 | 33x |
colnames(odat) <- vs |
| 1069 | 33x |
if (ck$t != 2 && model) {
|
| 1070 | 2x |
tryCatch( |
| 1071 |
{
|
|
| 1072 | 2x |
mod <- formula(paste( |
| 1073 | 2x |
vs["y"], |
| 1074 |
"~", |
|
| 1075 | 2x |
vs["x"], |
| 1076 | 2x |
if (seg$by$e) paste0("*", vs["by"]),
|
| 1077 | 2x |
if (seg$f1$e) paste0("*", vs[grep("^bet", names(vs))[1]]),
|
| 1078 | 2x |
if (seg$f2$e) paste0("*", vs["bet2"]),
|
| 1079 | 2x |
if (length(cvar)) paste0("+", paste0(vs["cov"], collapse = "+"))
|
| 1080 |
)) |
|
| 1081 | 2x |
fmod <- lm(mod, odat) |
| 1082 | 2x |
if (model) {
|
| 1083 | 2x |
s <- summary(fmod) |
| 1084 | 2x |
s$call <- mod |
| 1085 | 2x |
print(s) |
| 1086 |
} |
|
| 1087 |
}, |
|
| 1088 | 2x |
error = function(e) {
|
| 1089 | ! |
warning(paste("summary model failed:", e$message), call. = FALSE)
|
| 1090 |
} |
|
| 1091 |
) |
|
| 1092 |
} |
|
| 1093 | 33x |
if (!missing(levels)) {
|
| 1094 | ! |
tryCatch( |
| 1095 |
{
|
|
| 1096 | ! |
lc <- c("y", "x", "by", "f1", "f2")
|
| 1097 | ! |
ns <- c(txt$y, txt$x, txt$by, txt$bet, lc) |
| 1098 | ! |
lc <- c(lc[seq_len(length(ns) - length(lc))], lc) |
| 1099 | ! |
for (n in names(levels)) {
|
| 1100 | ! |
if (any(cns <- ns %in% n)) {
|
| 1101 | ! |
sl <- lc[cns <- which(cns)[1]] |
| 1102 | ! |
if (sl == "y") {
|
| 1103 | ! |
sl <- list(i = 1) |
| 1104 | ! |
vfac <- txt$yax |
| 1105 | ! |
dat$y <- factor(dat$y, labels = vfac) |
| 1106 |
} else {
|
|
| 1107 | ! |
sl <- seg[[sl]] |
| 1108 | ! |
vfac <- lvs(dat[, sl$i]) |
| 1109 |
} |
|
| 1110 | ! |
vl <- length(vfac) |
| 1111 | ! |
ln <- levels[[n]] |
| 1112 | ! |
lo <- NULL |
| 1113 | ! |
if (is.list(ln)) {
|
| 1114 | ! |
if (length(ln) > 1) {
|
| 1115 | ! |
lo <- levels[[n]][[2]] |
| 1116 |
} |
|
| 1117 | ! |
ln <- ln[[1]] |
| 1118 |
} |
|
| 1119 | ! |
if (is.numeric(ln)) {
|
| 1120 | ! |
ln <- vfac[ln] |
| 1121 |
} |
|
| 1122 | ! |
if (vl == length(ln)) {
|
| 1123 | ! |
vl <- list(dat[, sl$i]) |
| 1124 | ! |
if (all(ln %in% vfac)) {
|
| 1125 | ! |
vl$levels <- ln |
| 1126 |
} else {
|
|
| 1127 | ! |
if (!is.null(lo)) {
|
| 1128 | ! |
vl$labels <- ln[lo] |
| 1129 | ! |
vl$levels <- vfac[lo] |
| 1130 |
} else {
|
|
| 1131 | ! |
vl$labels <- ln |
| 1132 |
} |
|
| 1133 |
} |
|
| 1134 | ! |
dat[, sl$i] <- do.call(factor, vl) |
| 1135 | ! |
if ("l" %in% names(sl)) seg[[lc[cns]]]$l <- levels(dat[, sl$i])
|
| 1136 |
} else {
|
|
| 1137 | ! |
warning( |
| 1138 | ! |
n, |
| 1139 | ! |
" has ", |
| 1140 | ! |
vl, |
| 1141 | ! |
" levels but you provided ", |
| 1142 | ! |
length(ln), |
| 1143 | ! |
call. = FALSE |
| 1144 |
) |
|
| 1145 |
} |
|
| 1146 | ! |
if (sl$i == 1) {
|
| 1147 | ! |
txt$yax <- lvs(dat$y) |
| 1148 | ! |
dat$y <- as.numeric(dat$y) |
| 1149 |
} |
|
| 1150 |
} |
|
| 1151 |
} |
|
| 1152 |
}, |
|
| 1153 | ! |
error = function(e) {
|
| 1154 | ! |
warning("setting levels failed: ", e$message, call. = FALSE)
|
| 1155 |
} |
|
| 1156 |
) |
|
| 1157 |
} |
|
| 1158 | 33x |
dsf <- list(c1 = "", sep = rep.int("^^", nr), c2 = "")
|
| 1159 | 33x |
if (seg$f1$e) {
|
| 1160 | 11x |
dsf$c1 <- dat[, seg$f1$i] |
| 1161 |
} |
|
| 1162 | 33x |
if (seg$f2$e) {
|
| 1163 | 5x |
dsf$c2 <- dat[, seg$f2$i] |
| 1164 |
} |
|
| 1165 | 33x |
cdat <- split(dat, dsf) |
| 1166 | 33x |
if (seg$by$e) {
|
| 1167 | 17x |
cdat <- lapply(cdat, function(s) {
|
| 1168 | 37x |
if (length(unique(s$by)) > 1) {
|
| 1169 | 37x |
split(s, factor(as.character(s$by), lvs(s$by))) |
| 1170 |
} else {
|
|
| 1171 | ! |
s <- lapply(seg$by$l, function(l) if (sum(s$by == l)) s else NULL) |
| 1172 | ! |
names(s) <- seg$by$l |
| 1173 | ! |
s |
| 1174 |
} |
|
| 1175 |
}) |
|
| 1176 | 17x |
if (all((seg$n <- vapply(cdat, length, 0)) == seg$by$ll)) {
|
| 1177 | 17x |
seg$n <- vapply(cdat, function(s) vapply(s, NROW, 0), numeric(seg$by$ll)) |
| 1178 |
} else {
|
|
| 1179 | ! |
drop["by"] <- FALSE |
| 1180 |
} |
|
| 1181 |
} else {
|
|
| 1182 | 16x |
seg$n <- vapply(cdat, nrow, 0) |
| 1183 |
} |
|
| 1184 | 33x |
if (seg$by$e && ck$t != 3 && drop["by"]) {
|
| 1185 | 10x |
seg$by$l <- if (is.null(rownames(seg$n))) {
|
| 1186 | ! |
structure(seg$n > 1, names = seg$by$l) |
| 1187 |
} else {
|
|
| 1188 | 10x |
vapply(rownames(seg$n), function(r) any(seg$n[r, ] > 1), TRUE) |
| 1189 |
} |
|
| 1190 | 10x |
if (!any(seg$by$l)) {
|
| 1191 | ! |
if (ck$t == 2) {
|
| 1192 | ! |
stop("no level of by has more than 1 observation")
|
| 1193 |
} |
|
| 1194 | ! |
warning( |
| 1195 | ! |
"no level of by has more than 1 observation so it was treated as colorby", |
| 1196 | ! |
call. = FALSE |
| 1197 |
) |
|
| 1198 | ! |
seg$by$e <- FALSE |
| 1199 | ! |
seg$by$l <- "" |
| 1200 | ! |
seg$by$ll <- 1 |
| 1201 | ! |
if (ck$cb) {
|
| 1202 | ! |
colorby <- substitute(colorby) |
| 1203 | ! |
colorby[[2]] <- dat$by |
| 1204 |
} else {
|
|
| 1205 | ! |
colorby <- dat$by |
| 1206 |
} |
|
| 1207 | ! |
ck$cb <- TRUE |
| 1208 | ! |
dat <- dat[, -seg$by$i] |
| 1209 | ! |
cdat <- split(dat, dsf) |
| 1210 | ! |
seg$n <- vapply(cdat, nrow, 0) |
| 1211 |
} else {
|
|
| 1212 | 10x |
seg$by$l <- names(seg$by$l[seg$by$l]) |
| 1213 | 10x |
seg$by$ll <- length(seg$by$l) |
| 1214 |
} |
|
| 1215 |
} |
|
| 1216 | 33x |
if (!is.null(nrow(seg$n))) {
|
| 1217 | 17x |
cdat <- cdat[apply(seg$n, 2, function(r) any(r > 1))] |
| 1218 | 17x |
if (nrow(seg$n) > 1) seg$n <- colSums(seg$n[, names(cdat), drop = FALSE]) |
| 1219 |
} |
|
| 1220 | 33x |
if (ck$mv) {
|
| 1221 | 1x |
seg$n <- seg$n / length(ck$mvn) |
| 1222 |
} |
|
| 1223 | 33x |
seg$ll <- length(seg$n) |
| 1224 | 33x |
if (ck$mlvn && seg$by$e && (seg$by$s || !any(grepl("^[0-9]", seg$by$l)))) {
|
| 1225 | 2x |
lvn <- FALSE |
| 1226 |
} |
|
| 1227 | 33x |
ptxt <- c(txt[-c(1, 7)], l = lapply(seg[1:4], "[[", "l")) |
| 1228 |
if ( |
|
| 1229 | 33x |
missing(labels.trim) && |
| 1230 | 33x |
seg$ll == 1 && |
| 1231 | 33x |
length(ptxt$l.x) < 2 && |
| 1232 | 33x |
(seg$by$ll == 1 || ck$mv) |
| 1233 |
) {
|
|
| 1234 | 10x |
labels.trim <- 40 |
| 1235 |
} |
|
| 1236 | 33x |
if (is.numeric(labels.trim) || is.character(labels.filter)) {
|
| 1237 | 32x |
vs <- c("y", "x", "by", "bet", "cov", "l.x", "l.f1", "l.f2", "l.by")
|
| 1238 | 32x |
ptxt <- lapply(vs, function(n) {
|
| 1239 | 288x |
n <- as.character(ptxt[[n]]) |
| 1240 | 288x |
if (length(n) != 0 && all(n != "NULL" & n != "")) {
|
| 1241 | 144x |
names(n) <- n |
| 1242 | 144x |
if (is.character(labels.filter)) {
|
| 1243 | 144x |
n <- gsub(labels.filter, " ", n, perl = TRUE) |
| 1244 |
} |
|
| 1245 | 144x |
if (any(is.na(iconv(n)))) {
|
| 1246 | ! |
stop( |
| 1247 | ! |
"labels appear to be misencoded -- check them with the iconv function" |
| 1248 |
) |
|
| 1249 |
} |
|
| 1250 | 144x |
if (is.numeric(labels.trim)) {
|
| 1251 | 144x |
if (any(ln <- nchar(n) > (labels.trim + 3))) {
|
| 1252 | ! |
n[ln] <- sub("$", "...", strtrim(n[ln], labels.trim))
|
| 1253 |
} |
|
| 1254 |
} |
|
| 1255 |
} |
|
| 1256 | 288x |
n |
| 1257 |
}) |
|
| 1258 | 32x |
names(ptxt) <- vs |
| 1259 |
} |
|
| 1260 | 33x |
if (is.character(labx)) {
|
| 1261 | ! |
ptxt$x <- labx |
| 1262 | 33x |
} else if (ck$t == 2) {
|
| 1263 | 10x |
ptxt$x <- ptxt$y |
| 1264 |
} |
|
| 1265 | 33x |
if (is.character(laby)) {
|
| 1266 | ! |
ptxt$y <- laby |
| 1267 | 33x |
} else if (ck$t == 2) {
|
| 1268 | 10x |
ptxt$y <- "Density" |
| 1269 |
} |
|
| 1270 | 33x |
ck$ileg <- seg$by$e && ck$leg > 1 |
| 1271 | 33x |
ptxt$leg <- ptxt$l.by |
| 1272 | 33x |
fdat <- dat |
| 1273 | 33x |
names(fdat) <- paste0(".", names(dat))
|
| 1274 | 33x |
fdat <- if (!is.null(data)) {
|
| 1275 | ! |
if (nrow(data) == nr) cbind(data, fdat, odat) else data |
| 1276 |
} else {
|
|
| 1277 | 11x |
cbind(fdat, odat) |
| 1278 |
} |
|
| 1279 |
# figuring out colors |
|
| 1280 | 33x |
csf <- if (is.function(color.summary)) {
|
| 1281 | ! |
color.summary |
| 1282 | 33x |
} else if (grepl("^av|mea", color.summary, TRUE)) {
|
| 1283 | 33x |
splot.colormean |
| 1284 | 33x |
} else if (grepl("^mode", color.summary, TRUE)) {
|
| 1285 | ! |
function(x) names(which.max(table(x))) |
| 1286 |
} else {
|
|
| 1287 | ! |
function(x) lvs(x)[round(median(as.numeric(factor(x, lvs(x)))))] |
| 1288 |
} |
|
| 1289 | 33x |
colors <- substitute(colors) |
| 1290 | 33x |
seg$cols <- if (ck$co) {
|
| 1291 | 32x |
colors |
| 1292 | 33x |
} else if (any(paste(colors) %in% names(fdat))) {
|
| 1293 | 1x |
NULL |
| 1294 |
} else {
|
|
| 1295 | ! |
tryCatch(tdc(colors), error = function(e) NULL) |
| 1296 |
} |
|
| 1297 | 33x |
if (is.null(seg$cols)) {
|
| 1298 | 1x |
seg$cols <- eval(colors, fdat, parent.frame(1)) |
| 1299 |
} |
|
| 1300 | 33x |
ptxt$cbo <- substitute(colorby) |
| 1301 | 33x |
if (length(ptxt$cbo) > 1 && ptxt$cbo[[1]] == "list") {
|
| 1302 | ! |
ptxt$cbo <- ptxt$cbo[[2]] |
| 1303 |
} |
|
| 1304 | 33x |
if (!is.character(ptxt$cbo)) {
|
| 1305 | 33x |
ptxt$cbo <- deparse(ptxt$cbo) |
| 1306 |
} |
|
| 1307 | 33x |
if (length(seg$cols) == 1) {
|
| 1308 |
if ( |
|
| 1309 | 32x |
grepl("^bri|^dar|^pas", seg$cols, TRUE) &&
|
| 1310 | 32x |
(ck$cb || (seg$by$ll > 1 && seg$by$ll < 10)) |
| 1311 |
) {
|
|
| 1312 | 20x |
seg$cols <- splot.color(seed = seg$cols) |
| 1313 | 12x |
} else if (ck$co || grepl("^gra|^grey", seg$cols, TRUE)) {
|
| 1314 | 12x |
seg$cols <- splot.color(seg$by$ll, seed = "grey") |
| 1315 |
} |
|
| 1316 |
} |
|
| 1317 | 33x |
cl <- length(seg$cols) |
| 1318 | 33x |
seg$lcols <- seg$cols |
| 1319 | 33x |
ck[c("cbn", "cbb")] <- tg <- FALSE
|
| 1320 | 33x |
chl <- if (ck$cblegm) FALSE else ck$cbleg |
| 1321 | 33x |
if (ck$cb) {
|
| 1322 | 3x |
sca <- names(formals(splot.color)) |
| 1323 | 3x |
colorby <- substitute(colorby) |
| 1324 | 3x |
cba <- if (any(paste(colorby) %in% names(fdat))) {
|
| 1325 | 2x |
NULL |
| 1326 |
} else {
|
|
| 1327 | 1x |
tryCatch(tdc(colorby), error = function(e) NULL) |
| 1328 |
} |
|
| 1329 | 3x |
if (is.null(cba)) {
|
| 1330 | 2x |
cba <- eval(substitute(colorby), fdat) |
| 1331 |
} |
|
| 1332 | 3x |
if (is.null(cba) || (is.character(cba) && length(cba) == 1)) {
|
| 1333 | ! |
cba <- tdc(colorby) |
| 1334 |
} |
|
| 1335 | 3x |
if (!is.list(cba) || is.data.frame(cba)) {
|
| 1336 | 3x |
cba <- list(x = cba) |
| 1337 | ! |
} else if (is.null(names(cba))) {
|
| 1338 | ! |
names(cba) <- names(formals(splot.color))[seq_along(cba)] |
| 1339 | ! |
} else if (any(names(cba) == "")) {
|
| 1340 | ! |
tn <- names(cba) == "" |
| 1341 | ! |
names(cba)[tn] <- sca[seq_len(sum(tn))] |
| 1342 |
} |
|
| 1343 | 3x |
if (!is.null(ncol(cba$x)) && ncol(cba$x) > 1) {
|
| 1344 | ! |
if (!"by" %in% names(cba)) {
|
| 1345 | ! |
cba$by <- cba$x[, 2] |
| 1346 |
} |
|
| 1347 | ! |
cba$x <- cba$x[, 1] |
| 1348 |
} |
|
| 1349 | 3x |
cba$flat <- TRUE |
| 1350 | 3x |
cn <- names(cba) |
| 1351 | 3x |
ck$cbb <- "by" %in% cn |
| 1352 | 3x |
if (ck$mv && length(cba$x) * ck$mvnl == nr) {
|
| 1353 | ! |
cba$x <- rep(cba$x, ck$mvnl) |
| 1354 | ! |
if (ck$cbb) cba$by <- rep(cba$by, ck$mvnl) |
| 1355 |
} |
|
| 1356 | 3x |
if (ck$cbb) {
|
| 1357 | ! |
cba$by <- if (is.numeric(cba$by) && length(unique(cba$by)) > lim) {
|
| 1358 | ! |
ptxt$cbos <- if (missing(leg.title)) colorby else leg.title |
| 1359 | ! |
ptxt$cbos <- if (is.call(ptxt$cbos)) {
|
| 1360 | ! |
deparse(ptxt$cbos[[ |
| 1361 | ! |
if (cn[2] == "by" && length(ptxt$cbos) > 2) 3 else 2 |
| 1362 |
]]) |
|
| 1363 |
} else {
|
|
| 1364 | ! |
deparse(ptxt$cbos) |
| 1365 |
} |
|
| 1366 | ! |
splt(cba$by, ck$sp) |
| 1367 |
} else {
|
|
| 1368 | ! |
factor(cba$by, lvs(cba$by)) |
| 1369 |
} |
|
| 1370 |
if ( |
|
| 1371 | ! |
seg$by$e && |
| 1372 | ! |
seg$by$ll <= lim && |
| 1373 | ! |
length(cba$by) == nr && |
| 1374 | ! |
!identical(as.character(dat$by), as.character(cba$by)) |
| 1375 |
) {
|
|
| 1376 | ! |
cba$by <- dat$by:cba$by |
| 1377 | ! |
cbbl <- sub(":.*", "", lvs(cba$by))
|
| 1378 | ! |
colorby[[3]] <- as.name(paste0(ptxt$by, ":", colorby[[3]])) |
| 1379 | ! |
seg$lcols <- seg$cols <- splot.color(cbbl, seed = seg$cols) |
| 1380 | ! |
if (!ck$b && ck$line) {
|
| 1381 | ! |
if (length(lty) < seg$by$ll) {
|
| 1382 | ! |
lty <- seq_len(seg$by$ll) |
| 1383 |
} |
|
| 1384 | ! |
ck[c("lty", "ltym")] <- FALSE
|
| 1385 | ! |
lty <- rep(lty, table(cbbl)) |
| 1386 | ! |
seg$lty <- unique(lty) |
| 1387 |
} |
|
| 1388 |
} else {
|
|
| 1389 | ! |
lby <- length(lvs(cba$by)) |
| 1390 | ! |
if (!color.lock && cl < lby) {
|
| 1391 | ! |
seg$cols <- splot.color( |
| 1392 | ! |
as.list(rep.int(round(lby / cl + .49), cl)), |
| 1393 | ! |
seed = seg$cols |
| 1394 |
) |
|
| 1395 |
} |
|
| 1396 |
} |
|
| 1397 |
} |
|
| 1398 | 3x |
if (length(cba$x) == ck$orn) {
|
| 1399 | 3x |
cba$x <- cba$x[ck$omitted$all] |
| 1400 |
} |
|
| 1401 | 3x |
if (ck$cbb && length(cba$by) == ck$orn) {
|
| 1402 | ! |
cba$by <- cba$by[ck$omitted$all] |
| 1403 |
} |
|
| 1404 | 3x |
if (seg$by$e || !"seed" %in% cn) {
|
| 1405 | 3x |
cba$seed <- seg$cols |
| 1406 | 3x |
if ("seed" %in% cn) {
|
| 1407 | ! |
warning( |
| 1408 | ! |
"colorby's seed is ignored because by is specified -- use colors to set seeds", |
| 1409 | ! |
call. = FALSE |
| 1410 |
) |
|
| 1411 |
} |
|
| 1412 |
} |
|
| 1413 | 3x |
cn <- names(cba) |
| 1414 | 3x |
ckn <- cken <- is.numeric(cba$x) |
| 1415 | 3x |
if ((ck$t == 1 || any(seg$by$e, seg$f1$e)) && length(cba$x) == nr) {
|
| 1416 | 1x |
seg$cbxls <- lvs(cba$x) |
| 1417 | 1x |
if (ck$t != 3 && (!seg$by$e || seg$by$ll > lim)) {
|
| 1418 | 1x |
cba$x <- vapply( |
| 1419 | 1x |
split(cba$x, if (seg$by$e) dat$by else dat$x), |
| 1420 | 1x |
function(x) {
|
| 1421 | 2x |
if (ckn) {
|
| 1422 | 2x |
mean(x, na.rm = TRUE) |
| 1423 |
} else {
|
|
| 1424 | ! |
names(which.max(table(x))) |
| 1425 |
} |
|
| 1426 |
}, |
|
| 1427 | 1x |
if (ckn) 0 else "" |
| 1428 |
) |
|
| 1429 | 1x |
if (!ckn || length(seg$cbxls) <= lim) {
|
| 1430 | ! |
cba$x <- if (ckn) {
|
| 1431 | ! |
cba$x <- round(cba$x, 3) |
| 1432 | ! |
factor(cba$x, sort(unique(cba$x))) |
| 1433 |
} else {
|
|
| 1434 | ! |
factor(cba$x, seg$cbxls) |
| 1435 |
} |
|
| 1436 | ! |
ckn <- FALSE |
| 1437 |
} |
|
| 1438 | 1x |
if (ck$cbb && length(cba$by) == nr) {
|
| 1439 | ! |
cba$by <- factor( |
| 1440 | ! |
vapply( |
| 1441 | ! |
split(cba$by, if (seg$by$e) dat$by else dat$x), |
| 1442 | ! |
function(x) {
|
| 1443 | ! |
names(which.max(table(x))) |
| 1444 |
}, |
|
| 1445 |
"" |
|
| 1446 |
), |
|
| 1447 | ! |
lvs(cba$by) |
| 1448 |
) |
|
| 1449 | ! |
if (length(cba$x) != length(cba$by)) {
|
| 1450 | ! |
cba$by <- NULL |
| 1451 | ! |
ck$cbb <- FALSE |
| 1452 | ! |
warning( |
| 1453 | ! |
"colorby's by was dropped as it was not the same length as x after being aligned with the formula's x", |
| 1454 | ! |
call. = FALSE |
| 1455 |
) |
|
| 1456 |
} |
|
| 1457 |
} |
|
| 1458 | 1x |
if (ckn && !ck$b && ck$t == 1 && length(cba$x) == 2) {
|
| 1459 | ! |
cba$x <- c(mean(cba$x), cba$x) |
| 1460 | ! |
if (ck$cbb) {
|
| 1461 | ! |
cba$by <- factor( |
| 1462 | ! |
c(lvs(cba$by)[which.max(tabulate(cba$by))], as.character(cba$by)), |
| 1463 | ! |
lvs(cba$by) |
| 1464 |
) |
|
| 1465 |
} |
|
| 1466 |
} |
|
| 1467 | ! |
} else if (!ck$cbb) {
|
| 1468 | ! |
if (ck$t == 3) {
|
| 1469 | ! |
cba$by <- dat$by |
| 1470 |
} else {
|
|
| 1471 | ! |
cba$x <- data.frame(cba$x, dat$by) |
| 1472 | ! |
if (ck$b && seg$ll != 1) {
|
| 1473 | ! |
cba$x$x <- dat$x |
| 1474 |
} |
|
| 1475 | ! |
cba$x <- unlist( |
| 1476 | ! |
lapply(split(cba$x, dsf), function(x) {
|
| 1477 | ! |
lapply( |
| 1478 | ! |
split(x[, 1], x[, -1]), |
| 1479 | ! |
function(x) {
|
| 1480 | ! |
if (!length(x)) {
|
| 1481 | ! |
NA |
| 1482 | ! |
} else if (ckn) {
|
| 1483 | ! |
mean(x, na.rm = TRUE) |
| 1484 |
} else {
|
|
| 1485 | ! |
names(which.max(table(x))) |
| 1486 |
} |
|
| 1487 |
} |
|
| 1488 |
) |
|
| 1489 |
}), |
|
| 1490 | ! |
TRUE, |
| 1491 | ! |
FALSE |
| 1492 |
) |
|
| 1493 | ! |
if (length(cba$x) == seg$by$ll) {
|
| 1494 | ! |
names(cba$x) <- seg$by$l |
| 1495 |
} else {
|
|
| 1496 | ! |
seg$ill <- names(cba$x) |
| 1497 |
} |
|
| 1498 | ! |
if (!ckn) {
|
| 1499 | ! |
cba$x <- factor(cba$x, seg$cbxls) |
| 1500 |
} |
|
| 1501 | ! |
cba$by <- factor(rep_len(seg$by$l, length(cba$x)), seg$by$l) |
| 1502 | ! |
if (ck$cblegm) ck$cbleg <- FALSE |
| 1503 |
} |
|
| 1504 |
} |
|
| 1505 |
} |
|
| 1506 | 3x |
if (ck$cbb) {
|
| 1507 | ! |
if (length(cba$by) == nr && length(cba$x) == seg$by$ll) {
|
| 1508 | ! |
tn <- lapply(split(cba$by, dat$by), unique) |
| 1509 | ! |
if (all(vapply(tn, length, 0) == 1)) {
|
| 1510 | ! |
cba$by <- unlist(tn, use.names = FALSE) |
| 1511 |
} else {
|
|
| 1512 | ! |
cba$by <- NULL |
| 1513 | ! |
warning( |
| 1514 | ! |
"colorby's by was dropped as its levels within levels of by are not unique", |
| 1515 | ! |
call. = FALSE |
| 1516 |
) |
|
| 1517 |
} |
|
| 1518 |
} |
|
| 1519 | ! |
if (ck$cbleg) {
|
| 1520 | ! |
chl <- TRUE |
| 1521 | ! |
if (missing(leg.title)) {
|
| 1522 | ! |
leg.title <- substitute(colorby) |
| 1523 | ! |
leg.title <- if (is.call(leg.title) && length(leg.title) > 2) {
|
| 1524 | ! |
deparse(leg.title[[if (cn[2] == "by") 3 else 2]]) |
| 1525 |
} else {
|
|
| 1526 | ! |
deparse(leg.title) |
| 1527 |
} |
|
| 1528 |
} |
|
| 1529 | ! |
ptxt$leg <- lvs(cba$by) |
| 1530 |
} |
|
| 1531 |
} else {
|
|
| 1532 | 3x |
if (ck$cbleg && (ck$t == 1 || !seg$by$e)) {
|
| 1533 | 3x |
chl <- TRUE |
| 1534 | 3x |
tg <- ckn |
| 1535 | 3x |
ll <- all(ck$t != 1 || (length(seg$x$l) > 2 || seg$by$ll > 2)) |
| 1536 | 3x |
if (ll) {
|
| 1537 | 2x |
if (is.call(cba$x)) {
|
| 1538 | ! |
cba$x <- tdc(cba$x) |
| 1539 |
} |
|
| 1540 | 2x |
ll <- length(unique(cba$x)) > 2 |
| 1541 |
} |
|
| 1542 | 3x |
if (missing(leg.title) && length(ptxt$cbo) == 1) {
|
| 1543 | 3x |
leg.title <- ptxt$cbo |
| 1544 |
} |
|
| 1545 | 3x |
ptxt$leg <- if (ckn) {
|
| 1546 | 3x |
formatC( |
| 1547 | 3x |
c(min(cba$x), if (ll) mean(cba$x), max(cba$x)), |
| 1548 | 3x |
2, |
| 1549 | 3x |
format = "f" |
| 1550 |
) |
|
| 1551 |
} else {
|
|
| 1552 | ! |
lvs(cba$x) |
| 1553 |
} |
|
| 1554 | ! |
} else if (!seg$by$e) {
|
| 1555 | ! |
ck$leg <- 0 |
| 1556 |
} |
|
| 1557 |
} |
|
| 1558 | 3x |
if (!ckn && length(cba$x) > lim && !"shuffle" %in% cn) {
|
| 1559 | ! |
cba$shuffle <- TRUE |
| 1560 |
} |
|
| 1561 | 3x |
sca <- cn %in% sca |
| 1562 | 3x |
if (any(!sca)) {
|
| 1563 | ! |
warning( |
| 1564 | ! |
paste0("unused colorby arguments: ", paste(cn[!sca], collapse = ", ")),
|
| 1565 | ! |
call. = FALSE |
| 1566 |
) |
|
| 1567 |
} |
|
| 1568 | 3x |
seg$cols <- do.call(splot.color, cba[sca]) |
| 1569 | 3x |
if (!is.null(names(cba$x))) {
|
| 1570 | 1x |
names(seg$cols) <- names(cba$x) |
| 1571 |
} |
|
| 1572 | 3x |
if (!chl || ck$cbb) {
|
| 1573 | ! |
ck$cbn <- TRUE |
| 1574 | ! |
ptxt$cbn <- paste0( |
| 1575 | ! |
"Colored by ", |
| 1576 | ! |
if (ckn || cken) "value of " else "levels of ", |
| 1577 | ! |
ptxt$cbo, |
| 1578 |
". " |
|
| 1579 |
) |
|
| 1580 |
} |
|
| 1581 | 3x |
if (seg$by$e && !ck$cbb) {
|
| 1582 | ! |
if (length(seg$cols) == length(ptxt$leg)) {
|
| 1583 | ! |
seg$lcols <- seg$cols |
| 1584 | ! |
} else if (ckn && ck$cbb) {
|
| 1585 | ! |
seg$lcols <- seg$cols[c(which.min(cba$x), which.max(cba$x))] |
| 1586 |
} |
|
| 1587 |
} |
|
| 1588 | 3x |
if (chl) {
|
| 1589 | 3x |
if (ck$legm && !ck$leg) {
|
| 1590 | ! |
ck$leg <- 1 + seg$ll > 1 |
| 1591 |
} |
|
| 1592 |
if ( |
|
| 1593 | 3x |
(ck$ltym || length(lty) == length(seg$cbxls)) && |
| 1594 | 3x |
(!seg$by$e || seg$by$ll > length(ptxt$leg)) |
| 1595 |
) {
|
|
| 1596 | 3x |
ck[c("lty", "ltym")] <- FALSE
|
| 1597 | 3x |
if (!is.numeric(lty)) {
|
| 1598 | 3x |
lty <- 1 |
| 1599 |
} |
|
| 1600 | 3x |
seg$lty <- rep_len(lty, seg$by$ll) |
| 1601 | 3x |
if (!ck$ltym) {
|
| 1602 | 3x |
lty <- seq_along(seg$cbxls) |
| 1603 |
} |
|
| 1604 | 3x |
if (ck$ltym && seg$by$e && !ckn) {
|
| 1605 | ! |
cbl <- cba[[if (ck$cbb) "by" else "x"]] |
| 1606 | ! |
for (g in seq_along(seg$cbxls)) {
|
| 1607 | ! |
seg$lty[cbl == seg$cbxls[[g]]] <- lty[[g]] |
| 1608 |
} |
|
| 1609 |
} |
|
| 1610 | 3x |
lty <- unique(seg$lty) |
| 1611 |
} |
|
| 1612 | 3x |
if (tg) {
|
| 1613 | 3x |
l <- length(seg$cols) |
| 1614 | 3x |
seg$lcols <- seg$cols[order(cba$x)[c( |
| 1615 | 3x |
1, |
| 1616 | 3x |
if (ll) round(mean(seq_len(l))), |
| 1617 | 3x |
l |
| 1618 |
)]] |
|
| 1619 |
} else if ( |
|
| 1620 | ! |
seg$by$e && |
| 1621 | ! |
length(seg$cols) == seg$by$ll && |
| 1622 | ! |
length(ptxt$leg) == seg$by$ll |
| 1623 |
) {
|
|
| 1624 | ! |
seg$lcols <- seg$cols |
| 1625 |
} |
|
| 1626 |
} else {
|
|
| 1627 | ! |
ptxt$leg <- if ( |
| 1628 | ! |
length(seg$cols) == seg$by$ll && !is.null(names(seg$cols)) |
| 1629 |
) {
|
|
| 1630 | ! |
names(seg$cols) |
| 1631 |
} else {
|
|
| 1632 | ! |
seg$by$l |
| 1633 |
} |
|
| 1634 | ! |
if (length(ptxt$leg) == length(seg$cols)) {
|
| 1635 | ! |
seg$lcols <- seg$cols |
| 1636 | ! |
} else if (all(ptxt$leg %in% names(seg$cols))) {
|
| 1637 | ! |
seg$lcols <- seg$cols[ptxt$leg] |
| 1638 | ! |
} else if (seg$by$e && length(seg$cols) == nr) {
|
| 1639 | ! |
seg$lcols <- vapply(split(seg$cols, dat$by), csf, "") |
| 1640 |
} |
|
| 1641 |
} |
|
| 1642 |
} else {
|
|
| 1643 | 30x |
if (!color.lock && cl < seg$by$ll) {
|
| 1644 | ! |
seg$cols <- |
| 1645 | ! |
splot.color( |
| 1646 | ! |
as.list(rep.int(round(seg$by$ll / cl + .49), cl)), |
| 1647 | ! |
seed = seg$cols |
| 1648 |
) |
|
| 1649 |
} |
|
| 1650 |
if ( |
|
| 1651 | 30x |
ck$t != 2 && |
| 1652 | 30x |
!any(length(seg$cols) == c(nr, seg$by$ll)) && |
| 1653 | 30x |
(!ck$b || seg$by$e) |
| 1654 |
) {
|
|
| 1655 | 13x |
seg$cols <- rep_len(seg$cols, seg$by$ll) |
| 1656 |
} |
|
| 1657 |
} |
|
| 1658 | 33x |
if (seg$by$e && !all(seg$by$l %in% names(seg$cols))) {
|
| 1659 | 17x |
if (length(seg$cols) == seg$by$ll) {
|
| 1660 | 13x |
names(seg$cols) <- seg$by$l |
| 1661 | 13x |
if (!ck$cbb && !chl) seg$lcols <- seg$cols |
| 1662 | 4x |
} else if (length(seg$lcols) == seg$by$ll) {
|
| 1663 | ! |
names(seg$lcols) <- seg$by$l |
| 1664 | 4x |
} else if (length(ptxt$leg) == seg$by$ll) {
|
| 1665 | 4x |
if (length(seg$lcols) == nr) {
|
| 1666 | ! |
seg$lcols <- split(seg$lcols, dat$by) |
| 1667 |
} else {
|
|
| 1668 | 4x |
seg$lcols <- rep_len(seg$lcols, seg$by$ll) |
| 1669 | 4x |
if (any(grepl(names(cdat)[1], names(seg$lcols), fixed = TRUE))) {
|
| 1670 | ! |
for (g in names(cdat)) {
|
| 1671 | ! |
names(seg$lcols) <- sub( |
| 1672 | ! |
paste0(g, "."), |
| 1673 |
"", |
|
| 1674 | ! |
names(seg$lcols), |
| 1675 | ! |
fixed = TRUE |
| 1676 |
) |
|
| 1677 |
} |
|
| 1678 | ! |
if (all(seg$by$l %in% names(seg$lcols))) {
|
| 1679 | ! |
seg$lcols <- seg$lcols[seg$by$l] |
| 1680 |
} |
|
| 1681 |
} else {
|
|
| 1682 | 4x |
names(seg$lcols) <- seg$by$l |
| 1683 |
} |
|
| 1684 |
} |
|
| 1685 |
} |
|
| 1686 | 17x |
if (ck$b && length(seg$cols) == nr) {
|
| 1687 | ! |
seg$cols <- unlist( |
| 1688 | ! |
lapply( |
| 1689 | ! |
split(data.frame(seg$cols, dat$by), dat$x), |
| 1690 | ! |
function(d) vapply(split(d[, 1], d[, 2], drop = TRUE), csf, "") |
| 1691 |
), |
|
| 1692 | ! |
use.names = FALSE |
| 1693 |
) |
|
| 1694 |
} |
|
| 1695 |
} |
|
| 1696 | 33x |
if (ck$opacity && (ck$t != 3 || !points)) {
|
| 1697 | ! |
if (is.list(seg$cols)) {
|
| 1698 | ! |
lapply(seg$cols, adjustcolor, opacity) |
| 1699 |
} else {
|
|
| 1700 | ! |
seg$cols[] <- adjustcolor(seg$cols, opacity) |
| 1701 |
} |
|
| 1702 |
} |
|
| 1703 | 33x |
if (lvn && length(ptxt$by)) {
|
| 1704 | 15x |
ptxt$l.by[] <- paste0(paste0(ptxt$by, ": "), ptxt$l.by) |
| 1705 |
} |
|
| 1706 | 33x |
if (length(seg$cols) == nr) {
|
| 1707 | 3x |
if (any(seg$by$e && !ck$b, seg$f1$e, seg$f2$e)) {
|
| 1708 | 1x |
seg$scols <- split( |
| 1709 | 1x |
if (seg$by$e && !ck$b) data.frame(seg$cols, dat$by) else seg$cols, |
| 1710 | 1x |
dsf |
| 1711 |
) |
|
| 1712 | 1x |
if (!ck$b) {
|
| 1713 | ! |
if (seg$by$e) {
|
| 1714 | ! |
seg$scols <- lapply(seg$scols, function(d) split(d[, 1], d[, 2])) |
| 1715 |
} |
|
| 1716 | ! |
if (ck$t == 1) {
|
| 1717 | ! |
seg$scols <- lapply(seg$scols, function(bl) {
|
| 1718 | ! |
vapply( |
| 1719 | ! |
bl, |
| 1720 | ! |
function(bll) {
|
| 1721 | ! |
if (length(bll)) csf(bll) else "" |
| 1722 |
}, |
|
| 1723 |
"" |
|
| 1724 |
) |
|
| 1725 |
}) |
|
| 1726 |
} |
|
| 1727 |
} |
|
| 1728 |
} |
|
| 1729 | 30x |
} else if (seg$ll != 1 && "ill" %in% names(seg)) {
|
| 1730 | ! |
seg$scols <- lapply( |
| 1731 | ! |
names(cdat), |
| 1732 | ! |
function(n) seg$cols[grepl(n, names(seg$cols), fixed = TRUE)] |
| 1733 |
) |
|
| 1734 | ! |
names(seg$scols) <- names(cdat) |
| 1735 |
} |
|
| 1736 | 33x |
if (ck$t == 2 && seg$by$ll > 1 && !all(seg$by$l %in% names(seg$cols))) {
|
| 1737 | 4x |
seg$cols <- if (length(seg$lcols) == seg$by$ll) {
|
| 1738 | 4x |
seg$lcols |
| 1739 | 4x |
} else if (length(seg$cols) == 1) {
|
| 1740 | ! |
splot.color(seq_len(seg$by$ll), seed = seg$cols) |
| 1741 |
} else {
|
|
| 1742 | ! |
rep_len(seg$cols, seg$by$ll) |
| 1743 |
} |
|
| 1744 | ! |
if (is.null(names(seg$cols))) names(seg$cols) <- seg$by$l |
| 1745 |
} |
|
| 1746 |
# figuring out parts of the plot |
|
| 1747 | 33x |
ylab <- if (ck$ly) ptxt$y else "" |
| 1748 | 33x |
xlab <- if (ck$lx && length(ptxt$x)) ptxt$x else "" |
| 1749 | 33x |
main <- if (is.logical(title) && title) {
|
| 1750 | 31x |
paste0( |
| 1751 | 31x |
if (ck$t == 2) {
|
| 1752 | 9x |
paste("Density of", ptxt$x)
|
| 1753 |
} else {
|
|
| 1754 | 22x |
paste( |
| 1755 | 22x |
ptxt$y, |
| 1756 | 22x |
"by", |
| 1757 | 22x |
ptxt$x |
| 1758 |
) |
|
| 1759 |
}, |
|
| 1760 | 31x |
if (seg$by$e && !ck$mv) paste(" at levels of", ptxt$by),
|
| 1761 | 31x |
if (length(ptxt$bet) != 0) {
|
| 1762 | 10x |
paste( |
| 1763 | 10x |
" between", |
| 1764 | 10x |
paste(ptxt$bet, collapse = " & ") |
| 1765 |
) |
|
| 1766 |
} |
|
| 1767 |
) |
|
| 1768 | 33x |
} else if (is.character(title)) {
|
| 1769 | 1x |
title |
| 1770 |
} else {
|
|
| 1771 |
"" |
|
| 1772 |
} |
|
| 1773 | 33x |
if (!is.character(note)) {
|
| 1774 | 32x |
if (!is.logical(note) || note) {
|
| 1775 | 32x |
ck$er <- ck$t == 1 && ck$el |
| 1776 | 32x |
ck$spm <- txt$split != "none" |
| 1777 |
if ( |
|
| 1778 | 32x |
ck$er && |
| 1779 | 32x |
all(vapply( |
| 1780 | 32x |
cdat, |
| 1781 | 32x |
function(d) {
|
| 1782 | 18x |
if (!is.data.frame(d)) {
|
| 1783 | 14x |
all(vapply(d, function(dd) !anyDuplicated(dd$x), TRUE)) |
| 1784 |
} else {
|
|
| 1785 | 4x |
!anyDuplicated(d$x) |
| 1786 |
} |
|
| 1787 |
}, |
|
| 1788 | 32x |
TRUE |
| 1789 |
)) |
|
| 1790 |
) {
|
|
| 1791 | ! |
ck[c("el", "er")] <- FALSE
|
| 1792 |
} |
|
| 1793 | 32x |
if (any(ck$cbn, ck$spm, ck$er, ck$t == 3 && ck$ltck)) {
|
| 1794 | 21x |
if (ck$spm) {
|
| 1795 | 5x |
tv <- unique(c( |
| 1796 | 5x |
if (seg$x$s) ptxt$x, |
| 1797 | 5x |
if (seg$by$s) ptxt$by, |
| 1798 | 5x |
if (seg$f1$s) ptxt$bet[1], |
| 1799 | 5x |
if (seg$f2$s) ptxt$bet[2], |
| 1800 | 5x |
if ("cbos" %in% names(ptxt)) ptxt$cbos
|
| 1801 |
)) |
|
| 1802 | 5x |
tv <- sub( |
| 1803 | 5x |
", (?=[A-z0-9]+$)", |
| 1804 | 5x |
if (length(tv) > 2) ", & " else " & ", |
| 1805 | 5x |
paste(tv, collapse = ", "), |
| 1806 | 5x |
perl = TRUE |
| 1807 |
) |
|
| 1808 |
} |
|
| 1809 | 21x |
note <- paste0( |
| 1810 | 21x |
if (ck$spm) paste0(tv, " split by ", txt$split, ". "), |
| 1811 | 21x |
if (ck$er) {
|
| 1812 | 10x |
paste( |
| 1813 | 10x |
"Error bars show", |
| 1814 | 10x |
ifelse(ck$e, "standard error. ", "95% confidence intervals. ") |
| 1815 |
) |
|
| 1816 |
}, |
|
| 1817 | 21x |
if (ck$cbn) ptxt$cbn, |
| 1818 | 21x |
if (ck$t == 3 && ck$ltck) {
|
| 1819 | 11x |
paste0( |
| 1820 | 11x |
"Line type: ", |
| 1821 | 11x |
switch( |
| 1822 | 11x |
ck$ltco, |
| 1823 | 11x |
li = "lm", |
| 1824 | 11x |
lo = "loess", |
| 1825 | 11x |
sm = "spline", |
| 1826 | 11x |
e = "connected", |
| 1827 | 11x |
pr = "probability" |
| 1828 |
), |
|
| 1829 |
"." |
|
| 1830 |
) |
|
| 1831 |
} |
|
| 1832 |
) |
|
| 1833 |
} |
|
| 1834 |
} else {
|
|
| 1835 | ! |
note <- "" |
| 1836 |
} |
|
| 1837 |
} |
|
| 1838 | 33x |
ck$sud <- (!is.logical(sud) || sud) && (is.character(sud) || ck$su || ck$c) |
| 1839 | 33x |
ck$sub <- (!is.logical(sub) || sub) && |
| 1840 | 33x |
(is.character(sub) || seg$ll > 1 || ndisp) |
| 1841 | 33x |
pdo <- list(...) |
| 1842 | 33x |
l2m <- function(l) {
|
| 1843 | 1x |
tl <- round(l^.5) |
| 1844 | 1x |
c(tl + all(l > c(tl^2, tl * (tl - 1))), tl) |
| 1845 |
} |
|
| 1846 | 33x |
seg$dim <- if (any(ckl <- c("mfrow", "mfcol") %in% names(pdo))) {
|
| 1847 | ! |
pdo[[if (ckl[1]) "mfrow" else "mfcol"]] |
| 1848 | 33x |
} else if (!seg$f1$e) {
|
| 1849 | 22x |
c(1, 1) |
| 1850 | 33x |
} else if (!seg$f2$e) {
|
| 1851 | 6x |
if (seg$f1$ll > 2) l2m(seg$f1$ll) else c(2, 1) |
| 1852 |
} else {
|
|
| 1853 | 5x |
c(seg$f1$ll, seg$f2$ll) |
| 1854 |
} |
|
| 1855 | 33x |
seg$l <- t(data.frame(strsplit(names(cdat), ".^^.", fixed = TRUE))) |
| 1856 | 33x |
if (seg$f1$e) {
|
| 1857 | 11x |
rownames(seg$l) <- match(seg$l[, 1], seg$f1$l) |
| 1858 | 11x |
seg[c("f1", "f2")] <- lapply(c("f1", "f2"), function(n) {
|
| 1859 | 22x |
nl <- seg[[n]] |
| 1860 | 22x |
if (nl$e) {
|
| 1861 | 16x |
nl$l <- unique(seg$l[, if (n == "f1") 1 else 2]) |
| 1862 |
} |
|
| 1863 | 22x |
if (nl$e) {
|
| 1864 | 16x |
nl$ll <- length(nl$l) |
| 1865 |
} |
|
| 1866 | 22x |
nl |
| 1867 |
}) |
|
| 1868 |
} |
|
| 1869 | 33x |
nc <- seg$dim[1] * seg$dim[2] |
| 1870 | 33x |
if (length(ptxt$leg) == 1 && ptxt$leg == "NA") {
|
| 1871 | 13x |
ck$leg <- 0 |
| 1872 |
} |
|
| 1873 |
if ( |
|
| 1874 | 33x |
ck$leg == 1 && |
| 1875 | 33x |
ck$legm && |
| 1876 | 33x |
(dev.size(units = "in")[1] < 2 || |
| 1877 | 33x |
(all(seg$dim == 1) && (ck$t != 1 || seg$by$ll < 9))) |
| 1878 |
) {
|
|
| 1879 | 10x |
ck$leg <- 2 |
| 1880 |
} |
|
| 1881 | 33x |
if (ck$leg == 1) {
|
| 1882 | 10x |
if (is.logical(leg) || is.character(leg)) leg <- nc + 1 |
| 1883 |
} |
|
| 1884 | 33x |
dop <- par(no.readonly = TRUE) |
| 1885 | 33x |
if (drop["bet"] && !any(ckl) && any(nc - seg$ll >= seg$dim)) {
|
| 1886 | 1x |
seg$dim <- l2m(seg$ll) |
| 1887 | 1x |
nc <- seg$dim[1] * seg$dim[2] |
| 1888 |
} |
|
| 1889 | 33x |
seg$dmat <- matrix(seq_len(nc), seg$dim[2], seg$dim[1]) |
| 1890 | 33x |
if (!drop["bet"] && seg$f2$e) {
|
| 1891 | ! |
seg$lc <- vapply( |
| 1892 | ! |
seg$f1$l, |
| 1893 | ! |
function(l) seg$f2$l %in% seg$l[seg$l[, 1] == l, 2], |
| 1894 | ! |
logical(seg$f2$ll) |
| 1895 |
) |
|
| 1896 |
} else {
|
|
| 1897 | 33x |
seg$lc <- seg$dmat == 0 |
| 1898 | 33x |
seg$lc[seq_len(seg$ll)] <- TRUE |
| 1899 |
} |
|
| 1900 | 33x |
if (nc > seg$ll) {
|
| 1901 | ! |
if (any(ckl)) {
|
| 1902 | ! |
tm <- lapply(dim(seg$lc), seq_len) |
| 1903 | ! |
mm <- matrix(FALSE, seg$dim[2], seg$dim[1]) |
| 1904 | ! |
mm[tm[[1]], tm[[2]]] <- seg$lc |
| 1905 | ! |
seg$lc <- mm |
| 1906 |
} |
|
| 1907 | ! |
if (!drop["bet"]) {
|
| 1908 | ! |
seg$dmat[seg$lc] <- seq_len(seg$ll) |
| 1909 | ! |
seg$dmat[!seg$lc] <- seq_len(sum(!seg$lc)) + seg$ll |
| 1910 |
} |
|
| 1911 |
} |
|
| 1912 | 33x |
ck$legcol <- FALSE |
| 1913 | 33x |
if (lpos == "auto") {
|
| 1914 | 33x |
"topright" |
| 1915 |
} |
|
| 1916 | 33x |
lega <- list( |
| 1917 | 33x |
x = lpos, |
| 1918 | 33x |
col = seg$lcols, |
| 1919 | 33x |
cex = cex["leg"], |
| 1920 | 33x |
text.font = font["leg"], |
| 1921 | 33x |
bty = "n", |
| 1922 | 33x |
x.intersp = .5, |
| 1923 | 33x |
xjust = .5, |
| 1924 | 33x |
legend = ptxt$leg |
| 1925 |
) |
|
| 1926 |
if ( |
|
| 1927 | 33x |
ck$legt && |
| 1928 | 33x |
(is.character(leg.title) && |
| 1929 | 33x |
length(leg.title) == 1 || |
| 1930 | 33x |
length(ptxt$by) == 1) |
| 1931 |
) {
|
|
| 1932 | 19x |
lega$title <- if (is.character(leg.title)) leg.title else ptxt$by |
| 1933 |
} |
|
| 1934 | 33x |
l <- length(lega$legend) |
| 1935 | 33x |
seg$lwd <- rep_len(if (is.numeric(lwd)) lwd else 2, seg$by$ll) |
| 1936 | 33x |
if (!"lty" %in% names(seg)) {
|
| 1937 | 30x |
seg$lty <- rep_len( |
| 1938 | 30x |
if (!ck$ltym && !ck$lty) {
|
| 1939 | ! |
lty |
| 1940 | 30x |
} else if (ck$cbleg && ck$cbb && seg$by$ll == length(cba$by)) {
|
| 1941 | ! |
as.numeric(cba$by) |
| 1942 | 30x |
} else if (ck$lty && lty) {
|
| 1943 | 30x |
seq_len(6) |
| 1944 |
} else {
|
|
| 1945 | ! |
1 |
| 1946 |
}, |
|
| 1947 | 30x |
seg$by$ll |
| 1948 |
) |
|
| 1949 |
} |
|
| 1950 | 33x |
if (length(seg$cols) == length(seg$lcols)) {
|
| 1951 | 31x |
names(seg$lcols) <- names(seg$cols) |
| 1952 |
} |
|
| 1953 | 33x |
if (seg$by$e || ck$cbb) {
|
| 1954 | 17x |
names(seg$lwd) <- names(seg$lty) <- if (length(seg$lcols) == seg$by$ll) {
|
| 1955 | 17x |
names(seg$lcols) |
| 1956 | 17x |
} else if (all(c(length(seg$lwd), length(seg$lty)) == length(seg$cols))) {
|
| 1957 | ! |
names(seg$cols) |
| 1958 |
} else {
|
|
| 1959 | ! |
seg$by$l |
| 1960 |
} |
|
| 1961 |
} |
|
| 1962 | 33x |
lega$lwd <- if (seg$by$ll == l) {
|
| 1963 | 30x |
seg$lwd |
| 1964 |
} else {
|
|
| 1965 | 3x |
rep_len(if (is.numeric(lwd)) lwd else 2, l) |
| 1966 |
} |
|
| 1967 | 33x |
lega$lty <- if (seg$by$ll == l) {
|
| 1968 | 30x |
seg$lty |
| 1969 |
} else {
|
|
| 1970 | 3x |
rep_len( |
| 1971 | 3x |
if (!ck$ltym && !ck$lty) {
|
| 1972 | 3x |
lty |
| 1973 | 3x |
} else if (ck$lty && lty) {
|
| 1974 | ! |
seq_len(6) |
| 1975 |
} else {
|
|
| 1976 | ! |
1 |
| 1977 |
}, |
|
| 1978 | 3x |
l |
| 1979 |
) |
|
| 1980 |
} |
|
| 1981 | 33x |
if (!missing(leg.args)) {
|
| 1982 | ! |
lega[names(leg.args)] <- leg.args |
| 1983 |
} |
|
| 1984 | 33x |
if (any(tck <- !names(lega) %in% names(formals(legend)))) {
|
| 1985 | ! |
warning( |
| 1986 | ! |
"dropped items from leg.args: ", |
| 1987 | ! |
paste(names(lega)[tck], collapse = ", "), |
| 1988 | ! |
call. = FALSE |
| 1989 |
) |
|
| 1990 | ! |
lega <- lega[!tck] |
| 1991 |
} |
|
| 1992 |
if ( |
|
| 1993 | 33x |
(ck$legm || !ck$leg) && |
| 1994 | 33x |
missing(leg.args) && |
| 1995 | 33x |
(sum(strheight(lega$legend, "i")) * |
| 1996 | 33x |
cex["leg"] * |
| 1997 | 33x |
1.5 / |
| 1998 | 33x |
if ("ncol" %in% names(pdo)) {
|
| 1999 | ! |
pdo$ncol |
| 2000 |
} else {
|
|
| 2001 | 33x |
1 |
| 2002 |
}) > |
|
| 2003 | 33x |
dev.size()[2] |
| 2004 |
) {
|
|
| 2005 | ! |
ck$leg <- 0 |
| 2006 | ! |
if (ck$ltym) seg$lty[] <- 1 |
| 2007 |
} |
|
| 2008 | 33x |
if (ck$leg == 1) {
|
| 2009 | 10x |
if (ck$legm && nc > seg$ll) {
|
| 2010 | ! |
leg <- which(!seg$lc)[1] |
| 2011 |
} |
|
| 2012 | 10x |
if (nc > seg$ll && leg <= nc) {
|
| 2013 | ! |
if (seg$lc[leg] && !drop["bet"]) {
|
| 2014 | ! |
mm <- which(!seg$lc) |
| 2015 | ! |
leg <- mm[which.min(abs(mm - leg))] |
| 2016 |
} |
|
| 2017 | ! |
if (seg$lc[leg]) {
|
| 2018 | ! |
seg$lc[] <- TRUE |
| 2019 | ! |
seg$lc[leg] <- FALSE |
| 2020 | ! |
seg$lc[seg$lc][bsq <- seq_len(nc - seg$ll - 1) + seg$ll] <- FALSE |
| 2021 | ! |
seg$dmat[seg$lc] <- seq_len(seg$ll) |
| 2022 | ! |
seg$dmat[leg] <- seg$ll + 1 |
| 2023 | ! |
seg$lc[leg] <- TRUE |
| 2024 | ! |
seg$dmat[!seg$lc] <- bsq + 1 |
| 2025 |
} else {
|
|
| 2026 | ! |
seg$lc[leg] <- TRUE |
| 2027 | ! |
seg$dmat[leg] <- seg$ll + 1 |
| 2028 | ! |
seg$dmat[!seg$lc] <- seq_len(sum(!seg$lc)) + seg$ll + 1 |
| 2029 |
} |
|
| 2030 | ! |
if (ck$lp) lega$x <- "center" |
| 2031 | 10x |
} else if (ck$lp) {
|
| 2032 | 10x |
lega$x <- "right" |
| 2033 |
} |
|
| 2034 | 10x |
if (nc == seg$ll || leg > nc) {
|
| 2035 | 10x |
seg$dmat[seg$dmat == seg$ll + 1] <- nc + 1 |
| 2036 | 10x |
seg$dmat <- rbind(seg$dmat, rep.int(seg$ll + 1, seg$dim[1])) |
| 2037 | 10x |
ck$legcol <- TRUE |
| 2038 |
} |
|
| 2039 |
} |
|
| 2040 | 33x |
seg[c("dmat", "lc")] <- lapply(seg[c("dmat", "lc")], t)
|
| 2041 | 33x |
seg$prat <- if (missing(prat) && ck$legcol) {
|
| 2042 | 10x |
lw <- max( |
| 2043 | 10x |
.4, |
| 2044 | 10x |
if (ck$legt) strwidth(lega$title, "i"), |
| 2045 | 10x |
strwidth(ptxt$leg, "i") / if (seg$ll > 1) 1.3 else 1.7 |
| 2046 |
) + |
|
| 2047 | 10x |
if (all(seg$dim == 1)) .5 else .2 |
| 2048 | 10x |
fw <- (dev.size(units = "in")[1] - lw) / seg$dim[2] |
| 2049 | 10x |
c(fw, max(fw / 10, lw)) |
| 2050 |
} else {
|
|
| 2051 | 23x |
prat |
| 2052 |
} |
|
| 2053 | 33x |
op <- list( |
| 2054 | 33x |
oma = c( |
| 2055 | 33x |
sum(is.character(note) && note != "", ck$lx) + .15, |
| 2056 | 33x |
ck$ly * .9, |
| 2057 | 33x |
max(sum((main != "") * 1.8 + if (sum(seg$dim) > 2) .5 else 0, ck$sud), 1), |
| 2058 | 33x |
.5 |
| 2059 |
), |
|
| 2060 | 33x |
mar = c( |
| 2061 | 33x |
if (ck$lx) 2 else 1.5, |
| 2062 | 33x |
if (ck$ly) 3 else 2.4, |
| 2063 | 33x |
(ck$sud && (ck$su || ck$c)) * |
| 2064 | 33x |
ifelse(seg$ll > 1, 2, 0) + |
| 2065 | 33x |
(ck$sub && sum(seg$dim) > 2) * 1.3, |
| 2066 | 33x |
0 |
| 2067 |
), |
|
| 2068 | 33x |
mgp = c(3, .3, 0), |
| 2069 | 33x |
font.main = 1, |
| 2070 | 33x |
font.lab = 2, |
| 2071 | 33x |
cex.main = 1, |
| 2072 | 33x |
cex.lab = 1, |
| 2073 | 33x |
cex.axis = 1, |
| 2074 | 33x |
tcl = -.2, |
| 2075 | 33x |
pch = 19, |
| 2076 | 33x |
xpd = NA |
| 2077 |
) |
|
| 2078 | 33x |
if (length(pdo) != 0) {
|
| 2079 | ! |
if (any(cpdo <- (npdo <- names(pdo)) %in% names(dop))) {
|
| 2080 | ! |
ck$mai <- "mai" %in% npdo |
| 2081 | ! |
op[npdo[cpdo]] <- pdo[cpdo] |
| 2082 | ! |
if ("font.sub" %in% names(op)) {
|
| 2083 | ! |
op$font.main <- op$font.sub |
| 2084 |
} |
|
| 2085 | ! |
if ("cex.sub" %in% names(op)) {
|
| 2086 | ! |
op$cex.main <- op$cex.sub |
| 2087 |
} |
|
| 2088 | ! |
if ("col.sub" %in% names(op)) op$col.main <- op$col.sub
|
| 2089 |
} |
|
| 2090 | ! |
pdo <- pdo[!cpdo] |
| 2091 |
} |
|
| 2092 | 33x |
if (!"horiz" %in% names(pdo) && !"ncol" %in% names(leg.args)) {
|
| 2093 | 33x |
lega$ncol <- 1 |
| 2094 |
} |
|
| 2095 | 33x |
if (length(pdo) != 0) {
|
| 2096 |
if ( |
|
| 2097 | ! |
any( |
| 2098 | ! |
cpdo <- (npdo %in% names(formals(legend)) & !npdo %in% names(leg.args)) |
| 2099 |
) |
|
| 2100 |
) {
|
|
| 2101 | ! |
lega[npdo[cpdo]] <- pdo[cpdo] |
| 2102 |
} |
|
| 2103 | ! |
if (any(!cpdo)) {
|
| 2104 | ! |
warning( |
| 2105 | ! |
"unused argument", |
| 2106 | ! |
if (sum(!cpdo) == 1) ": " else "s: ", |
| 2107 | ! |
paste(names(pdo)[!cpdo], collapse = ", "), |
| 2108 | ! |
call. = FALSE |
| 2109 |
) |
|
| 2110 |
} |
|
| 2111 |
} |
|
| 2112 | 33x |
expand_color_code <- function(e) {
|
| 2113 | 363x |
if (is.character(e) && all(grepl("^#[0-9a-f]{3}$", e, TRUE))) {
|
| 2114 | ! |
paste0(e, substring(e, 2)) |
| 2115 |
} else {
|
|
| 2116 | 363x |
e |
| 2117 |
} |
|
| 2118 |
} |
|
| 2119 | 33x |
pdo <- lapply(pdo, expand_color_code) |
| 2120 | 33x |
op <- lapply(op, expand_color_code) |
| 2121 | 33x |
if (dark) {
|
| 2122 | ! |
op$fg <- op$col <- op$col.axis <- op$col.main <- op$col.sub <- op$col.sub <- "white" |
| 2123 | ! |
if (is.null(op$bg) && par("bg") == "white") {
|
| 2124 | ! |
warning("foreground and background are both white")
|
| 2125 |
} |
|
| 2126 |
} |
|
| 2127 | 33x |
par(op) |
| 2128 | 33x |
on.exit(par(dop)) |
| 2129 | 33x |
layout( |
| 2130 | 33x |
seg$dmat, |
| 2131 | 33x |
c( |
| 2132 | 33x |
rep.int(seg$prat[1], seg$dim[2]), |
| 2133 | 33x |
if (ck$legcol) seg$prat[if (length(seg$prat) > 1) 2 else 1] |
| 2134 |
) |
|
| 2135 |
) |
|
| 2136 | 33x |
success <- FALSE |
| 2137 | 33x |
ck$scol <- "scols" %in% names(seg) |
| 2138 | 33x |
for (i in names(cdat)) {
|
| 2139 | 53x |
tryCatch( |
| 2140 |
{
|
|
| 2141 |
# plotting |
|
| 2142 | 53x |
cl <- (if ("list" %in% class(cdat[[i]])) {
|
| 2143 | 37x |
vapply(cdat[[i]], NROW, 0) |
| 2144 |
} else {
|
|
| 2145 | 16x |
nrow(cdat[[i]]) |
| 2146 |
}) > |
|
| 2147 | 53x |
0 |
| 2148 | 53x |
if (any(!cl)) {
|
| 2149 | ! |
cdat[[i]] <- cdat[[i]][cl] |
| 2150 | ! |
if (length(cdat[[i]]) == 0) next |
| 2151 |
} |
|
| 2152 | 53x |
if (ck$scol) {
|
| 2153 | 1x |
seg$cols <- seg$lcols <- seg$scols[[i]] |
| 2154 |
} |
|
| 2155 | 53x |
cl <- strsplit(i, ".^^.", fixed = TRUE)[[1]] |
| 2156 | 53x |
ptxt$sub <- if (is.character(sub)) {
|
| 2157 | ! |
sub |
| 2158 | 53x |
} else if (ck$sub) {
|
| 2159 | 52x |
if (seg$ll > 1 || (!missing(ndisp) && ndisp)) {
|
| 2160 | 30x |
paste0( |
| 2161 | 30x |
if (seg$f1$e) {
|
| 2162 | 30x |
paste0( |
| 2163 | 30x |
if (lvn || (ck$mlvn && grepl("^[0-9]", cl[1]))) {
|
| 2164 | 30x |
paste0(ptxt$bet[1], ": ") |
| 2165 |
}, |
|
| 2166 | 30x |
cl[1], |
| 2167 | 30x |
if (seg$f2$e) {
|
| 2168 | 20x |
paste0( |
| 2169 |
", ", |
|
| 2170 | 20x |
if (lvn || (ck$mlvn && grepl("^[0-9]", cl[2]))) {
|
| 2171 | 20x |
paste0(ptxt$bet[2], ": ") |
| 2172 |
}, |
|
| 2173 | 20x |
cl[2] |
| 2174 |
) |
|
| 2175 |
} |
|
| 2176 |
) |
|
| 2177 |
}, |
|
| 2178 | 30x |
if ((length(names(cdat)) > 1 || !missing(ndisp)) && ndisp) {
|
| 2179 | 30x |
paste(", n =", seg$n[i])
|
| 2180 |
} |
|
| 2181 |
) |
|
| 2182 |
} else {
|
|
| 2183 |
"" |
|
| 2184 |
} |
|
| 2185 |
} |
|
| 2186 | 53x |
if ( |
| 2187 | 53x |
!is.null(sort) && |
| 2188 | 53x |
ck$t != 2 && |
| 2189 | 53x |
any( |
| 2190 | 53x |
class( |
| 2191 | 53x |
if (seg$by$e) cdat[[i]][[1]][, "x"] else cdat[[i]][, "x"] |
| 2192 | 53x |
) %in% |
| 2193 | 53x |
c("factor", "character")
|
| 2194 |
) |
|
| 2195 |
) {
|
|
| 2196 | 1x |
nsl <- grepl("^[Ff]", as.character(sort))
|
| 2197 | 1x |
sdir <- grepl("^[DdTt]", as.character(sort))
|
| 2198 | 1x |
td <- if (seg$by$e) do.call(rbind, cdat[[i]]) else cdat[[i]] |
| 2199 | 1x |
td[, "x"] <- as.character(td[, "x"]) |
| 2200 | 1x |
cdat[[i]] <- do.call( |
| 2201 | 1x |
rbind, |
| 2202 | 1x |
lapply( |
| 2203 | 1x |
if (nsl) {
|
| 2204 | 1x |
lvs(td[, "x"]) |
| 2205 |
} else {
|
|
| 2206 | ! |
names(sort( |
| 2207 | ! |
vapply(split(td[, "y"], td[, "x"]), mean, 0, na.rm = TRUE), |
| 2208 | ! |
sdir |
| 2209 |
)) |
|
| 2210 |
}, |
|
| 2211 | 1x |
function(l) td[td[, "x"] == l, , drop = FALSE] |
| 2212 |
) |
|
| 2213 |
) |
|
| 2214 | 1x |
seg$x$l <- ptxt$l.x <- lvs(cdat[[i]][, "x"]) |
| 2215 | 1x |
cdat[[i]][, "x"] <- factor(cdat[[i]][, "x"], seg$x$l) |
| 2216 | ! |
if (seg$by$e) cdat[[i]] <- split(cdat[[i]], cdat[[i]][, "by"]) |
| 2217 |
} |
|
| 2218 | 53x |
if (ck$t == 1) {
|
| 2219 |
# bar and line |
|
| 2220 | 20x |
flipped <- FALSE |
| 2221 | 53x |
if ( |
| 2222 | 20x |
missing(byx) && |
| 2223 | 20x |
ck$mv && |
| 2224 | 20x |
any(vapply( |
| 2225 | 20x |
cdat[[i]], |
| 2226 | 20x |
function(d) {
|
| 2227 | ! |
any( |
| 2228 | ! |
vapply( |
| 2229 | ! |
split(d$y, as.character(d$x)), |
| 2230 | ! |
function(dl) if (length(dl) == 1) 0 else var(dl), |
| 2231 | ! |
0 |
| 2232 |
) == |
|
| 2233 | ! |
0 |
| 2234 |
) |
|
| 2235 |
}, |
|
| 2236 | 20x |
TRUE |
| 2237 |
)) |
|
| 2238 |
) {
|
|
| 2239 | ! |
byx <- FALSE |
| 2240 |
} |
|
| 2241 | 53x |
if ( |
| 2242 | 20x |
byx && |
| 2243 | 20x |
lim < Inf && |
| 2244 | 20x |
seg$by$e && |
| 2245 | 20x |
(is.list(cdat[[i]]) && length(cdat[[i]]) > 1) |
| 2246 |
) {
|
|
| 2247 | 14x |
flipped <- TRUE |
| 2248 | 14x |
cdat[[i]] <- do.call(rbind, cdat[[i]]) |
| 2249 | 14x |
cdat[[i]][c("x", "by")] <- cdat[[i]][c("by", "x")]
|
| 2250 | 14x |
if (is.numeric(cdat[[i]]$x)) {
|
| 2251 | ! |
cdat[[i]]$x <- as.character(cdat[[i]]$x) |
| 2252 |
} |
|
| 2253 | 14x |
cdat[[i]] <- split(cdat[[i]], cdat[[i]]$by)[lvs(cdat[[i]]$by)] |
| 2254 |
} |
|
| 2255 | 20x |
dl <- if (cl <- "list" %in% class(cdat[[1]])) length(cdat[[i]]) else 1 |
| 2256 | 20x |
mot <- paste0( |
| 2257 | 20x |
"y~0+", |
| 2258 | 20x |
paste( |
| 2259 | 20x |
names(if (cl) cdat[[i]][[1]] else cdat[[i]])[c(2, cvar)], |
| 2260 | 20x |
collapse = "+" |
| 2261 |
) |
|
| 2262 |
) |
|
| 2263 | 20x |
m <- pe <- ne <- matrix( |
| 2264 | 20x |
NA, |
| 2265 | 20x |
seg$by$ll, |
| 2266 | 20x |
max(c(1, length(seg$x$l))), |
| 2267 | 20x |
dimnames = list(seg$by$l, seg$x$l) |
| 2268 |
) |
|
| 2269 | 20x |
if (flipped) {
|
| 2270 | 14x |
m <- pe <- ne <- t(m) |
| 2271 |
} |
|
| 2272 | 20x |
rn <- if (nrow(m) == 1) 1 else rownames(m) |
| 2273 | 20x |
cn <- if (seg$by$e && flipped) seg$by$l else colnames(m) |
| 2274 | 20x |
for (l in seq_len(dl)) {
|
| 2275 | 34x |
ri <- rn[l] |
| 2276 | 34x |
td <- if (cl) cdat[[i]][[ri]] else cdat[[i]] |
| 2277 | 34x |
if (is.null(td)) {
|
| 2278 | ! |
next |
| 2279 |
} |
|
| 2280 | 34x |
if (nrow(td) > 1 && length(unique(td$x)) > 1) {
|
| 2281 | 34x |
mo <- lm(mot, data = td) |
| 2282 | 34x |
ccn <- sub("^x", "", names(mo$coef))
|
| 2283 | 34x |
sus <- which(ccn %in% cn) |
| 2284 | 34x |
su <- ccn[sus] |
| 2285 | 34x |
m[ri, su] <- mo$coef[sus] |
| 2286 | 34x |
if (nrow(td) > 2 && anyDuplicated(td$x)) {
|
| 2287 | 33x |
if (ck$e) {
|
| 2288 | 33x |
e <- suppressWarnings(summary(update(mo, ~ . - 0))$coef[ |
| 2289 | 33x |
sus, |
| 2290 | 33x |
2 |
| 2291 |
]) |
|
| 2292 | 33x |
e <- e[c(2, seq_along(e)[-1])] |
| 2293 | 33x |
pe[ri, su] <- m[l, su] + e |
| 2294 | 33x |
ne[ri, su] <- m[l, su] - e |
| 2295 |
} else {
|
|
| 2296 | ! |
e <- confint(mo)[sus, ] |
| 2297 | ! |
pe[ri, su] <- e[, 2] |
| 2298 | ! |
ne[ri, su] <- e[, 1] |
| 2299 |
} |
|
| 2300 |
} |
|
| 2301 |
} else {
|
|
| 2302 | ! |
if (nrow(td) == 0) {
|
| 2303 | ! |
next |
| 2304 |
} |
|
| 2305 | ! |
mo <- lapply( |
| 2306 | ! |
split(td, td["x"]), |
| 2307 | ! |
function(s) {
|
| 2308 | ! |
if (nrow(s) == 0) NA else mean(s[is.finite(s[, "y"]), "y"]) |
| 2309 |
} |
|
| 2310 |
) |
|
| 2311 | ! |
m[ri, ] <- unlist(mo[colnames(m)]) |
| 2312 |
} |
|
| 2313 |
} |
|
| 2314 | 20x |
re <- if (flipped) {
|
| 2315 | 14x |
list(m = t(m), ne = t(ne), pe = t(pe)) |
| 2316 |
} else {
|
|
| 2317 | 6x |
list(m = m, ne = ne, pe = pe) |
| 2318 |
} |
|
| 2319 | 20x |
if (ck$ltm && all(apply(is.na(re$m), 2, any))) {
|
| 2320 | ! |
drop["x"] <- FALSE |
| 2321 | ! |
line.type <- "b" |
| 2322 |
} |
|
| 2323 | 20x |
dx <- !apply(is.na(re$m), 2, all) |
| 2324 | 20x |
if (drop["x"]) {
|
| 2325 | 20x |
re <- lapply(re, function(s) s[, dx, drop = FALSE]) |
| 2326 |
} |
|
| 2327 | 20x |
m <- re$m |
| 2328 | 20x |
ne <- re$ne |
| 2329 | 20x |
pe <- re$pe |
| 2330 | 20x |
if (all(mna <- is.na(m))) {
|
| 2331 | ! |
next |
| 2332 |
} |
|
| 2333 | 20x |
re <- lapply(re, function(s) {
|
| 2334 | 60x |
na <- is.na(s) |
| 2335 | 60x |
s[na] <- m[na] |
| 2336 | 60x |
s[!mna] |
| 2337 |
}) |
|
| 2338 | 20x |
if (ck$el) {
|
| 2339 | 19x |
ck$el <- all(round(re$m - re$ne, 8) != 0) |
| 2340 |
} |
|
| 2341 | 20x |
lb <- min(re$m) - |
| 2342 | 20x |
if (!ck$el) {
|
| 2343 | 2x |
round((max(re$m) - min(re$m)) / 10) |
| 2344 |
} else {
|
|
| 2345 | 18x |
max(abs(re$m - re$ne)) * 1.2 |
| 2346 |
} |
|
| 2347 | 20x |
if (ck$b && !ck$el) {
|
| 2348 | 2x |
lb <- lb - (max(re$m) - min(re$m)) * .1 |
| 2349 |
} |
|
| 2350 | 20x |
dm <- dim(m) |
| 2351 | 20x |
ylim <- if (missing(myl)) {
|
| 2352 | 20x |
c(lb, max(re$m) + if (ck$el) max(abs(re$m - re$pe)) else 0) |
| 2353 |
} else {
|
|
| 2354 | ! |
myl |
| 2355 |
} |
|
| 2356 | 20x |
if (ck$leg == 2 && ck$lp) {
|
| 2357 | 3x |
if (!seg$by$e && ncol(m) == 2) {
|
| 2358 | 1x |
lega$x <- "top" |
| 2359 |
} else {
|
|
| 2360 | 2x |
lega$x <- apply(m, 2, function(r) {
|
| 2361 | 4x |
na <- !is.na(r) |
| 2362 | ! |
if (any(na)) max(r[na]) else -Inf |
| 2363 |
}) |
|
| 2364 | 2x |
stw <- ncol(m) |
| 2365 | 2x |
oyl <- if (stw %% 2) 3 else 2 |
| 2366 | 2x |
lega$x <- c("topleft", "top", "topright")[
|
| 2367 | 2x |
if (oyl == 2) -2 else 1:3 |
| 2368 | 2x |
][which.min(vapply( |
| 2369 | 2x |
split( |
| 2370 | 2x |
lega$x, |
| 2371 | 2x |
rep(seq_len(oyl), each = stw / oyl)[seq_len(stw)] |
| 2372 |
), |
|
| 2373 | 2x |
mean, |
| 2374 | 2x |
0, |
| 2375 | 2x |
na.rm = TRUE |
| 2376 |
))] |
|
| 2377 | ! |
if (is.na(lega$x)) lega$x <- "topright" |
| 2378 |
} |
|
| 2379 |
} |
|
| 2380 | 20x |
if (any(is.na(ylim))) {
|
| 2381 | ! |
next |
| 2382 |
} |
|
| 2383 | 20x |
oyl <- axTicks(2, c(ylim[1], ylim[2], par("yaxp")[3]))
|
| 2384 | 20x |
rn <- if (nrow(m) == 1) colnames(m) else rownames(m) |
| 2385 | 20x |
colnames(m) <- if (drop["x"] && sum(dx) == ncol(m)) {
|
| 2386 | 20x |
ptxt$l.x[dx] |
| 2387 |
} else {
|
|
| 2388 | ! |
ptxt$l.x |
| 2389 |
} |
|
| 2390 | 20x |
stw <- strwidth(colnames(m), "i") |
| 2391 | 53x |
if ( |
| 2392 | 20x |
(missing(xlas) || xlas > 1) && |
| 2393 | 20x |
sum(stw) > |
| 2394 | 20x |
par("fin")[1] - sum(par("omi")[c(2, 4)]) - dm[2] * .1 &&
|
| 2395 | 20x |
par("fin")[1] > 2.5
|
| 2396 |
) {
|
|
| 2397 | ! |
xlas <- 3 |
| 2398 | ! |
if (missing(mxl)) {
|
| 2399 | ! |
mxl <- c(1, dm[2]) |
| 2400 |
} |
|
| 2401 | ! |
mh <- c(par("fin")[2] / 2, max(stw))
|
| 2402 | ! |
par(mai = if (ck$mai) op$mai else c(min(mh) + .25, par("mai")[-1]))
|
| 2403 | ! |
if (mh[1] < mh[2] && missing(labels.trim)) {
|
| 2404 | ! |
mh <- round(mh[1] / .1) |
| 2405 | ! |
n <- colnames(m) |
| 2406 | ! |
ln <- nchar(n) > mh |
| 2407 | ! |
colnames(m)[ln] <- sub("$", "...", strtrim(n[ln], mh))
|
| 2408 |
} |
|
| 2409 |
} |
|
| 2410 | 20x |
if (min(re$ne, na.rm = TRUE) >= 0) {
|
| 2411 | 2x |
autori <- FALSE |
| 2412 |
} |
|
| 2413 | 20x |
rck <- !is.list(seg$cols) && all(rn %in% names(seg$cols)) |
| 2414 | 20x |
if (rck && length(seg$cols) < dm[1]) {
|
| 2415 | ! |
seg$cols <- rep_len(seg$cols, dm[1]) |
| 2416 |
} |
|
| 2417 | 20x |
if (!rck && ck$ltm && !ck$el) {
|
| 2418 | 1x |
line.type <- "b" |
| 2419 |
} |
|
| 2420 | 20x |
if (ck$b) {
|
| 2421 | 7x |
if (autori) {
|
| 2422 | 5x |
a <- if (missing(myl)) lb else myl[1] |
| 2423 | 5x |
a <- a * -1 |
| 2424 | 5x |
m <- m + a |
| 2425 | 5x |
ne <- ne + a |
| 2426 | 5x |
pe <- pe + a |
| 2427 | 5x |
ayl <- oyl + a |
| 2428 | 5x |
aj <- lapply(re, "+", a) |
| 2429 | 5x |
ylim <- if (missing(myl)) {
|
| 2430 | 5x |
if (!ck$el) {
|
| 2431 | ! |
ylim + a |
| 2432 |
} else {
|
|
| 2433 | 5x |
c( |
| 2434 | 5x |
min(aj$m) - max(abs(aj$m - aj$ne)) * 1.2, |
| 2435 | 5x |
max(aj$m) + |
| 2436 | 5x |
max(abs(aj$m - aj$pe)) * |
| 2437 | 5x |
if (ck$leg == 2 && seg$by$ll > 1) {
|
| 2438 | ! |
seg$by$ll^.3 + .7 |
| 2439 |
} else {
|
|
| 2440 | 5x |
1.2 |
| 2441 |
} |
|
| 2442 |
) |
|
| 2443 |
} |
|
| 2444 |
} else {
|
|
| 2445 | ! |
myl + a |
| 2446 |
} |
|
| 2447 |
} |
|
| 2448 | 7x |
if (dm[1] != 1) {
|
| 2449 | 4x |
rownames(m) <- ptxt$l.by[rn] |
| 2450 |
} |
|
| 2451 | 7x |
lega[c("lwd", "lty")] <- NULL
|
| 2452 | 7x |
lega[c("pch", "pt.cex", "x.intersp", "y.intersp", "adj")] <- list(
|
| 2453 | 7x |
15, |
| 2454 | 7x |
2, |
| 2455 | 7x |
1, |
| 2456 | 7x |
1.2, |
| 2457 | 7x |
c(0, .35) |
| 2458 |
) |
|
| 2459 | 7x |
p <- barplot( |
| 2460 | 7x |
m, |
| 2461 | 7x |
beside = TRUE, |
| 2462 | 7x |
col = if (rck) seg$cols[rn] else seg$cols, |
| 2463 | 7x |
axes = FALSE, |
| 2464 | 7x |
axisnames = FALSE, |
| 2465 | 7x |
border = NA, |
| 2466 | 7x |
ylab = NA, |
| 2467 | 7x |
xlab = NA, |
| 2468 | 7x |
ylim = ylim, |
| 2469 | 7x |
main = if (ck$sub) ptxt$sub else NA, |
| 2470 | 7x |
xpd = if ("xpd" %in% names(pdo)) {
|
| 2471 | ! |
pdo$xpd |
| 2472 | 7x |
} else if (autori) {
|
| 2473 | 7x |
NA |
| 2474 |
} else {
|
|
| 2475 | 2x |
FALSE |
| 2476 |
} |
|
| 2477 |
) |
|
| 2478 |
} else {
|
|
| 2479 | 13x |
p <- matrix( |
| 2480 | 13x |
rep.int(seq_len(dm[2]), dm[1]), |
| 2481 | 13x |
nrow = dm[1], |
| 2482 | 13x |
byrow = TRUE |
| 2483 |
) |
|
| 2484 | 13x |
plot( |
| 2485 | 13x |
NA, |
| 2486 | 13x |
ylim = ylim, |
| 2487 | 13x |
xlim = if (missing(mxl)) {
|
| 2488 | 13x |
c(1 - stw[1] / 3, dm[2] + stw[length(stw)] / 3) |
| 2489 |
} else {
|
|
| 2490 | ! |
mxl |
| 2491 |
}, |
|
| 2492 | 13x |
ylab = NA, |
| 2493 | 13x |
xlab = NA, |
| 2494 | 13x |
main = if (ck$sub) ptxt$sub else NA, |
| 2495 | 13x |
axes = FALSE |
| 2496 |
) |
|
| 2497 | 13x |
for (a in if (dm[1] == 1) {
|
| 2498 | 3x |
1 |
| 2499 | 13x |
} else if (all(rn %in% names(seg$cols))) {
|
| 2500 | 10x |
rn |
| 2501 |
} else {
|
|
| 2502 | ! |
seq_len(dm[1]) |
| 2503 |
}) {
|
|
| 2504 | 23x |
graphics::lines( |
| 2505 | 23x |
m[a, ], |
| 2506 | 23x |
col = seg$cols[[a]], |
| 2507 | 23x |
lty = seg$lty[[a]], |
| 2508 | 23x |
lwd = seg$lwd[[a]], |
| 2509 | 23x |
type = line.type |
| 2510 |
) |
|
| 2511 |
} |
|
| 2512 |
} |
|
| 2513 | 20x |
if (ck$ileg) {
|
| 2514 | ! |
lega$legend <- rn |
| 2515 |
} |
|
| 2516 | 20x |
if (xaxis) {
|
| 2517 | 20x |
axis( |
| 2518 | 20x |
1, |
| 2519 | 20x |
colMeans(p), |
| 2520 | 20x |
colnames(m), |
| 2521 | 20x |
FALSE, |
| 2522 | 20x |
las = xlas, |
| 2523 | 20x |
cex = par("cex.axis"),
|
| 2524 | 20x |
fg = par("col.axis")
|
| 2525 |
) |
|
| 2526 |
} |
|
| 2527 | 20x |
a2a <- list( |
| 2528 | 20x |
2, |
| 2529 | 20x |
las = ylas, |
| 2530 | 20x |
cex = par("cex.axis"),
|
| 2531 | 20x |
fg = par("col.axis")
|
| 2532 |
) |
|
| 2533 | 20x |
if (ck$b && autori) {
|
| 2534 | 5x |
a2a$at <- ayl |
| 2535 | 5x |
a2a$labels <- formatC(oyl, 2, format = "f") |
| 2536 |
} |
|
| 2537 | 20x |
if (yaxis) {
|
| 2538 | 20x |
do.call(axis, a2a) |
| 2539 |
} |
|
| 2540 | 20x |
if (ck$el) {
|
| 2541 | 18x |
te <- round(Reduce("-", list(ne, pe)), 8)
|
| 2542 | 18x |
te[is.na(te)] <- 0 |
| 2543 | 18x |
te <- te == 0 |
| 2544 | 18x |
if (any(te)) {
|
| 2545 | ! |
ne[te] <- pe[te] <- NA |
| 2546 |
} |
|
| 2547 | 18x |
arrows( |
| 2548 | 18x |
p, |
| 2549 | 18x |
ne, |
| 2550 | 18x |
p, |
| 2551 | 18x |
pe, |
| 2552 | 18x |
lwd = error.lwd, |
| 2553 | 18x |
col = error.color, |
| 2554 | 18x |
angle = 90, |
| 2555 | 18x |
code = 3, |
| 2556 | 18x |
length = .05 |
| 2557 |
) |
|
| 2558 |
} |
|
| 2559 | 33x |
} else if (ck$t == 2) {
|
| 2560 |
# density |
|
| 2561 | 14x |
if (!is.list(density.args)) {
|
| 2562 | ! |
density.args <- list() |
| 2563 |
} |
|
| 2564 | 14x |
fdan <- names(formals(stats::density.default)) |
| 2565 | 14x |
dan <- names(density.args) |
| 2566 | 14x |
if (any(mdan <- !dan %in% fdan)) {
|
| 2567 | ! |
warning( |
| 2568 | ! |
paste( |
| 2569 | ! |
"unused density argument(s):", |
| 2570 | ! |
paste(dan[mdan], collapse = ", ") |
| 2571 |
), |
|
| 2572 | ! |
call. = FALSE |
| 2573 |
) |
|
| 2574 | ! |
density.args <- density.args[!mdan] |
| 2575 |
} |
|
| 2576 | 14x |
density.args$give.Rkern <- FALSE |
| 2577 | 14x |
if (!missing(mxl)) {
|
| 2578 | ! |
if (!"from" %in% dan) {
|
| 2579 | ! |
density.args$from <- mxl[1] |
| 2580 |
} |
|
| 2581 | ! |
if (!"to" %in% dan) density.args$to <- mxl[2] |
| 2582 |
} |
|
| 2583 | 14x |
if (!"n" %in% dan) {
|
| 2584 | 10x |
density.args$n <- 512 |
| 2585 |
} |
|
| 2586 | 14x |
n <- density.args$n |
| 2587 | 14x |
m <- list() |
| 2588 | 14x |
dl <- if (cl <- "list" %in% class(cdat[[i]])) length(cdat[[i]]) else 1 |
| 2589 | 14x |
rnl <- logical(dl) |
| 2590 | 14x |
rn <- if (is.data.frame(cdat[[i]])) {
|
| 2591 | 6x |
names(ptxt$l.by) |
| 2592 |
} else {
|
|
| 2593 | 8x |
names(cdat[[i]]) |
| 2594 |
} |
|
| 2595 | 14x |
dx <- dy <- numeric(n * seg$by$ll) |
| 2596 | 14x |
for (l in seq_len(dl)) {
|
| 2597 | 22x |
tryCatch( |
| 2598 |
{
|
|
| 2599 | 22x |
density.args$x <- (if (cl) cdat[[i]][[l]] else cdat[[i]])[, "y"] |
| 2600 | 22x |
m[[l]] <- do.call(stats::density, density.args) |
| 2601 | 22x |
dx[seq_len(n) + n * (l - 1)] <- m[[l]]$x |
| 2602 | 22x |
dy[seq_len(n) + n * (l - 1)] <- m[[l]]$y |
| 2603 | 22x |
rnl[l] <- TRUE |
| 2604 |
}, |
|
| 2605 | 22x |
error = function(e) NULL |
| 2606 |
) |
|
| 2607 |
} |
|
| 2608 | 14x |
names(m) <- rn <- rn[rnl] |
| 2609 | 14x |
if (seg$by$ll > 1 || (ck$polyo && ck$poly)) {
|
| 2610 | 8x |
plot( |
| 2611 | 8x |
NA, |
| 2612 | 8x |
xlim = if (missing(mxl)) range(c(dx, dx)) else mxl, |
| 2613 | 8x |
ylim = if (missing(myl)) c(0, max(dy)) else myl, |
| 2614 | 8x |
main = if (ck$sub) ptxt$sub else NA, |
| 2615 | 8x |
ylab = NA, |
| 2616 | 8x |
xlab = NA, |
| 2617 | 8x |
axes = FALSE, |
| 2618 | 8x |
xpd = if ("xpd" %in% names(pdo)) pdo$xpd else FALSE
|
| 2619 |
) |
|
| 2620 | 8x |
for (l in if (seg$by$ll > 1 && all(rn %in% names(seg$cols))) {
|
| 2621 | 8x |
rn |
| 2622 |
} else {
|
|
| 2623 | ! |
seq_along(m) |
| 2624 |
}) {
|
|
| 2625 | 16x |
if (ck$poly) {
|
| 2626 | 16x |
polygon( |
| 2627 | 16x |
m[[l]], |
| 2628 | 16x |
col = adjustcolor(seg$cols[[l]], density.opacity), |
| 2629 | 16x |
border = NA |
| 2630 |
) |
|
| 2631 |
} |
|
| 2632 | 16x |
if (!is.logical(lines) || lines) {
|
| 2633 | 16x |
graphics::lines( |
| 2634 | 16x |
m[[l]], |
| 2635 | 16x |
col = seg$cols[[l]], |
| 2636 | 16x |
lwd = seg$lwd[[l]], |
| 2637 | 16x |
lty = seg$lty[[l]] |
| 2638 |
) |
|
| 2639 |
} |
|
| 2640 |
} |
|
| 2641 | ! |
if (ck$ileg) lega$legend <- rn |
| 2642 |
} else {
|
|
| 2643 | 6x |
col <- if (length(seg$lcols) > 2) "#555555" else seg$lcols[1] |
| 2644 | 6x |
if (ck$leg) {
|
| 2645 | ! |
lega[c("lwd", "lty")] <- NULL
|
| 2646 | ! |
lega[c("pch", "pt.cex", "x.intersp", "y.intersp", "adj")] <- list(
|
| 2647 | ! |
15, |
| 2648 | ! |
2, |
| 2649 | ! |
1, |
| 2650 | ! |
1.2, |
| 2651 | ! |
c(0, .35) |
| 2652 |
) |
|
| 2653 |
} |
|
| 2654 | 6x |
y <- (if (cl) cdat[[i]][[1]] else cdat[[i]])[, "y"] |
| 2655 | 6x |
hp <- hist(y, breaks, plot = FALSE) |
| 2656 | 6x |
if (ck$cb && length(seg$cols) == nr) {
|
| 2657 | ! |
nb <- length(hp$counts) |
| 2658 | ! |
seg$cols <- vapply( |
| 2659 | ! |
split(seg$cols[order(y)], sort(rep_len(seq_len(nb), nr))), |
| 2660 | ! |
csf, |
| 2661 |
"" |
|
| 2662 |
) |
|
| 2663 | ! |
if (!ckn) {
|
| 2664 | ! |
seg$cols <- adjustcolor( |
| 2665 | ! |
seg$cols, |
| 2666 | ! |
1, |
| 2667 | ! |
color.offset, |
| 2668 | ! |
color.offset, |
| 2669 | ! |
color.offset |
| 2670 |
) |
|
| 2671 |
} |
|
| 2672 | 6x |
} else if (!color.lock && (ck$co || length(seg$cols) == 1)) {
|
| 2673 | 6x |
seg$cols[2] <- adjustcolor( |
| 2674 | 6x |
seg$cols[1], |
| 2675 | 6x |
1, |
| 2676 | 6x |
color.offset, |
| 2677 | 6x |
color.offset, |
| 2678 | 6x |
color.offset |
| 2679 |
) |
|
| 2680 |
} |
|
| 2681 | 6x |
hist( |
| 2682 | 6x |
y, |
| 2683 | 6x |
breaks, |
| 2684 | 6x |
FALSE, |
| 2685 | 6x |
border = if ("border" %in% names(pdo)) pdo$border else par("bg"),
|
| 2686 | 6x |
main = if (ck$sub) ptxt$sub else NA, |
| 2687 | 6x |
ylab = NA, |
| 2688 | 6x |
xlab = NA, |
| 2689 | 6x |
axes = FALSE, |
| 2690 | 6x |
col = if (length(seg$cols) == 2) seg$cols[2] else seg$cols, |
| 2691 | 6x |
xlim = if (missing(mxl)) range(hp$breaks) else mxl, |
| 2692 | 6x |
ylim = if (missing(myl)) c(0, max(c(dy, hp$density))) else myl |
| 2693 |
) |
|
| 2694 | 6x |
if (!is.logical(lines) || lines) {
|
| 2695 | 6x |
graphics::lines( |
| 2696 | 6x |
m[[1]], |
| 2697 | 6x |
col = col, |
| 2698 | 6x |
lwd = lwd, |
| 2699 | 6x |
xpd = if ("xpd" %in% names(pdo)) {
|
| 2700 | ! |
pdo$xpd |
| 2701 |
} else {
|
|
| 2702 | 6x |
FALSE |
| 2703 |
} |
|
| 2704 |
) |
|
| 2705 |
} |
|
| 2706 |
} |
|
| 2707 | 14x |
if (ck$lp && ck$leg == 2) {
|
| 2708 | 2x |
lega$x <- if (mean(dx) > mean(range(dx))) "topleft" else "topright" |
| 2709 |
} |
|
| 2710 | 14x |
if (xaxis) {
|
| 2711 | 14x |
axis(1, las = xlas, cex = par("cex.axis"), fg = par("col.axis"))
|
| 2712 |
} |
|
| 2713 | 14x |
if (yaxis) {
|
| 2714 | 14x |
axis(2, las = ylas, cex = par("cex.axis"), fg = par("col.axis"))
|
| 2715 |
} |
|
| 2716 |
} else {
|
|
| 2717 |
# scatter |
|
| 2718 | 19x |
dl <- if (cl <- "list" %in% class(cdat[[i]])) length(cdat[[i]]) else 1 |
| 2719 | 19x |
rn <- if (is.data.frame(cdat[[i]])) seg$by$l else names(cdat[[i]]) |
| 2720 | 19x |
td <- if (cl) do.call(rbind, cdat[[i]]) else cdat[[i]] |
| 2721 | 19x |
cx <- td[, "x"] |
| 2722 | 19x |
cy <- td[, "y"] |
| 2723 | 19x |
xch <- if (is.numeric(cx) || is.logical(cx)) {
|
| 2724 | 19x |
cx |
| 2725 |
} else {
|
|
| 2726 | ! |
as.numeric(factor(cx)) |
| 2727 |
} |
|
| 2728 | 19x |
a2a <- list(cex = par("cex.axis"), fg = par("col.axis"))
|
| 2729 | 19x |
if (length(ptxt$l.x) != 0) {
|
| 2730 | ! |
a2a$tick <- FALSE |
| 2731 | ! |
a2a$at <- seq_along(ptxt$l.x) |
| 2732 | ! |
a2a$labels <- ptxt$l.x |
| 2733 | ! |
if (missing(xlas) || xlas > 1) {
|
| 2734 | ! |
xlas <- 3 |
| 2735 | ! |
par( |
| 2736 | ! |
mai = if (ck$mai) {
|
| 2737 | ! |
op$mai |
| 2738 |
} else {
|
|
| 2739 | ! |
c( |
| 2740 | ! |
min(c(par("fin")[2] / 2, max(strwidth(ptxt$l.x, "i")))) +
|
| 2741 | ! |
.25, |
| 2742 | ! |
par("mai")[-1]
|
| 2743 |
) |
|
| 2744 |
} |
|
| 2745 |
) |
|
| 2746 |
} |
|
| 2747 |
} |
|
| 2748 | 19x |
plot( |
| 2749 | 19x |
NA, |
| 2750 | 19x |
xlim = if (missing(mxl)) range(xch, na.rm = TRUE) else mxl, |
| 2751 | 19x |
ylim = if (missing(myl)) {
|
| 2752 | 19x |
c( |
| 2753 | 19x |
min(cy, na.rm = TRUE), |
| 2754 | 19x |
max(cy, na.rm = TRUE) + |
| 2755 | 19x |
max(cy, na.rm = TRUE) * |
| 2756 | 19x |
if (ck$leg == 1 && seg$by$ll < lim) seg$by$ll / 20 else 0 |
| 2757 |
) |
|
| 2758 |
} else {
|
|
| 2759 | ! |
myl |
| 2760 |
}, |
|
| 2761 | 19x |
main = if (ck$sub) ptxt$sub else NA, |
| 2762 | 19x |
ylab = NA, |
| 2763 | 19x |
xlab = NA, |
| 2764 | 19x |
axes = FALSE |
| 2765 |
) |
|
| 2766 | 19x |
if (yaxis) {
|
| 2767 | 19x |
do.call( |
| 2768 | 19x |
axis, |
| 2769 | 19x |
c( |
| 2770 | 19x |
list(2, las = ylas), |
| 2771 | 19x |
c( |
| 2772 | 19x |
a2a[c("cex", "fg")],
|
| 2773 | 19x |
if ("yax" %in% names(txt)) {
|
| 2774 | ! |
list( |
| 2775 | ! |
at = seq_along(txt$yax), |
| 2776 | ! |
labels = txt$yax, |
| 2777 | ! |
tick = FALSE |
| 2778 |
) |
|
| 2779 |
} |
|
| 2780 |
) |
|
| 2781 |
) |
|
| 2782 |
) |
|
| 2783 |
} |
|
| 2784 | 19x |
if (xaxis) {
|
| 2785 | 19x |
do.call(axis, c(list(1, las = xlas), a2a)) |
| 2786 |
} |
|
| 2787 | 19x |
if (ck$leg > 1) {
|
| 2788 | 5x |
up <- xch[cy >= quantile(cy, na.rm = TRUE)[4]] |
| 2789 | 5x |
mr <- quantile(xch, na.rm = TRUE) |
| 2790 | 5x |
if (ck$lp) {
|
| 2791 | 5x |
lega$x <- if (sum(up < mr[2]) > sum(up > mr[4])) {
|
| 2792 | ! |
"topright" |
| 2793 |
} else {
|
|
| 2794 | 5x |
"topleft" |
| 2795 |
} |
|
| 2796 |
} |
|
| 2797 | ! |
if (ck$ileg) lega$legend <- rn |
| 2798 |
} |
|
| 2799 | 19x |
padj <- if ( |
| 2800 | 19x |
color.lock || ck$cb || (missing(color.offset) && !ck$ltck) |
| 2801 |
) {
|
|
| 2802 | 2x |
1 |
| 2803 |
} else {
|
|
| 2804 | 17x |
color.offset |
| 2805 |
} |
|
| 2806 | 19x |
ckcn <- all(rn %in% names(seg$cols)) |
| 2807 | 19x |
ckln <- all(rn %in% names(seg$lcols)) |
| 2808 | 19x |
if (!ckln) {
|
| 2809 | 4x |
if (ckcn) {
|
| 2810 | ! |
seg$lcols <- seg$cols |
| 2811 |
} else {
|
|
| 2812 | 4x |
seg$lcols[] <- if (opacity != 1) {
|
| 2813 | ! |
adjustcolor("#555555", opacity)
|
| 2814 |
} else {
|
|
| 2815 | 4x |
"#555555" |
| 2816 |
} |
|
| 2817 |
} |
|
| 2818 |
} |
|
| 2819 | 19x |
lwd <- rep_len(if (is.numeric(lwd)) lwd else 2, dl) |
| 2820 | 19x |
for (l in if (ckcn) rn else seq_len(dl)) {
|
| 2821 | 34x |
td <- if (cl) cdat[[i]][[l]] else cdat[[i]] |
| 2822 | 34x |
if (is.null(td)) {
|
| 2823 | ! |
next |
| 2824 |
} |
|
| 2825 | 34x |
x <- td[, "x"] |
| 2826 | 34x |
y <- td[, "y"] |
| 2827 | 34x |
col <- if (ckcn) seg$cols[[l]] else seg$cols |
| 2828 | 34x |
if (opacity != 1 || padj != 1) {
|
| 2829 | 32x |
col <- adjustcolor(col, opacity, padj, padj, padj) |
| 2830 |
} |
|
| 2831 | 34x |
if (points && points.first) {
|
| 2832 | 34x |
points(x, y, col = col, cex = cex["points"]) |
| 2833 |
} |
|
| 2834 | 34x |
if (ck$ltck) {
|
| 2835 | 34x |
lt <- if (ck$ltco == "pr" && length(unique(y)) != 2) {
|
| 2836 | ! |
"li" |
| 2837 |
} else {
|
|
| 2838 | 34x |
ck$ltco |
| 2839 |
} |
|
| 2840 | 34x |
fit <- if (lt == "e") {
|
| 2841 | ! |
y |
| 2842 |
} else {
|
|
| 2843 | 34x |
tryCatch( |
| 2844 |
{
|
|
| 2845 | 34x |
if (ck$c) {
|
| 2846 | ! |
lm(y ~ x + as.matrix(td[, cvar, drop = FALSE]))$fitted |
| 2847 | 34x |
} else if (lt == "pr") {
|
| 2848 | ! |
yr <- range(y) |
| 2849 | ! |
y <- factor(y, labels = c(0, 1)) |
| 2850 | ! |
fit <- predict(glm(y ~ x, binomial)) |
| 2851 | ! |
fit <- exp(fit) / (1 + exp(fit)) |
| 2852 | ! |
if (!all(yr == c(0, 1))) {
|
| 2853 | ! |
fit <- (fit - mean(fit)) * (yr[2] - yr[1]) + mean(yr) |
| 2854 |
} |
|
| 2855 | ! |
if (max(fit) > yr[2]) fit - (max(fit) - yr[2]) else fit |
| 2856 |
} else {
|
|
| 2857 | 34x |
predict(switch( |
| 2858 | 34x |
lt, |
| 2859 | 34x |
li = lm, |
| 2860 | 34x |
lo = loess, |
| 2861 | 34x |
sm = smooth.spline |
| 2862 | 34x |
)(y ~ x)) |
| 2863 |
} |
|
| 2864 |
}, |
|
| 2865 | 34x |
error = function(e) {
|
| 2866 | ! |
warning("error estimating line: ", e$message, call. = FALSE)
|
| 2867 | ! |
NULL |
| 2868 |
} |
|
| 2869 |
) |
|
| 2870 |
} |
|
| 2871 | 34x |
if (!is.null(fit)) {
|
| 2872 | 34x |
if (lt == "e") {
|
| 2873 | ! |
xo <- x |
| 2874 | 34x |
} else if (lt == "sm") {
|
| 2875 | ! |
xo <- fit$x |
| 2876 | ! |
fit <- fit$y |
| 2877 |
} else {
|
|
| 2878 | 34x |
or <- order(x) |
| 2879 | 34x |
xo <- x[or] |
| 2880 | 34x |
fit <- fit[or] |
| 2881 |
} |
|
| 2882 | 34x |
graphics::lines( |
| 2883 | 34x |
xo, |
| 2884 | 34x |
fit, |
| 2885 | 34x |
col = seg$lcols[[l]], |
| 2886 | 34x |
lty = seg$lty[[l]], |
| 2887 | 34x |
lwd = seg$lwd[[l]] |
| 2888 |
) |
|
| 2889 |
} |
|
| 2890 |
} |
|
| 2891 | 34x |
if (points && !points.first) {
|
| 2892 | ! |
points(x, y, col = col, cex = cex["points"]) |
| 2893 |
} |
|
| 2894 |
} |
|
| 2895 |
} |
|
| 2896 | 53x |
if (ck$leg == 2) {
|
| 2897 | 10x |
if (ck$lpm) {
|
| 2898 | ! |
message("click to place the legend")
|
| 2899 | ! |
lega[c("x", "y")] <- locator(1)
|
| 2900 | ! |
if (is.null(lega$x)) {
|
| 2901 | ! |
warning("placing the legend with locator(1) failed")
|
| 2902 | ! |
lega$y <- NULL |
| 2903 | ! |
lega$x <- if (seg$ll > 1) "topright" else "right" |
| 2904 |
} |
|
| 2905 |
} |
|
| 2906 | 10x |
tf <- par("font")
|
| 2907 | 10x |
par(font = font["leg.title"]) |
| 2908 | 10x |
do.call(legend, lega) |
| 2909 | 10x |
par(font = tf) |
| 2910 |
} |
|
| 2911 | 53x |
success <- TRUE |
| 2912 | 53x |
if (!missing(add)) {
|
| 2913 | 1x |
add_attempt <- tryCatch( |
| 2914 | 1x |
eval(substitute(add), fdat), |
| 2915 | 1x |
error = function(e) list(failed = TRUE) |
| 2916 |
) |
|
| 2917 | 1x |
if (is.list(add_attempt) && isTRUE(add_attempt$failed)) {
|
| 2918 | ! |
tryCatch( |
| 2919 | ! |
eval(substitute(add), parent.frame(1)), |
| 2920 | ! |
error = function(e) {
|
| 2921 | ! |
warning("error from add: ", e$message, call. = FALSE)
|
| 2922 |
} |
|
| 2923 |
) |
|
| 2924 |
} |
|
| 2925 |
} |
|
| 2926 |
}, |
|
| 2927 | 53x |
error = function(e) {
|
| 2928 | ! |
dev.off() |
| 2929 | ! |
stop(e) |
| 2930 |
} |
|
| 2931 |
) |
|
| 2932 |
} |
|
| 2933 | 33x |
if (!success) {
|
| 2934 | ! |
stop("failed to make any plots with the current input", call. = FALSE)
|
| 2935 |
} |
|
| 2936 | 33x |
if (ck$leg == 1) {
|
| 2937 | 10x |
if (all(par("mfg")[1:2] != 0)) {
|
| 2938 | 10x |
plot.new() |
| 2939 | 10x |
if (ck$b) {
|
| 2940 | 1x |
lega[c("pch", "pt.cex", "x.intersp", "y.intersp", "adj")] <- list(
|
| 2941 | 1x |
15, |
| 2942 | 1x |
2, |
| 2943 | 1x |
1, |
| 2944 | 1x |
1.2, |
| 2945 | 1x |
c(0, .35) |
| 2946 |
) |
|
| 2947 |
} |
|
| 2948 | 10x |
if (ck$lpm) {
|
| 2949 | ! |
message("click to place the legend")
|
| 2950 | ! |
lega[c("x", "y")] <- locator(1)
|
| 2951 | ! |
if (is.null(lega$x)) {
|
| 2952 | ! |
warning("placing the legend with locator(1) failed")
|
| 2953 | ! |
lega$y <- NULL |
| 2954 | ! |
lega$x <- if (seg$ll > 1) "topright" else "right" |
| 2955 |
} |
|
| 2956 |
} |
|
| 2957 | 10x |
tf <- par("font")
|
| 2958 | 10x |
par(font = font["leg.title"]) |
| 2959 | 10x |
do.call(legend, lega) |
| 2960 | 10x |
par(font = tf) |
| 2961 |
} else {
|
|
| 2962 | ! |
warning("legend positioning failed", call. = FALSE)
|
| 2963 |
} |
|
| 2964 |
} |
|
| 2965 | 33x |
if (ck$sud && any(ck$su, ck$c, is.character(sud))) {
|
| 2966 | ! |
mtext( |
| 2967 | ! |
if (is.character(sud)) {
|
| 2968 | ! |
sud |
| 2969 |
} else {
|
|
| 2970 | ! |
gsub( |
| 2971 | ! |
", (?=[A-z0-9 ]+$)", |
| 2972 | ! |
ifelse(length(ptxt$cov) > 2, ", & ", " & "), |
| 2973 | ! |
gsub( |
| 2974 |
"^ | $", |
|
| 2975 |
"", |
|
| 2976 | ! |
paste0( |
| 2977 | ! |
if (ck$su) {
|
| 2978 | ! |
paste( |
| 2979 | ! |
"Subset:", |
| 2980 | ! |
paste0(txt$su[1], if (length(txt$su) != 1) "...") |
| 2981 |
) |
|
| 2982 |
}, |
|
| 2983 | ! |
if (ck$su && ck$c) ", ", |
| 2984 | ! |
if (ck$c) {
|
| 2985 | ! |
paste( |
| 2986 | ! |
if (ck$t == 1) "Covariates:" else "Line adjustment:", |
| 2987 | ! |
paste(ptxt$cov, collapse = ", ") |
| 2988 |
) |
|
| 2989 |
} |
|
| 2990 |
) |
|
| 2991 |
), |
|
| 2992 | ! |
TRUE, |
| 2993 | ! |
TRUE |
| 2994 |
) |
|
| 2995 |
}, |
|
| 2996 | ! |
3, |
| 2997 | ! |
0, |
| 2998 | ! |
TRUE, |
| 2999 | ! |
cex = cex["sud"], |
| 3000 | ! |
font = font["sud"] |
| 3001 |
) |
|
| 3002 |
} |
|
| 3003 | 33x |
mtext( |
| 3004 | 33x |
main, |
| 3005 | 33x |
3, |
| 3006 | 33x |
if (ck$sud) 1.5 else .5, |
| 3007 | 33x |
TRUE, |
| 3008 | 33x |
cex = cex["title"], |
| 3009 | 33x |
font = font["title"] |
| 3010 |
) |
|
| 3011 | 33x |
mtext(ylab, 2, -.2, TRUE, cex = par("cex.lab"), font = par("font.lab"))
|
| 3012 | 33x |
mtext(xlab, 1, 0, TRUE, cex = par("cex.lab"), font = par("font.lab"))
|
| 3013 | 33x |
if (is.character(note)) {
|
| 3014 | 22x |
mtext( |
| 3015 | 22x |
note, |
| 3016 | 22x |
1, |
| 3017 | 22x |
ck$lx, |
| 3018 | 22x |
TRUE, |
| 3019 | 22x |
adj = if (ck$ly) 0 else .01, |
| 3020 | 22x |
font = font["note"], |
| 3021 | 22x |
cex = cex["note"] |
| 3022 |
) |
|
| 3023 |
} |
|
| 3024 |
if ( |
|
| 3025 | 33x |
save || |
| 3026 | 33x |
(missing(save) && |
| 3027 | 33x |
any(!missing(format), !missing(file.name), !missing(dims))) |
| 3028 |
) {
|
|
| 3029 | 1x |
tryCatch( |
| 3030 |
{
|
|
| 3031 | 1x |
if (is.character(format) || is.name(format)) {
|
| 3032 | 1x |
t <- as.character(format) |
| 3033 | 1x |
format <- eval(parse(text = t)) |
| 3034 |
} else {
|
|
| 3035 | ! |
t <- deparse(substitute(format)) |
| 3036 |
} |
|
| 3037 | 1x |
if (is.function(format)) {
|
| 3038 | 1x |
t <- sub("^[^:]*::", "", t)
|
| 3039 |
} |
|
| 3040 | 1x |
tt <- if (any(grepl("cairo", t, TRUE))) {
|
| 3041 | ! |
paste0(".", tolower(strsplit(t, "_|Cairo")[[1]][2]))
|
| 3042 | 1x |
} else if (t == "postscript") {
|
| 3043 | ! |
".ps" |
| 3044 |
} else {
|
|
| 3045 | 1x |
paste0(".", t)
|
| 3046 |
} |
|
| 3047 | 1x |
if (missing(dims) && grepl("jpeg|png|tiff|bmp|bit", t, TRUE)) {
|
| 3048 | ! |
dims <- dev.size(units = "px") |
| 3049 |
} |
|
| 3050 | 1x |
fn <- paste0( |
| 3051 | 1x |
if (main == "" || !missing(file.name)) {
|
| 3052 | 1x |
sub("\\.[^.]+$", "", file.name)
|
| 3053 |
} else {
|
|
| 3054 | ! |
gsub("\\s+", "_", gsub("^ +| +$| ", "", main))
|
| 3055 |
}, |
|
| 3056 | 1x |
tt |
| 3057 |
) |
|
| 3058 | 1x |
dev.copy(format, fn, width = dims[1], height = dims[2]) |
| 3059 | 1x |
dev.off() |
| 3060 | 1x |
if (file.exists(fn)) {
|
| 3061 | 1x |
message("image saved: ", fn)
|
| 3062 |
} else {
|
|
| 3063 | ! |
warning("failed to save image")
|
| 3064 |
} |
|
| 3065 |
}, |
|
| 3066 | 1x |
error = function(e) {
|
| 3067 | ! |
warning("unable to save image: ", e$message, call. = FALSE)
|
| 3068 |
} |
|
| 3069 |
) |
|
| 3070 |
} |
|
| 3071 | 33x |
invisible(list( |
| 3072 | 33x |
dat = dat, |
| 3073 | 33x |
cdat = cdat, |
| 3074 | 33x |
txt = txt, |
| 3075 | 33x |
ptxt = ptxt, |
| 3076 | 33x |
seg = seg, |
| 3077 | 33x |
ck = ck, |
| 3078 | 33x |
lega = lega, |
| 3079 | 33x |
fmod = fmod |
| 3080 |
)) |
|
| 3081 |
} |
| 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 |
} |