globalVariables(c(
'z1','plot', 'x0', 'x1', 'y0', 'y1', 'z0'
))
#' Correlated Splom
#'
#' Scatterplot matrix with correlations.
#' @param x object
#' @param ... passed arguments
#' @export
#' @family generic functions
#' @family corsplom
#' @importFrom utils head
corsplom <- function(x,...)UseMethod('corsplom')
#' Correlated Scatterplot Matrix Function for Data Frame
#'
#' Creates a scatterplot matrix with correlations in lower panel, by default.
#' @param x data.frame
#' @param xvar variables to plot
#' @param upper.panel passed to \code{\link[lattice]{splom}} or ggplot
#' @param lower.panel passed to \code{\link[lattice]{splom}} or ggplot
#' @param diag.panel passed to \code{\link[lattice]{splom}} or ggplot
#' @param pscales passed to \code{\link[lattice]{splom}}
#' @param xlab can be function(x = x, var = xvar, ...)
#' @param varname.cex text size multiplier
#' @param main character, or a function of x, xvar
#' @param sub character, or a function of x, xvar
#' @param col point color
#' @param smooth.col smooth color, defaults to col
#' @param smooth.lty smooth line type
#' @param smooth.lwd smooth line size
#' @param smooth.alpha smooth alpha
#' @param density whether to plot density polygons
#' @param diag.label label for the diagonal: a function of x, varname, .data
#' @param pin location for a pin (reference line) in the density region; can be function(x, varname, .data) or NULL to suppress
#' @param pin.col color of pin, if any
#' @param pin.alpha alpha transparency of pin
#' @param dens.col color for density region
#' @param dens.scale inflation factor for height of density smooth
#' @param dens.alpha alpha transparency for density region
#' @param settings default parameter settings: a list from which matching elements are passed to lattice (as par.settings) or to ggplot theme()
#' @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 as.table diagonal arranged top-left to bottom-right
#' @param dens.up whether density plots in diagonal should face the upper triangle vs. lower
#' @param gg logical: whether to generate \code{ggplot} instead of \code{trellis}
#' @param verbose generate messages describing process
#' @param ... extra arguments passed to \code{\link[lattice]{splom}} and ggplot
#' @export
#' @return trellis or grob
#' @importFrom rlang UQS
#' @importFrom gtable gtable_add_padding
#' @importFrom gridExtra arrangeGrob
#' @importFrom gridExtra grid.arrange
#' @family multivariate plots
#' @family corsplom
#' @family metaplot
#' @examples
#'
#' library(magrittr)
#' library(dplyr)
#' library(csv)
#' x <- as.csv(system.file(package = 'metaplot', 'extdata/theoph.csv'))
#' x %<>% pack
#' # setOption(gg = TRUE)
#' x %>% metaplot(lKe, lKa, lCl)
#' x %>% metaplot(
#' lKe, lKa, lCl,
#' col = 'black',smooth.col = 'red', pin.col = 'red',
#' dens.col='blue',dens.alpha = 0.1
#' )
corsplom_data_frame <- function(
x,
xvar = names(x),
upper.panel = metOption('upper.panel_corsplom',if(gg) 'corsplom_gg_scatter' else 'corsplom_panel_scatter'),
lower.panel= metOption('lower.panel_corsplom',if(gg) 'corsplom_gg_correlation' else 'corsplom_panel_correlation'),
diag.panel = metOption('diag.panel_corsplom',if(gg) 'corsplom_gg_diagonal' else 'corsplom_panel_diagonal'),
pscales= metOption('pscales_corsplom',0),
xlab = metOption('xlab_corsplom',NULL),
varname.cex = metOption('varname.cex_corsplom',1),
main = metOption('main_corsplom',NULL),
sub = metOption('sub_corsplom',NULL),
col = metOption('col_corsplom','blue'),
smooth.col = metOption('smooth.col_corsplom',NULL),
smooth.lty = metOption('smooth.lty_corsplom','solid'),
smooth.lwd = metOption('smooth.lwd_corsplom',1),
smooth.alpha = metOption('smooth.alpha_corsplom',1),
density = metOption('density_corsplom',TRUE),
diag.label = metOption('diag.label_corsplom','diag_label'),
pin = metOption('pin_corsplom','diag_pin'),
pin.col = metOption('pin.col_corsplom','darkgrey'),
pin.alpha = metOption('pin.alpha_corsplom',1),
dens.col = metOption('dens.col_corsplom','grey'),
dens.scale = metOption('dens.scale_corsplom',0.2),
dens.alpha = metOption('dens.alpha_corsplom',0.5),
settings = metOption('settings.corsplom',NULL),
padding = metOption('padding_corsplom', 1),
as.table = metOption('as.table_corsplom', FALSE),
dens.up = metOption('dens.up_corsplom', TRUE), # must not partial match densplot or upper
gg = metOption('gg_corsplom',FALSE),
verbose = metOption('verbose_corsplom',FALSE),
...
){
if(verbose)cat('this is corsplom_data_frame')
if(is.null(smooth.col))smooth.col <- col
settings <- as.list(settings)
if(is.null(names(settings))) names(settings) <- character(0)
stopifnot(length(as.table) == 1, is.logical(as.table))
if(is.character(xlab)) xlab <- tryCatch(match.fun(xlab), error = function(e)xlab)
if(is.function(xlab)) xlab <- xlab(x, xvar, ...)
if(is.null(xlab)) xlab <- ''
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')
stopifnot(inherits(x, 'data.frame'))
if(!is.null(main))if(is.function(main)) main <- main(x = x, xvar = xvar, ...)
if(!is.null(sub))if(is.function(sub)) sub <- sub(x = x, xvar = xvar, ...)
x <- x[,xvar,drop=FALSE]
if(gg){
tryCatch(match.fun(ylab), error = function(e)ylab)
if(is.character(upper.panel)) upper.panel <- tryCatch(match.fun(upper.panel), error = function(e)upper.panel)
if(is.character(lower.panel)) lower.panel <- tryCatch(match.fun(lower.panel), error = function(e)lower.panel)
if(is.character(diag.panel)) diag.panel <- tryCatch(match.fun(diag.panel), error = function(e)diag.panel)
ncol <- ncol(x)
cols <- 1:ncol
rows <- ncol:1
if(as.table) rows <- 1:ncol
res <- list()
for(i in rows){
for(j in cols){
if(i == j){
top <- FALSE
right <- FALSE
bottom <- FALSE
left <- FALSE
if(as.table & dens.up){
top <- i != 1
right <- i != ncol
}
if(!as.table & dens.up){
top <- i != ncol
left <- i != 1
}
if(as.table & !dens.up){
bottom <- i != ncol
left <- i != 1
}
if(!as.table & !dens.up){
bottom <- i != 1
right <- i != ncol
}
if(verbose)cat('calling diag.panel')
p <- diag.panel(
data = x,
mapping = aes_string(x = names(x)[[i]]),
col = col,
density = density & c(top, right, bottom, left),
varname.cex = varname.cex,
diag.label = diag.label,
pin = pin,
pin.col = pin.col,
pin.alpha = pin.alpha,
dens.col = dens.col,
dens.scale = dens.scale,
dens.alpha = dens.alpha,
.data = x,
as.table = as.table,
first = i == 1,
last = i == ncol,
verbose = verbose,
...
)
}
if(i != j && xor(i < j, as.table)){
if(verbose)cat('calling lower.panel')
p <- lower.panel(
data = x,
mapping = aes_string(x = names(x)[[j]], y = names(x)[[i]]),
col = col,
smooth.col = smooth.col,
smooth.alpha = smooth.alpha,
smooth.lty = smooth.lty,
smooth.lwd = smooth.lwd,
verbose = verbose,
...
)
}
if(i != j && xor(i > j, as.table)){
if(verbose)cat('calling upper.panel')
p <- upper.panel(
data = x,
mapping = aes_string(x = names(x)[[j]], y = names(x)[[i]]),
col = col,
smooth.col = smooth.col,
smooth.alpha = smooth.alpha,
smooth.lwd = smooth.lwd,
verbose = verbose,
...
)
}
theme_settings <- list(
aspect.ratio = 1,
strip.background = element_blank(),
strip.text.x = element_blank(),
strip.text.y = element_blank(),
axis.title = element_blank(),
axis.ticks = element_blank(),
axis.line = element_blank(),
axis.text.x = element_blank(),
axis.text.y = element_blank(),
axis.title.x = element_blank(),
axis.title.y = element_blank(),
plot.margin = unit(c(0,0,0,0), 'pt')
)
theme_extra <- settings[names(settings) %in% names(formals(theme))]
theme_settings <- merge(theme_settings, theme_extra)
p <- p + do.call(theme, theme_settings)
res[[length(res) + 1]] <- p
}
}
m <- do.call(
arrangeGrob,
c(
res,
ncol = ncol,
nrow = ncol,
respect = TRUE,
top = sub,
bottom = xlab
)
)
m <- do.call(
arrangeGrob,
list(
m,
top = textGrob(
main,
gp = gpar(
fontface = 'bold',
cex = 1.3
)
)
)
)
m <- gtable_add_padding(m, padding)
class(m) <- c('metaplot_gtable', class(m))
return(m)
}
if(verbose)cat('calling splom')
splom(
x,
upper.panel = upper.panel,
lower.panel = lower.panel,
diag.panel = diag.panel,
pscales = pscales,
xlab = xlab,
varname.cex = varname.cex,
main = main,
sub = sub,
.data = x,
split = split,
col = col,
smooth.col = smooth.col,
smooth.lty = smooth.lty,
smooth.lwd = smooth.lwd,
smooth.alpha = smooth.alpha,
density = density,
diag.label = diag.label,
pin = pin,
pin.col = pin.col,
pin.alpha = pin.alpha,
dens.col = dens.col,
dens.scale = dens.scale,
dens.alpha = dens.alpha,
as.matrix = as.table,
as_table = as.table,
par.settings = par.settings,
dens.up = dens.up,
verbose = verbose,
...
)
}
#' Correlated Scatterplot Matrix Method for Data Frame
#'
#' Creates a scatterplot matrix. Parses arguments and generates the call: fun(x, xvar, ...).
#' @param x data.frame
#' @param ... passed to fun
#' @param fun function to do the actual plotting
#' @param verbose generate messages describing process
#' @export
#' @importFrom rlang UQS quos
#' @family multivariate plots
#' @family corsplom
#' @family methods
corsplom.data.frame <- function(
x,
...,
fun = metOption('corsplom','corsplom_data_frame'),
verbose = metOption('verbose_corsplom_data_frame',FALSE)
){
args <- quos(...)
args <- lapply(args,f_rhs)
vars <- args[names(args) == '']
other <- args[names(args) != '']
vars <- sapply(vars, as.character)
prime <- list(x = x, xvar = vars)
args <- c(prime, other)
if(verbose){
if(is.character(fun))message('calling ', fun) else message('calling fun')
}
do.call(fun, args)
}
#' Correlation GG Function for GG Metaplot Corsplom
#'
#' Default lower panel function for corsplom_data_frame() with \code{gg = TRUE}. Plots Pearson correlation coefficient.
#' corsplom_data_frame() typically supplies smooth aesthetics in case smooth is desired; smooth arguments are defined to
#' suppress corresponding warnings.
#' @param data data
#' @param mapping mapping
#' @param col text color
#' @param smooth.col ignored
#' @param smooth.lty ignored
#' @param smooth.lwd ignored
#' @param smooth.alpha ignored
#' @param use passed to \code{\link[stats]{cor}}
#' @param verbose generate messages describing process
#' @param ... ignored
#' @keywords internal
#' @export
#' @family panel functions
#' @family corsplom
corsplom_gg_correlation = function(
data, mapping, col = metOption('col_corsplom_gg','blue'),
smooth.col, smooth.lty, smooth.lwd, smooth.alpha, use = 'pairwise.complete.obs', verbose = FALSE, ...
){
if(verbose)cat('this is corsplom_gg_correlation')
x <- as.character(mapping$x)
x <- x[x != '~']
x <- x[[1]]
y <- as.character(mapping$y)
y <- y[y != '~']
y <- y[[1]]
x <- data[[x]]
y <- data[[y]]
x1 <- range(x,na.rm = T)
y1 <- range(y,na.rm = T)
x0 <- min(x1)+(max(x1)-min(x1))/2
y0 <- min(y1)+(max(y1)-min(y1))/2
# panel.text(x0 ,y0, labels = paste('r =',round(cor(x,y, na.rm = T),3) ))
p <- ggplot(
data = data,
mapping = mapping,
colour = col
)
p <- p + xlim(x1[[1]], x1[[2]])
p <- p + ylim(y1[[1]], y1[[2]])
stat <- try(silent = TRUE, round(cor(x,y, use = use), 3))
if(inherits(stat, 'try-error')) stat <- ''
p <- p + annotate(
'text',
x = x0,
y = y0,
label = paste('r =',stat)
)
p <- p + theme(
aspect.ratio = 1,
panel.grid.major = element_blank(),
panel.grid.minor = element_blank() #,
# panel.border = element_rect(fill = NA)
)
p
}
#' Scatter GG Function for Metaplot Corsplom
#'
#' Default upper panel function for corsplom_data_frame with \code{gg = TRUE}. Plots data with loess smooth.
#' @param data data
#' @param mapping mapping
#' @param col point color
#' @param smooth.col smooth color
#' @param smooth.lty smooth line type
#' @param smooth.lwd smooth line size
#' @param smooth.alpha smooth alpha
#' @param verbose generate messages describing process
#' @param ... passed arguments
#' @keywords internal
#' @export
#' @family panel functions
#' @family corsplom
corsplom_gg_scatter = function(
data,
mapping,
method = 'loess',
se = F,
col = metOption('col_corsplom_gg','blue'),
smooth.col = metOption('smooth.col_corsplom_gg','blue'),
smooth.alpha = metOption('smooth.alpha_corsplom_gg',1),
smooth.lty = metOption('smooth.lty_corsplom_gg','solid'),
smooth.lwd = metOption('smooth.lwd_corsplom_gg',1),
verbose = metOption('verbose_corsplom_gg',FALSE),
...
){
if(verbose)cat('this is corsplom_gg_scatter')
x <- as.character(mapping$x)
x <- x[x != '~']
x <- x[[1]]
y <- as.character(mapping$y)
y <- y[y != '~']
y <- y[[1]]
lim1 <- range(data[[x]],na.rm = TRUE)
lim2 <- range(data[[y]],na.rm = TRUE)
ggplot(data = data, mapping = mapping, ...) +
xlim(lim1[[1]],lim1[[2]]) +
ylim(lim2[[1]],lim2[[2]]) +
geom_point(colour = col) +
geom_smooth(
method = method,
se = se,
colour = smooth.col,
alpha = smooth.alpha,
linetype = smooth.lty,
size = smooth.lwd,
...
)
}
#' Diagonal GG Function for Metaplot Corsplom
#'
#' Default diagonal panel function for corsplom_data_frame with \code{gg = TRUE}. Plots a density smooth against the corresponding axis from within the diagonal panel. Plots a grey pin at each axis zero. Formats and displays the variable name.
#' @param data data
#' @param mapping mapping
#' @param .data copy of original dataset
#' @param diag.label label for the diagonal: a function of x, varname, .data
#' @param pin location for a pin (reference line) in the density region; can be a function of x, varname, .data
#' @param pin.col color of pin, if any
#' @param pin.alpha alpha transparency of pin
#' @param density whether to plot density polygons; can be a length 4 vector for top, right, bottom, left
#' @param dens.col color for density region
#' @param dens.scale inflation factor for height of density smooth
#' @param dens.alpha alpha transparency for density region
#' @param varname.cex text size multiplier
#' @param as.table diagonal arranged top-left to bottom-right
#' @param dens.up whether density plots should face the upper triangle (or lower, if FALSE)
#' @param verbose generate messages describing process
#' @param ... passed arguments
#' @keywords internal
#' @export
#' @family panel functions
#' @family corsplom
#' @seealso \code{\link{corsplom}}
corsplom_gg_diagonal <- function(
data,
mapping,
.data,
density = TRUE,
diag.label = metOption('diag_label_corsplom_gg','diag_label'),
pin = metOption('pin_loc_corsplom_gg',diag_pin),
pin.col = metOption('pin.col_corsplom_gg','darkgrey'),
pin.alpha = metOption('pin.alpha_corsplom_gg',1),
dens.col = metOption('dens.col_corsplom_gg','grey'),
dens.scale = metOption('dens.scale_corsplom_gg',0.2),
dens.alpha = metOption('dens.alpha_corsplom_gg',0.5),
varname.cex = metOption('varname.cex_corsplom_gg', 1),
as.table = metOption('as.table_corsplom_gg', TRUE),
dens.up = metOption('dens.up_corsplom_gg',TRUE),
verbose = metOption('verbose_corsplom_gg',FALSE),
...
){
if(verbose)cat('this is corsplom_gg_diagonal')
stopifnot(is.logical(density))
density <- rep(density, length.out = 4)
names(density) <- c('top','right','bottom','left')
x <- as.character(mapping$x)
x <- x[x != '~']
x <- x[[1]]
data$x <- data[[x]]
lim <- range(data$x,na.rm = TRUE)
lo <- lim[[1]]
hi <- lim[[2]]
len <- hi - lo
me <- hi/2 + lo/2
d <- density(data$x,na.rm=TRUE, from = lo, to = hi)
d <- data.frame(x1 = d$x, y1 = d$y)
# ensure start and end points are minima
bottom <- rbind(
data.frame(x1 = d$x1[[1]], y1 = min(d$y1)),
d,
data.frame(x1 = d$x1[[nrow(d)]], y1 = min(d$y1))
)
bottom %<>% mutate(y1 = y1 / max(y1, na.rm = TRUE)) # normalized
bottom %<>% mutate(y1 = y1 * len * dens.scale) # scaled
bottom %<>% mutate(y1 = y1 + lo) # offset
top <- bottom %>% mutate(y1 = hi - y1 + lo) # inverted
left <- bottom %>% mutate(z1 = y1, y1 = x1, x1 = z1) # rotated
right <- left %>% mutate(x1 = hi - x1 + lo) # inverted
p <- ggplot(mapping = aes(x = x1, y = y1)) + xlim(lo,hi) + ylim(lo,hi)
if(density[['top']]) p <- p +
geom_polygon(
data = top,
col = NA,
fill = dens.col,
alpha = dens.alpha
)
if(density[['right']]) p <- p +
geom_polygon(
data = right,
col = NA,
fill = dens.col,
alpha = dens.alpha
)
if(density[['bottom']]) p <- p +
geom_polygon(
data = bottom,
col = NA,
fill = dens.col,
alpha = dens.alpha
)
if(density[['left']]) p <- p +
geom_polygon(
data = left,
col = NA,
fill = dens.col,
alpha = dens.alpha
)
if(is.character(pin)) pin <- match.fun(pin)
if(is.function(pin)) pin <- pin(x = x, varname = x, .data = .data, ...)
ref <- pin
ref <- as.numeric(ref)
ref <- ref[is.defined(ref)]
if(length(ref) && any(density)){
bottom <- data.frame(
x0 = ref,
x1 = ref,
y0 = rep(lo, length(ref)),
y1 = rep(lo + len * dens.scale, length(ref))
)
top <- bottom %>% mutate(
y0 = hi - y0 + lo,
y1 = hi - y1 + lo
)
left <- bottom %>% mutate(
z0 = x0, x0 = y0, z1 = x1, x1 = y1, y0 = z0, y1 = z1
)
right <- left %>% mutate(
x0 = hi - x0 + lo,
x1 = hi - x1 + lo
)
if(density[['top']]) p <- p + geom_segment(
data = top,
mapping = aes(x = x0, y = y0, xend = x1, yend = y1),
col = pin.col, alpha = pin.alpha
)
if(density[['right']]) p <- p + geom_segment(
data = right,
mapping = aes(x = x0, y = y0, xend = x1, yend = y1),
col = pin.col, alpha = pin.alpha
)
if(density[['bottom']]) p <- p + geom_segment(
data = bottom,
mapping = aes(x = x0, y = y0, xend = x1, yend = y1),
col = pin.col, alpha = pin.alpha
)
if(density[['left']]) p <- p + geom_segment(
data = left,
mapping = aes(x = x0, y = y0, xend = x1, yend = y1),
col = pin.col, alpha = pin.alpha
)
}
if(is.character(diag.label))diag.label <- match.fun(diag.label)
if(is.function(diag.label))diag.label <- diag.label(varname = x, .data = .data, ...)
#if(is.expression(diag.label))diag.label <- as.character(diag.label)
p <- p + annotate(
'text',
x = me,
y = me,
label = as.character(diag.label),
parse = is.expression(diag.label),
size = 4 * varname.cex
)
# diag.panel.splom(varname = diag.label, ...)
p
}
#' Plot a Metaplot_gtable
#'
#' Plots a metaplot_gtable. Underlying object type is 'gtable'.
#' Defaults for \code{link{corsplom_data_frame}} and \code{link{multiplot}} prepend class 'metaplot_gtable' to
#' modify plot and print functionality.
#'
#' @param x metaplot_gtable
#' @param \dots ignored
#' @keywords internal
#' @export
#' @return (invisible) gtable
#' @family methods
#' @family corsplom
#' @importFrom grid grid.newpage grid.draw
#' @seealso \code{\link{corsplom}}
plot.metaplot_gtable <- function(x, ...){
grid.newpage()
grid.draw(x)
}
#' Print a Metaplot_gtable
#'
#' Prints a metaplot_gtable. Underlying object type is 'gtable'.
#' Defaults for \code{link{corsplom_data_frame}} and \code{link{multiplot}} prepend class 'metaplot_gtable' to
#' modify plot and print functionality. Print method for 'gtable' summarizes the object.
#' This method invokes the plot method to give interactive behavior more like splom().
#'
#' @param x metaplot_gtable
#' @param \dots ignored
#' @keywords internal
#' @export
#' @return gtable
#' @family methods
#' @family corsplom
#' @seealso \code{\link{corsplom}} \code{\link{multiplot}}
print.metaplot_gtable <- function(x, ...)plot(x,...)
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.