Nothing
#' Boxplots
#'
#' @name boxplot
#' @keywords internal
NULL
#' Boxplot Function for Data Frame
#'
#' Boxplot for data.frame. Creates a boxplot using \code{boxplot_panel} by default.
#' @param x data.frame
#' @param yvar y variable
#' @param xvar x variable
#' @param facets optional conditioning variables
#' @param log whether to log transform numeric variable (auto-selected if NA)
#' @param crit if log is NA, log-transform if mean/median ratio for non-missing values is greater than this value
#' @param horizontal whether box/whisker axis should be horizontal (numeric x, categorical y); defaults TRUE if var[[2]] is numeric
#' @param scales passed to \code{\link[lattice]{xyplot}} (should be function(x = x, horizontal, log,...)) or \code{\link[ggplot2]{facet_grid}} or \code{\link[ggplot2]{facet_wrap}}
#' @param panel panel function
#' @param ref optional reference line(s) on numeric axis; can be function(x = x, var = con, ...) or NULL to suppress
#' @param ref.col color for reference line(s); can be length one integer to auto-select that many colors
#' @param ref.lty line type for reference line(s)
#' @param ref.lwd line size for reference line(s)
#' @param ref.alpha transparency for reference line(s)
#' @param nobs whether to include the number of observations under the category label
#' @param na.rm whether to remove data points with one or more missing coordinates
#' @param ylab y axis label
#' @param xlab x axis label
#' @param numlab numeric axis label; can be function(x = x, var = numvar, log = ylog, ...)
#' @param catlab categorical axis label; can be function(x = x, var = catvar, ...)
#' @param aspect passed to \code{\link[lattice]{bwplot}} or ggplot; use 'fill', NA, or NULL to calculate automatically
#' @param as.table passed to \code{\link[lattice]{xyplot}}
#' @param main character, or a function of x, yvar, xvar, facets, and log
#' @param sub character, or a function of x, yvar, xvar, facets, and log
#' @param settings default parameter settings: a list from which matching elements are passed to lattice (as par.settings) or to ggplot theme() and facet_wrap() or facet_grid(). \code{ncol} and \code{nrow} are used as layout indices for lattice (for homology with facet_wrap).
#' @param padding numeric (will be recycled to length 4) giving plot margins in default units: top, right, bottom, left (in multiples of 5.5 points for ggplot)
#' @param reverse if y is categorical, present levels in reverse order (first at top)
#' @param pch special character for box median: passed to \code{\link[lattice]{panel.bwplot}}
#' @param notch whether to draw notched boxes: passed to \code{\link[lattice]{panel.bwplot}}
#' @param gg logical: whether to generate \code{ggplot} instead of \code{trellis}
#' @param verbose generate messages describing process
#' @param ... passed arguments
#' @export
#' @importFrom rlang quos UQ
#' @importFrom graphics boxplot
#' @import lattice
#' @importFrom stats as.formula median cor loess.smooth density
#' @family mixedvariate plots
#' @family boxplot
#' @family metaplot
#' @examples
#' library(magrittr)
#' library(dplyr)
#' boxplot_data_frame(Theoph,'Subject','conc')
#' boxplot_data_frame(Theoph %>% filter(conc > 0),
#' 'conc','Subject', log = TRUE, ref = c(2,5),horizontal = FALSE)
boxplot_data_frame <- function(
x,
yvar,
xvar,
facets = NULL,
log = metOption('log_boxplot',FALSE),
crit = metOption('crit_boxplot',1.3),
horizontal = metOption('horizontal_boxplot',NULL),
scales = metOption('scales_boxplot',NULL),
panel = metOption('panel_boxplot','boxplot_panel'),
ref = metOption('ref_boxplot','metaplot_ref'),
ref.col = metOption('ref.col_boxplot','grey'),
ref.lty = metOption('ref.lty_boxplot','solid'),
ref.lwd = metOption('ref.lwd_boxplot',1),
ref.alpha = metOption('ref.alpha_boxplot',1),
nobs = metOption('nobs_boxplot',FALSE),
na.rm = metOption('na.rm_boxplot',TRUE),
xlab = NULL,
ylab = NULL,
numlab = metOption('numlab_boxplot','axislabel'),
catlab = metOption('catlab_boxplot','axislabel'),
aspect = metOption('aspect_boxplot',1),
as.table = metOption('as.table_boxplot',TRUE),
main = metOption('main_boxplot',NULL),
sub = metOption('sub_boxplot',NULL),
settings = metOption('settings_boxplot',NULL),
padding = metOption('padding_boxplot', 1),
reverse = metOption('reverse_boxplot',TRUE),
pch = metOption('pch_boxplot','|'),
notch = metOption('notch_boxplot',FALSE),
gg = metOption('gg_boxplot',FALSE),
verbose = metOption('verbose_boxplot', FALSE),
...
){
if(verbose) cat('this is boxplot_data_frame')
settings <- as.list(settings)
if(is.null(names(settings))) names(settings) <- character(0)
aspect <- metaplot_aspect(aspect, gg)
stopifnot(inherits(x, 'data.frame'))
stopifnot(is.character(xvar))
stopifnot(is.character(yvar))
if(!is.null(facets))stopifnot(is.character(facets))
stopifnot(is.numeric(padding))
padding <- rep(padding, length.out = 4)
par.settings <- settings[names(settings) %in% names(trellis.par.get())]
par.settings <- parintegrate(par.settings, padding)
if(gg)padding <- unit(padding * 5.5, 'pt')
y <- x
stopifnot(all(c(xvar,yvar,facets) %in% names(y)))
xguide <- attr(x[[xvar]], 'guide')
if(is.null(xguide)) xguide <- ''
xguide <- as.character(xguide)
if(is.null(horizontal)) horizontal <- is.numeric(x[[xvar]]) & !encoded(xguide)
cat <- if(horizontal) yvar else xvar
con <- if(horizontal) xvar else yvar
if(is.character(ref)) ref <- match.fun(ref)
if(is.function(ref)) ref <- ref(x = x, var = con, ...)
ref <- as.numeric(ref)
ref <- ref[is.defined(ref)]
stopifnot(all(c(cat,con) %in% names(y)))
if(na.rm){
#y %<>% filter(is.defined(UQ(cat)) & is.defined(UQ(con))) # preserves attributes
foo <- y
y <- y[is.defined(y[[cat]]) & is.defined(y[[con]]),]
for(col in names(foo))attributes(y[[col]]) <- attributes(foo[[col]])
at <- attributes(foo)
at$row.names <- NULL
for(a in names(at)) attr(y,a) <- attr(foo,a)
}
ff <- character(0)
if(!is.null(facets))ff <- paste(facets, collapse = ' + ')
if(!is.null(facets))ff <- paste0('|',ff)
formula <- as.formula(yvar %>% paste(sep = '~', xvar) %>% paste(ff))
if(!is.null(facets)){
for (i in seq_along(facets)) y[[facets[[i]]]] <- as_factor(y[[ facets[[i]] ]])
}
#formula <- as.formula(paste(sep = ' ~ ', yvar, xvar))
if(!is.numeric(y[[con]]))stop(con, ' must be numeric')
if(is.null(log)) log <- FALSE # same as default
if(is.na(log)){
if(any(y[[con]] <= 0, na.rm = TRUE)){
log <- FALSE
} else{
log <- mean(y[[con]],na.rm = TRUE)/median(y[[con]],na.rm = TRUE) > crit
}
}
bad <- !is.na(y[[con]]) & y[[con]] <= 0
bad[is.na(bad)] <- FALSE
if(log && any(bad)){
warning('dropping ',sum(bad), ' non-positive records for log scale')
y <- y[!bad,]
}
if(log & !gg){
ref <- ref[ref > 0]
if(length(ref)) ref <- log10(ref)
if(!length(ref)) ref <- NULL
}
if(is.character(catlab)) catlab <- tryCatch(match.fun(catlab), error = function(e)catlab)
if(is.function(catlab)) catlab <- catlab(x = y, var = cat, ...)
if(is.character(numlab)) numlab <- tryCatch(match.fun(numlab), error = function(e)numlab)
if(is.function(numlab)) numlab <- numlab(x = y, var = con, log = log, ...)
if(is.null(ylab)) ylab <- if(horizontal) catlab else numlab
if(is.null(xlab)) xlab <- if(horizontal) numlab else catlab
# guide <- attr(y[[cat]], 'guide')
# if(encoded(guide)){
# y[[cat]] <- decode(y[[cat]],encoding = if(length(decodes(guide)))guide else NULL)
# # y[[cat]] <- factor(y[[cat]],levels = rev(levels(y[[cat]])))
# }
# if(!is.factor(y[[cat]])) y[[cat]] <- factor(y[[cat]],levels = unique(y[[cat]]))
y[[cat]] <- as_factor(y[[cat]])
if(horizontal & reverse) y[[cat]] <- factor(y[[cat]],levels = rev(levels(y[[cat]])))
if(nobs){
lev <- levels(y[[cat]])
num <- sapply(lev,function(l)sum(na.rm = TRUE, y[[cat]] == l))
levels(y[[cat]]) <- paste(lev,num,sep = '\n')
}
if(is.null(scales) && gg) scales <- 'fixed'
if(is.null(scales)) scales <- function(x = y, horizontal = horizontal, log = log, ...){
s <- list(
tck = c(1,0),
alternating = FALSE,
x = list(log = log,equispaced.log = FALSE)
)
if(!horizontal)s <- list(
tck = c(1,0),
alternating = FALSE,
y = list(log = log,equispaced.log = FALSE)
)
s
}
if(is.character(scales) && !gg) scales <- match.fun(scales)
if(!is.function(scales) && !gg) stop('scales must be NULL, or function(x, horizontal, log,...), or the name of a function')
if(!gg) scales <- scales(x=x, horizontal = horizontal, log = log, ...)
if(!is.null(main))if(is.function(main)) main <- main(x = x, yvar = yvar, xvar = xvar, facets = facets, log = log, ...)
if(!is.null(sub))if(is.function(sub)) sub <- sub(x = x, yvar = yvar, xvar = xvar, facets = facets, log = log, ...)
if(gg){
plot <- ggplot(data = y, aes_string(cat, con))
plot <- plot +
geom_boxplot(notch = notch) +
xlab(catlab) +
ylab(numlab) +
ggtitle(main, subtitle = sub)
# scale aesthetics
panels <- 0
if(length(facets))panels <- nrow(unique(y[facets]))
if(!panels) panels <- 1
if(is.null(ref.col)) ref.col <- 'grey' # same as default
if(is.numeric(ref.col)) ref.col <- hue_pal()(ref.col[[1]])
ref.col <- rep(ref.col, length.out = length(ref))
ref.lty <- rep(ref.lty, length.out = length(ref))
ref.lwd <- rep(ref.lwd, length.out = length(ref))
ref.alpha <- rep(ref.alpha, length.out = length(ref))
ref.col <- rep(ref.col, times = panels)
ref.lty <- rep(ref.lty, times = panels)
ref.lwd <- rep(ref.lwd, times = panels)
ref.alpha <- rep(ref.alpha, times = panels)
if(length(ref)) plot <- plot +
geom_hline(
yintercept = ref,
color = ref.col,
linetype = ref.lty,
size = ref.lwd,
alpha = ref.alpha
)
theme_settings <- list(aspect.ratio = aspect, plot.margin = padding)
theme_extra <- settings[names(settings) %in% names(formals(theme))]
theme_settings <- merge(theme_settings, theme_extra)
plot <- plot + do.call(theme, theme_settings)
if(log) plot <- plot + scale_y_continuous(
trans = log_trans(),
breaks = base_breaks()
)
facet_args <- list()
if(length(facets) ==1) facet_args[[1]] <- facets[[1]]
if(length(facets) > 1) facet_args[[1]] <- as.formula(
paste(
sep='~',
facets[[1]],
facets[[2]]
)
)
facet_args$scales <- scales
facet_extra <- list()
if(length(facets) == 1) facet_extra <- settings[names(settings) %in% names(formals(facet_wrap))]
if(length(facets) > 1) facet_extra <- settings[names(settings) %in% names(formals(facet_grid))]
facet_args <- merge(facet_args, facet_extra)
if(length(facets) == 1) plot <- plot + do.call(facet_wrap, facet_args)
if(length(facets) > 1) plot <- plot + do.call(facet_grid, facet_args)
if(horizontal) plot <- plot + coord_flip()
return(plot)
}
args <- list(
formula,
data = y,
aspect = aspect,
horizontal = horizontal,
par.settings = par.settings,
scales = scales,
ylab = ylab,
xlab = xlab,
as.table = as.table,
main = main,
sub = sub,
panel = panel,
ref = ref,
ref.col = ref.col,
ref.lty = ref.lty,
ref.lwd = ref.lwd,
ref.alpha = ref.alpha,
pch = pch,
notch = notch,
verbose = verbose
)
args <- c(args, list(...))
if(all(c('ncol','nrow') %in% names(settings))){
layout <- c(settings$ncol, settings$nrow)
args <- c(args, list(layout = layout))
}
if(verbose)cat('calling bwplot')
do.call(bwplot, args)
}
#' Panel Function for Metaplot Boxplot
#'
#' Panel function for metaplot boxplot. Calls, \code{\link[lattice]{panel.bwplot}} and plots reference lines if ref has length.
#' @export
#' @family panel functions
#' @family mixedvariate plots
#' @keywords internal
#' @param ref numeric
#' @param horizontal passed to \code{\link[lattice]{panel.bwplot}}
#' @param pch passed to \code{\link[lattice]{panel.bwplot}}
#' @param notch passed to \code{\link[lattice]{panel.bwplot}}
#' @param ref.col passed to \code{\link[lattice]{panel.abline}} as col
#' @param ref.lty passed to \code{\link[lattice]{panel.abline}} as lty
#' @param ref.lwd passed to \code{\link[lattice]{panel.abline}} as lwd
#' @param ref.alpha passed to \code{\link[lattice]{panel.abline}} as alpha
#' @param verbose generate messages describing process
#'
#'
boxplot_panel <- function(
ref = NULL, horizontal,pch = '|',notch=FALSE,
ref.col, ref.lty, ref.lwd, ref.alpha, verbose = FALSE, ...
){
if(verbose)cat('this is boxplot_panel calling panel.bwplot and panel.abline')
panel.bwplot(horizontal = horizontal, pch = pch, notch = notch, ...)
if(length(ref)){
if(horizontal) {
panel.abline(v = ref, col = ref.col, lty = ref.lty, lwd = ref.lwd, alpha = ref.alpha)
}else{
panel.abline(h = ref, col = ref.col, lty = ref.lty, lwd = ref.lwd, alpha = ref.alpha)
}
}
}
#' Boxplot Method for Data Frame
#'
#' Boxplot for data.frame. Parses arguments and generates the call: fun(x, yvar, xvar, facets, ...).
#' @param x data.frame
#' @param ... passed to fun
#' @param fun function that does the actual plotting
#' @param verbose generate messages describing process
#' @export
#' @importFrom rlang f_rhs
#' @family mixedvariate plots
#' @family boxplot
#' @family methods
#' @examples
#' library(dplyr)
#' library(magrittr)
#' Theoph %<>% mutate(site = ifelse(as.numeric(Subject) > 6, 'Site A','Site B'))
#' boxplot(Theoph,'Subject','conc')
#' boxplot(Theoph,Subject,conc)
#' boxplot(Theoph,Subject,conc, gg = T)
#' boxplot(Theoph,conc,Subject)
#' boxplot(Theoph,conc,Subject, gg = T)
#' boxplot(Theoph,conc,Subject,site)
#' boxplot(Theoph,conc,Subject,site, gg = T)
#' boxplot(Theoph,conc,Subject,site, gg = T, scales = 'free_x')
#' attr(Theoph,'title') <- 'Theophylline'
#' boxplot(Theoph, Subject, conc, main = function(x,...)attr(x,'title'))
#' boxplot(Theoph, Subject, conc, main = function(x,...)attr(x,'title'), gg = T)
#' boxplot(Theoph, Subject, conc, sub= function(x,...)attr(x,'title'))
#' boxplot(Theoph, Subject, conc, sub= function(x,...)attr(x,'title'), gg = T)
#' boxplot(Theoph %>% filter(conc > 0),Subject,conc, log = T)
#' boxplot(Theoph %>% filter(conc > 0),Subject,conc, log = T, gg = T)
boxplot.data.frame <- function(
x,
...,
fun = metOption('box','boxplot_data_frame'),
verbose = metOption('verbose_boxplot',FALSE)
){
args <- quos(...)
args <- lapply(args,f_rhs)
var <- args[names(args) == '']
other <- args[names(args) != '']
var <- sapply(var, as.character)
ypos <- 1
xpos <- 2
yvar <- var[ypos]
xvar <- var[xpos]
more <- character(0)
if(length(var) > xpos) more <- var[(xpos+1):length(var)]
facets <- if(length(more)) more else NULL
formal <- list(
x = x,
yvar = yvar,
xvar = xvar,
facets = facets
)
args <- c(formal, other)
if(verbose){
if(is.character(fun))message('calling ', fun) else message('calling fun')
}
do.call(fun, args)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.