R/graphics.R
In gmonette/yscs: Collection of tools used in York University's Statistical Consulting Service
###
### td
###
#' @name td
NULL
#' Set lattice parameters for multiple groups
#'
#' Easier alternative to using trellis.par.set and trellis.par.get to change lattice colors, line types, etc.
#'
#' Designed to easily set lattice parameters for multiple groups. Setting
#' parameters before calling the lattice function allows parameters to be used
#' consistently in the group key.
#'
#' 'td' calls 'trellis.device' and sets graphical parameters for
#' 'superpose.line' and 'superpose.symbol'. 'td' also initializes a new trellis
#' device with a white background if new = TRUE.
#'
#' 'gd' is similar to 'td' except that it uses a theme that resembles that of 'ggplot'
#'
#' @param n in 'gd' specifies the number of distinct colours to generate to
#' distinguish groups. 'gd' uses 'latticeExtra' to set defaults for a
#' ggplot2-like appearance. Default is n = 4
#' @param new If new = TRUE, open a new window, otherwise modify the existing
#' active window, if there is one.
#' @param col
#' @param lty
#' @param lwd
#' @param pch
#' @param cex
#' for each level of the groups variable
#' @param font
#' @param fill
#' @param col.line
#' not given
#' @param col.symbol
#' 'groups' not given
#' @param alpha
#' @param alpha.line
#' @param alpha.symbol graphical parameters for superpose.line and
#' superpose.symbol
#' @param len extend the length of parameters by recycling to length 'len'
#' @param long if TRUE generate a default combination of col, lty and pch with
#' length 42.
#' @param record If TRUE, set history to 'recording'. Caution: this can use a
#' lot of memory in .GlobalEnv. Consider adding selected graphs to memory with
#' the 'Insert' key instead.
#' @param basecol
#' @param colsets
#' @param \dots
#' parameter: e.g. \code{plot.symbol=list(cex=2,col='red')}. Particular useful
#' for the cex, col, lty, lwd, alpha, pch parameters in plot.line and
#' plot.symbol.
#' @author Georges Monette
#' @examples
#' td( lty = 1:7) # sets line types for 7 groups
#' gd(7) # sets line types for 7 groups using colors from RColorBrewer
#' td( plot.symbol = list(col = 'red', pch = 17))
#' gd_(col='blue') # set main color to 'blue'
#' @describeIn td
#' @export
td <- function(
new = FALSE,
col=c("#0080ff", "#ff00ff", "darkgreen", "#ff0000" , "orange" , "#00ff00", "brown" ),
lty=1:7, lwd=1,
pch = 1:7, cex = 0.8, font = 1,
long = FALSE,
# record = FALSE, # not supported in RStudio
basecol = NULL,
colsets = c('plot.symbol','plot.line','dot.symbol',
'dot.line','cloud.3d','box.dot'),
...) {
# Modified for R: Oct. 10, 2004
#
# reset superpose.symbol and superpose.line so they have consistent length
# equal to the max of input parameters:
# sps: cex, col, font, pch
# spl: lty, col, lwd
# or to len
# This allows distinctive line styles, for example for 12 objects by using
# good lty's: 1,4,8,6,3,5,7
# and good col's: 1,8,6,3,4,5,2
#
require(lattice)
aargs <- list(...)
if ( long ) {
col <- c(3,5,4,6,8,2) # drop yellow
len <- 42 # generates 42 unique combinations of pch/lty and col
}
if(new) trellis.device(theme = col.whitebg, record = record, new = new)
# NOTE: fixed panel.superpose so lty argument
# is passed to points for type = 'b'
len <- max(len,length(col),length(lty),length(lwd),length(pch),length(cex),length(font))
spl <- trellis.par.get("superpose.line")
spl$alpha <- rep(alpha.line, length = len)
spl$lty <- rep(lty,length=len)
spl$col <- rep(col.line,length=len)
spl$lwd <- rep(lwd,length=len)
trellis.par.set("superpose.line",spl)
sps <- trellis.par.get("superpose.symbol")
sps$alpha <- rep( alpha.symbol, length = len)
sps$pch <- rep(pch, length=len)
sps$col <- rep(col.symbol, length=len)
sps$cex <- rep(cex, length=len)
sps$font <- rep(font, length=len)
sps$fill <- rep(fill, length=len)
trellis.par.set("superpose.symbol",sps)
list(superpose.symbol = sps, superpose.line = spl)
if ( !is.null(basecol)) {
for ( ii in colsets ) {
tt <- trellis.par.get(ii)
tt$col <- basecol
trellis.par.set(ii,tt)
}
}
if ( length(aargs)){
tpg <- trellis.par.get()
for ( nn in names(aargs)){
for(mm in names(aargs[[nn]])){
tpg[[nn]][[mm]] <- aargs[[nn]][[mm]]
}
}
trellis.par.set(theme = tpg)
}
ret <- trellis.par.get()
invisible(ret[grep('superpose',names(ret))])
}
#' @describeIn td uses a ggplot-like theme
#' @param n number of groups for which to set colors, line types, etc. using RColorBrewer.
#' @examples
#' # - setting colors for groups, i.e. 'superpose.symbol' in trellis.par.get():
#' gd(5) # where 5 is the number of groups
#' gd(5, lwd = 2, lty = 1)
#' gd(5, col = brewer.pal(5,"Dark2"),cex = 1.5)
#'
#' # To set colors with no groups
#' gd_(col='tomato4')
#' # changing the default color for lines and symbols
#' gd(plot.line=list(col='red',lwd=2),
#' plot.symbol=list(col='blue', cex = 1.3))
#' # OR using superpose = FALSE
#' gd(superpose = FALSE, col = 'red', lwd = 2)
#' # OR using the utility function:
#' gd_(col = 'red', lwd = 2)
#' #
#' # For a complete list of elements that can be changed:
#' names(trellis.par.get())
#' # For a list of colors
#' colors()
#' grepv('pink',colors()) # types of pink
#' # Using magrittr
#' library(magrittr)
#' colors() %>% grepv('blue', .) %>%
#' pal %>%
#' as.data.frame %>%
#' sortdf( ~ red) %>%
#' as.matrix %>%
#' divide_by(255) %>%
#' rgb %>%
#' pal
#' @export
gd <-
function (n=9,
col = brewer.pal(n,"Set1"), lty = 1:n, lwd = 1,
pch = 19, cex = 1.4, font = 1, fill = "transparent",
col.line = col, col.symbol = col,
alpha = 1, alpha.line = alpha, alpha.symbol = alpha,
len = n,
# arguments to ggplot2like:
h = c(0,360) + 15, l =65, c = 100, h.start = 0, direction = 1,
low = "#3B4FB8", high = "#B71B1A", space = "rgb",
# trellis par set parameters for basecol:
basecol = NULL,
colsets = c("plot.symbol","plot.line", "dot.symbol",
"dot.line", "cloud.3d", "box.dot"),
# set ggplot2 like environment even if not first call
superpose = TRUE,
gginit = FALSE,
# other arguments of form:
# plot.symbol = list( col = 'red', pch = 4)
...)
{
# gd makes it easy to set graphical parameters,
# i.e. col, lwd, lty, fill, font, cex, pch, alpha
# for 'superpose.symbol' and 'superpose.line' used
# for different groups in lattice
# Note: fill works with pch 21:25
#
# gd can also be used to set other graphical parameters
# by specifying the list in which they are set
# (see trellis.par.get()). For example to reset
# symbol colors and line colors:
# gd(
# Usage:
library(lattice)
library(latticeExtra)
library(RColorBrewer)
aargs <- list(...)
# ggplot2
if(is.null(lattice.options('gginit')[[1]]) | gginit == TRUE){
lattice.options(gginit=TRUE)
trellis.par.set(ggplot2like(n = n,h = h,l = l,c = c,
h.start = h.start, direction = direction,
low = low , high = high , space = space))
lattice.options(ggplot2like.opts())
}
len <- max(len, length(col), length(lty), length(lwd), length(pch),
length(cex), length(font))
if (superpose ) {
spl <- trellis.par.get("superpose.line")
spl$alpha <- rep(alpha.line, length = len)
spl$lty <- rep(lty, length = len)
spl$col <- rep(col.line, length = len)
spl$lwd <- rep(lwd, length = len)
trellis.par.set("superpose.line", spl)
sps <- trellis.par.get("superpose.symbol")
sps$alpha <- rep(alpha.symbol, length = len)
sps$pch <- rep(pch, length = len)
sps$col <- rep(col.symbol, length = len)
sps$cex <- rep(cex, length = len)
sps$font <- rep(font, length = len)
sps$fill <- rep(fill, length = len)
trellis.par.set("superpose.symbol", sps)
} else { # use to set non-panel setting
tt <- trellis.par.get()
if ( !missing(col) ) {
tt$plot.symbol$col <- col.symbol
tt$plot.line$col <- col.line
}
if ( !missing(col.line)) {
tt$plot.line$col <- col.line
}
if ( !missing(col.symbol)) {
tt$plot.symbol$col <- col.symbol
}
if ( !missing(alpha) ) {
tt$plot.symbol$alpha <- alpha.symbol
tt$plot.line$alpha <- alpha.line
}
if ( !missing(alpha.line)) {
tt$plot.line$alpha <- alpha.line
}
if ( !missing(alpha.symbol)) {
tt$plot.symbol$alpha <- alpha.symbol
}
if ( !missing(lty)) {
tt$plot.line$lty <- lty
}
if ( !missing(lwd)) {
tt$plot.line$lwd <- lwd
}
if ( !missing(pch)) {
tt$plot.symbol$pch <- pch
}
if ( !missing(cex)) {
tt$plot.symbol$cex <- cex
}
if ( !missing(fill)) {
tt$plot.symbol$fill <- fill
}
trellis.par.set(theme = tt)
}
if (!is.null(basecol)) {
for (ii in colsets) {
tt <- trellis.par.get(ii)
tt$col <- basecol
trellis.par.set(ii, tt)
}
}
if (length(aargs)) {
tpg <- trellis.par.get()
for (nn in names(aargs)) {
for (mm in names(aargs[[nn]])) {
tpg[[nn]][[mm]] <- aargs[[nn]][[mm]]
}
}
trellis.par.set(theme = tpg)
}
ret <- trellis.par.get()
invisible(ret[grep("superpose", names(ret))])
}
#' @describeIn td gd to set non-group parameters
#' @export
gd_ <- function(...) gd(superpose = FALSE, ...)
###
### xqplot
###
#' Extended Quantile Plots
#'
#' An easy way to see a dataset's variables at a glance. Shows uniform quantile
#' plot for numerical varibles and barcharts for factors. Quantile plots also
#' show a horizontal line at the position of the mean and at mean plus or minus
#' one standard deviation.
#'
#' @param x a data frame or list of variables to plot
#' @param ptype "quantile" (default) or "normal": kind of quantile to plot on x
#' axis.
#' @param labels names for each plot
#' @param \dots additional arguments passed to 'plot' command
#' @param mfrow number of rows and columns per page. If missing, an attempt is
#' made to choose a reasonable number.
#' @param ask
#' @param mcex character expansion factor for marginal text
#' \code{mcex}
#' @param maxlab maximum number of categories to label in barcharts
#' @param debug if TRUE, print additional information
#' @param mar size of margins
#' @param text.cex.factor character expansion factor for barchart labels
#' @param left.labs determines placement of barchart labels
#' @param maxvarnamelength maximum length of variable name without splitting on
#' two lines.
#' @note Bugs:
#' 'mfrow' should take the total number of variables into account if they will
#' fill more than one page so the last page is close to being full.
#'
#' The current version of the function could be made much simpler and more
#' transparent. Some code is redundant.
#' @examples
#' require(car)
#' xqplot(Prestige)
#' xqplot(Prestige,"n") # normal quantiles
#' @export
xqplot <- function(x,
ptype = "quantile",
labels = dimnames(x)[[2]], ...,
mfrow = findmfrow ( ncol(x)),
ask = prod(mfrow) <
ncol(x) && dev.interactive(),
mcex = 0.8, maxlab = 12 , debug = F,
mar = c(5,2,3,1),
text.cex.factor = 1 ,
left.labs = F,
maxvarnamelength = 20)
{
## Adapted from myplot.data.frame for R by G. Monette, Oct. 25, 2004
## maxlab is maximum number of labels
# Turn matrices into variables:
if (! is.list(x)) x <- as.data.frame(x)
if ( any ( sapply( x, class) == 'matrix') ) {
zz <- list()
for ( ii in seq_along( x )) {
if ( is.matrix( x[[ii]])) {
if ( is.null (colnames( x[[ii]]))) {
cnames <- paste( names(x)[ii], 1:ncol(x[[ii]]), sep ='.')
} else {
cnames <- paste( names(x)[ii], colnames(x[[ii]]), sep = '.')
}
for ( jj in seq_len( ncol ( x[[ii]]))) {
zz[[cnames[jj] ]] <- x[[ii]][,jj]
}
} else {
zz[[ names(x)[[ii]] ]] <- x[[ii]]
}
}
x <- as.data.frame(zz)
#disp( x )
}
left.labs <- rep( left.labs, length = length(x))
findmfrow <- function( x ) {
if ( x > 9) c(3,4)
else cbind( '1'=c(1,1),'2'=c(1,2),'3'=c(2,2),
'4'=c(2,2),'5'=c(2,3),'6'=c(2,3),
'7'=c(3,3), '8'=c(3,3), '9'=c(3,3)) [, x]
}
opt <- par( mfrow = mfrow, ask = ask , mar = mar + 0.1 )
on.exit(par(opt))
if(debug) { cat("opt:\n");print(opt)}
iscat <- function( x ) is.factor(x) || is.character(x)
Levels <- function(x) {
if ( is.factor(x)) levels(x) else unique(x)
}
compute.cex <- function( x ) {
ll <- length(x)
cex <- 2 * ifelse( ll < 5, 2,
ifelse( ll < 10, 1,
ifelse( ll < 20, .7, .5)))/mfrow[1]
}
for ( ii in 1: dim(x)[2]) {
vv <- x[[ii]]
nam <- labels[[ii]]
Nmiss <- sum(is.na(vv))
N <- length(vv)
if ( iscat(vv) ){
tt <- table(vv)
xlab <- paste("N =", N )
if ( Nmiss > 0 ) {
tt <- c( "<NA>" = sum(is.na(vv)), tt)
xlab <- paste(xlab, " Nmiss =", Nmiss)
}
ll <- names(tt)
nn <- length(ll)
if ( left.labs[ii] ) barplot( tt, horiz = TRUE,
xlab = xlab,
cex.names = text.cex.factor * compute.cex(nn) )
else {
zm <- barplot( tt, names = rep("",nn), horiz = TRUE, xlab = xlab)
## If nn > maxlab drop labels for smaller frequencies
sel <- rep( T, length(tt))
tt.sorted <- rev(sort(tt))
if ( nn > maxlab ) sel <- tt > tt.sorted[maxlab]
if (debug) {
disp(sel)
disp(nam)
disp(tt)
disp(tt.sorted)
disp(maxlab)
disp(tt.sorted[maxlab])
disp(sel)
disp(zm[sel])
disp(rep(max(tt),nn)[sel])
disp( ll[sel])
}
if ( any(sel) ) text( rep( max( tt ), nn)[sel] ,
zm[sel], ll[sel], adj = 1, cex = text.cex.factor * compute.cex( nn ))
}
} # end of iscat(vv)
else {
sublab <- ""
N <- length( vv )
Ninfinite <- 0
if ( any( is.infinite ( vv ) ) ){
n.pi <- sum( vv == Inf , na.rm = TRUE)
n.ni <- sum( vv == -Inf, na.rm = TRUE )
Ninfinite <- n.pi + n.ni
vv <- vv[!is.infinite(vv)]
sublab <- paste( sublab,"-Inf:",n.ni,"+Inf:",n.pi)
}
Nmiss <- 0
if ( any ( is.na( vv ) )) {
Nmiss <- sum( is.na(vv) )
vv <- vv[!is.na(vv)]
sublab <- paste( sublab, "NA:", Nmiss)
}
Nok <- N - Nmiss - Ninfinite
if ( pmatch( ptype, 'normal', nomatch = 0) == 1 ) {
xxvar <- qnorm( ppoints(length(vv)) )
xlab <- paste("Normal quantile for", Nok, "obs.")
}
else {
xxvar <- ppoints( length(vv) )
xlab <- paste("Fraction of", Nok, "obs.")
}
## Plot continuous
if ( Nok == 0 ) {
xxvar <- 1
vv <- 1
if ( sublab == "") {
plot( xxvar, vv, xlab = xlab, ylab="", type = 'n')
} else {
plot( xxvar, vv, xlab = xlab, ylab="", type = 'n', sub = sublab)
}
text( 1, 1, "NA")
}
else {
if ( sublab == "") {
plot(xxvar, sort(vv), xlab = xlab, ylab = "Data", ...)
} else {
plot(xxvar, sort(vv), xlab = xlab, ylab = "Data", ..., sub = sublab)
}
xm <- mean(vv)
xs <- sqrt(var(vv))
abline( h= xm,lty=1)
abline( h= c(xm-xs,xm+xs),lty=2)
}
}
## Titles for all plots
vlab <- labels[ii]
line.offset <- 1.0
if ( nchar( vlab ) > maxvarnamelength) {
vlab <- paste( substring(vlab,1,maxvarnamelength), "\n",substring(vlab, maxvarnamelength + 1))
line.offset <- 0.2
}
mtext(vlab, 3, line.offset , cex = mcex)
}
# par(opt)
if(debug) { disp(par()) }
invisible(0)
}
#' Show available characters, colours, etc.
#'
#' @param n
#' @export
sampler <-
function( n=24 ) {
# sample of lines and symbols
old.par <- par(ask=T)
on.exit( par(old.par))
require(lattice)
y <- 0:n
x <- 0:n
print(xyplot( y ~ x, type = 'n', xlab = 'lty', ylab = 'col',
panel = function(x,y,...) {
for ( i in x) {
panel.xyplot(c(i,i),range(y),type='l',lty=i,col=1,lwd = 3)
}
for ( i in y) {
for ( j in seq(0,.9, by = .1)) {
panel.xyplot(c(min(x)+ j*(max(x)-min(x)),min(x)+ (j+.1)*(max(x)-min(x))),c(i,i),type='l',lty=1,col=i, lwd = 3)
}
}
}))
# print(z$x, z$y, ylim=c(0,7))
spl <-trellis.par.get('superpose.line')
z <- expand.grid( y = 1:length(spl$lty), x = 0:2)
print(xyplot( y ~ x , z, ylim =c(0,length(spl$lty)),groups = y, type='b',
main="superpose.line and .symbol"))
y <- 10*(0:25)
x <- 0:9
print(xyplot( y ~ x, type = 'n', main = 'pch',
xlab = expression( ~ alpha + beta + gamma + delta[epsilon] + zeta^eta + theta + iota+kappa),
ylab = expression( ~ lambda + mu + nu + xi + omicron + pi + rho + sigma + tau + upsilon + phi + chi +psi + omega),
panel = function(x,y,...) {
for ( i in x) {
for ( j in y ) {
panel.xyplot(i,j,pch=i+j,cex = 2)
}
}
}))
invisible(0)
}
#' Generate a palette of colours -- possibly superseded
#'
#' @param col colors to show
#' @param border (default 'light gray')
#' @param \dots
#' @export
pal <- function(col=c('blue','pink'), border = "light gray", ...) {
n <- length(col)
plot(0, 0, type = "n", xlim = c(0, 1), ylim = c(0, 1), axes = FALSE,
xlab = "", ylab = "", ...)
rect(0, 0:(n - 1)/n, .6, 1:n/n, col = col, border = border)
ret <- col2rgb(col)
dimnames(ret)[[2]] <- col
ret <- t(ret)
txt <- paste( as.character(col), "(",
apply( ret, 1, paste, collapse=" "), ")")
text( rep(.6, n), (0:(n-1)+.5)/n, txt, adj = 0)
ret <- col2rgb(col)
dimnames(ret)[[2]] <- col
t(ret)
}
#' Display colors n at a time
#'
#' @param pp
#' @export
pals <- function(pp=30){
n <- length(cc <- colors())
ii <- 1
while( ii < n ){
pal(cc[ii:min(ii+pp,n)], ask = TRUE)
ii <- ii + pp + 1
}
}
## brace() now moved to brace.R
#' Replace elements of x with correspondingly named elements of ll
#'
#' @param x
#' @param ll
#' @export
change <- function(x,ll) {
#
# Modifies elements in a list
# Ideal for changing ... arguments in calls to panel.groups etc.
#
nams <- names(ll)
for ( ii in seq_along(ll) ) {
x[[nams[ii]]] <- ll[[ii]]
}
x
}
#' Panel function to display subgroups within groups within panels
#'
#' This function is designed to be used as the argument to \code{panel.groups}
#' in \code{xyplot}. It effectively adds another level of subgrouping to that
#' implemented by the \code{groups} argument in \code{xyplot}. Useful mainly
#' to display data and fitted lines in groups within panels.
#'
#' This function is designed to be used as the argument to 'panel.groups' in
#' 'xyplot'. It allows the plotting of points versus lines within subgroups of
#' the data identified by the 'groups' argument in xyplot. It requires a
#' variable to identify the subgroups. Points or lines are used within
#' subgroups depending on 'subgroups.type' where the order is that of the
#' levels of the 'subgroups' argument coerced as a factor, if necessary. See
#' the examples below.
#'
#' @param x,y coordinates of the points to be displayed
#' @param subscripts subscripts giving indices in original data frame
#' @param subgroups a subgrouping variable. Use a full reference, e.g.
#' data$subvar
#' @param subgroups.type plotting type, typically 'p' or 'l', for each level of
#' the variable passed through the \code{subgroups} argument
#' @param type
#' @param panel.subgroups function use to plot data within in each group
#' referring to the levels of the variable passed by \code{subgroups}. Define
#' a \code{panel.subgroups} argument in the call to \code{xyplot} and it will
#' be used to plot the groups. See the examples below.
#' @param \dots any other arguments to be passed to the panel plotting function
#' @seealso \code{link[lattice]{panel.superpose}},
#' \code{link[lattice]{panel.superpose.2}}, \code{link[lattice]{panel.xyplot}}
#' @examples
#' \dontrun{
#' library(car)
#' data(Prestige)
#' fit <- lm( prestige ~ (education +I(education^2)) * type, Prestige, na.action = na.omit)
#' pred <- expand.grid( education = seq( 6, 18, .5), type = levels( Prestige$type))
#' pred$prestige <- predict( fit, newdata = pred )
#'
#' Prestige$what <- 'data'
#' pred$what <- 'fit' # this works because 'fit' follows 'data' lexicographically
#'
#' combined <- merge( Prestige, pred, all = T)
#'
#' xyplot( prestige ~ education, combined,
#' groups = type,
#' subgroups = combined$what, # note that a full reference to the variable is needed
#' panel = panel.superpose, # might not be necessary in future version of lattice
#' panel.groups = panel.subgroups) # uses the default of points for the first level of 'what'
#' # and lines for the second level
#'
#' ## Using the argument 'panel.subgroups' instead of the default 'panel.xyplot'
#' ## Note that panel.subgroups is a function (this one) and also an argument that
#' ## is a function passed to the function. The argument defines the action to
#' ## be taken within each level of 'what'
#'
#' xyplot( prestige ~ education, combined,
#' groups = type,
#' subgroups = combined$what, # note that a full reference to the variable is needed
#' panel = panel.superpose, # might not be necessary in future version of lattice
#' panel.groups = panel.subgroups,
#' panel.subgroups = function( x, y, subgroup, type, ...) {
#' # note that you need to include 'type' among the arguments
#' # if you need to prevent it from being passed through '...'
#' # When called, this function will be passed arguments
#' # subgroup, subgroup.number, subscripts, and type from
#' # subgroups.type.
#' if ( subgroup == 'data' ) {
#' panel.xyplot( x, y, ...)
#' panel.lines( dell(x,y), ...)
#' } else {
#' panel.lines( x,y, ...)
#' }
#' })
#' }
#' @export
panel.subgroups <- function( x, y, subscripts,
subgroups, subgroups.type = c('p','l'),type,
panel.subgroups = panel.xyplot, ...) {
help = "Use help: ?panel.subgroups"
subgroups <- as.factor(subgroups)
levs <- levels(subgroups)
subgroups.type <- rep( subgroups.type, length.out = length(levs))
subgroups = subgroups[subscripts]
for ( i in seq_along( levs) ) {
sel <- subgroups == levs[i]
if ( any( sel )) {
panel.subgroups( x[sel], y[sel], type = subgroups.type[i],
subscripts = subscripts[sel], subgroup.number = i,
subgroup = levs[i], ...)
}
}
}
gmonette/yscs documentation built on May 17, 2019, 7:28 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
###
### td
###
#' @name td
NULL
#' Set lattice parameters for multiple groups
#'
#' Easier alternative to using trellis.par.set and trellis.par.get to change lattice colors, line types, etc.
#'
#' Designed to easily set lattice parameters for multiple groups. Setting
#' parameters before calling the lattice function allows parameters to be used
#' consistently in the group key.
#'
#' 'td' calls 'trellis.device' and sets graphical parameters for
#' 'superpose.line' and 'superpose.symbol'. 'td' also initializes a new trellis
#' device with a white background if new = TRUE.
#'
#' 'gd' is similar to 'td' except that it uses a theme that resembles that of 'ggplot'
#'
#' @param n in 'gd' specifies the number of distinct colours to generate to
#' distinguish groups. 'gd' uses 'latticeExtra' to set defaults for a
#' ggplot2-like appearance. Default is n = 4
#' @param new If new = TRUE, open a new window, otherwise modify the existing
#' active window, if there is one.
#' @param col
#' @param lty
#' @param lwd
#' @param pch
#' @param cex
#' for each level of the groups variable
#' @param font
#' @param fill
#' @param col.line
#' not given
#' @param col.symbol
#' 'groups' not given
#' @param alpha
#' @param alpha.line
#' @param alpha.symbol graphical parameters for superpose.line and
#' superpose.symbol
#' @param len extend the length of parameters by recycling to length 'len'
#' @param long if TRUE generate a default combination of col, lty and pch with
#' length 42.
#' @param record If TRUE, set history to 'recording'. Caution: this can use a
#' lot of memory in .GlobalEnv. Consider adding selected graphs to memory with
#' the 'Insert' key instead.
#' @param basecol
#' @param colsets
#' @param \dots
#' parameter: e.g. \code{plot.symbol=list(cex=2,col='red')}. Particular useful
#' for the cex, col, lty, lwd, alpha, pch parameters in plot.line and
#' plot.symbol.
#' @author Georges Monette
#' @examples
#' td( lty = 1:7) # sets line types for 7 groups
#' gd(7) # sets line types for 7 groups using colors from RColorBrewer
#' td( plot.symbol = list(col = 'red', pch = 17))
#' gd_(col='blue') # set main color to 'blue'
#' @describeIn td
#' @export
td <- function(
new = FALSE,
col=c("#0080ff", "#ff00ff", "darkgreen", "#ff0000" , "orange" , "#00ff00", "brown" ),
lty=1:7, lwd=1,
pch = 1:7, cex = 0.8, font = 1,
long = FALSE,
# record = FALSE, # not supported in RStudio
basecol = NULL,
colsets = c('plot.symbol','plot.line','dot.symbol',
'dot.line','cloud.3d','box.dot'),
...) {
# Modified for R: Oct. 10, 2004
#
# reset superpose.symbol and superpose.line so they have consistent length
# equal to the max of input parameters:
# sps: cex, col, font, pch
# spl: lty, col, lwd
# or to len
# This allows distinctive line styles, for example for 12 objects by using
# good lty's: 1,4,8,6,3,5,7
# and good col's: 1,8,6,3,4,5,2
#
require(lattice)
aargs <- list(...)
if ( long ) {
col <- c(3,5,4,6,8,2) # drop yellow
len <- 42 # generates 42 unique combinations of pch/lty and col
}
if(new) trellis.device(theme = col.whitebg, record = record, new = new)
# NOTE: fixed panel.superpose so lty argument
# is passed to points for type = 'b'
len <- max(len,length(col),length(lty),length(lwd),length(pch),length(cex),length(font))
spl <- trellis.par.get("superpose.line")
spl$alpha <- rep(alpha.line, length = len)
spl$lty <- rep(lty,length=len)
spl$col <- rep(col.line,length=len)
spl$lwd <- rep(lwd,length=len)
trellis.par.set("superpose.line",spl)
sps <- trellis.par.get("superpose.symbol")
sps$alpha <- rep( alpha.symbol, length = len)
sps$pch <- rep(pch, length=len)
sps$col <- rep(col.symbol, length=len)
sps$cex <- rep(cex, length=len)
sps$font <- rep(font, length=len)
sps$fill <- rep(fill, length=len)
trellis.par.set("superpose.symbol",sps)
list(superpose.symbol = sps, superpose.line = spl)
if ( !is.null(basecol)) {
for ( ii in colsets ) {
tt <- trellis.par.get(ii)
tt$col <- basecol
trellis.par.set(ii,tt)
}
}
if ( length(aargs)){
tpg <- trellis.par.get()
for ( nn in names(aargs)){
for(mm in names(aargs[[nn]])){
tpg[[nn]][[mm]] <- aargs[[nn]][[mm]]
}
}
trellis.par.set(theme = tpg)
}
ret <- trellis.par.get()
invisible(ret[grep('superpose',names(ret))])
}
#' @describeIn td uses a ggplot-like theme
#' @param n number of groups for which to set colors, line types, etc. using RColorBrewer.
#' @examples
#' # - setting colors for groups, i.e. 'superpose.symbol' in trellis.par.get():
#' gd(5) # where 5 is the number of groups
#' gd(5, lwd = 2, lty = 1)
#' gd(5, col = brewer.pal(5,"Dark2"),cex = 1.5)
#'
#' # To set colors with no groups
#' gd_(col='tomato4')
#' # changing the default color for lines and symbols
#' gd(plot.line=list(col='red',lwd=2),
#' plot.symbol=list(col='blue', cex = 1.3))
#' # OR using superpose = FALSE
#' gd(superpose = FALSE, col = 'red', lwd = 2)
#' # OR using the utility function:
#' gd_(col = 'red', lwd = 2)
#' #
#' # For a complete list of elements that can be changed:
#' names(trellis.par.get())
#' # For a list of colors
#' colors()
#' grepv('pink',colors()) # types of pink
#' # Using magrittr
#' library(magrittr)
#' colors() %>% grepv('blue', .) %>%
#' pal %>%
#' as.data.frame %>%
#' sortdf( ~ red) %>%
#' as.matrix %>%
#' divide_by(255) %>%
#' rgb %>%
#' pal
#' @export
gd <-
function (n=9,
col = brewer.pal(n,"Set1"), lty = 1:n, lwd = 1,
pch = 19, cex = 1.4, font = 1, fill = "transparent",
col.line = col, col.symbol = col,
alpha = 1, alpha.line = alpha, alpha.symbol = alpha,
len = n,
# arguments to ggplot2like:
h = c(0,360) + 15, l =65, c = 100, h.start = 0, direction = 1,
low = "#3B4FB8", high = "#B71B1A", space = "rgb",
# trellis par set parameters for basecol:
basecol = NULL,
colsets = c("plot.symbol","plot.line", "dot.symbol",
"dot.line", "cloud.3d", "box.dot"),
# set ggplot2 like environment even if not first call
superpose = TRUE,
gginit = FALSE,
# other arguments of form:
# plot.symbol = list( col = 'red', pch = 4)
...)
{
# gd makes it easy to set graphical parameters,
# i.e. col, lwd, lty, fill, font, cex, pch, alpha
# for 'superpose.symbol' and 'superpose.line' used
# for different groups in lattice
# Note: fill works with pch 21:25
#
# gd can also be used to set other graphical parameters
# by specifying the list in which they are set
# (see trellis.par.get()). For example to reset
# symbol colors and line colors:
# gd(
# Usage:
library(lattice)
library(latticeExtra)
library(RColorBrewer)
aargs <- list(...)
# ggplot2
if(is.null(lattice.options('gginit')[[1]]) | gginit == TRUE){
lattice.options(gginit=TRUE)
trellis.par.set(ggplot2like(n = n,h = h,l = l,c = c,
h.start = h.start, direction = direction,
low = low , high = high , space = space))
lattice.options(ggplot2like.opts())
}
len <- max(len, length(col), length(lty), length(lwd), length(pch),
length(cex), length(font))
if (superpose ) {
spl <- trellis.par.get("superpose.line")
spl$alpha <- rep(alpha.line, length = len)
spl$lty <- rep(lty, length = len)
spl$col <- rep(col.line, length = len)
spl$lwd <- rep(lwd, length = len)
trellis.par.set("superpose.line", spl)
sps <- trellis.par.get("superpose.symbol")
sps$alpha <- rep(alpha.symbol, length = len)
sps$pch <- rep(pch, length = len)
sps$col <- rep(col.symbol, length = len)
sps$cex <- rep(cex, length = len)
sps$font <- rep(font, length = len)
sps$fill <- rep(fill, length = len)
trellis.par.set("superpose.symbol", sps)
} else { # use to set non-panel setting
tt <- trellis.par.get()
if ( !missing(col) ) {
tt$plot.symbol$col <- col.symbol
tt$plot.line$col <- col.line
}
if ( !missing(col.line)) {
tt$plot.line$col <- col.line
}
if ( !missing(col.symbol)) {
tt$plot.symbol$col <- col.symbol
}
if ( !missing(alpha) ) {
tt$plot.symbol$alpha <- alpha.symbol
tt$plot.line$alpha <- alpha.line
}
if ( !missing(alpha.line)) {
tt$plot.line$alpha <- alpha.line
}
if ( !missing(alpha.symbol)) {
tt$plot.symbol$alpha <- alpha.symbol
}
if ( !missing(lty)) {
tt$plot.line$lty <- lty
}
if ( !missing(lwd)) {
tt$plot.line$lwd <- lwd
}
if ( !missing(pch)) {
tt$plot.symbol$pch <- pch
}
if ( !missing(cex)) {
tt$plot.symbol$cex <- cex
}
if ( !missing(fill)) {
tt$plot.symbol$fill <- fill
}
trellis.par.set(theme = tt)
}
if (!is.null(basecol)) {
for (ii in colsets) {
tt <- trellis.par.get(ii)
tt$col <- basecol
trellis.par.set(ii, tt)
}
}
if (length(aargs)) {
tpg <- trellis.par.get()
for (nn in names(aargs)) {
for (mm in names(aargs[[nn]])) {
tpg[[nn]][[mm]] <- aargs[[nn]][[mm]]
}
}
trellis.par.set(theme = tpg)
}
ret <- trellis.par.get()
invisible(ret[grep("superpose", names(ret))])
}
#' @describeIn td gd to set non-group parameters
#' @export
gd_ <- function(...) gd(superpose = FALSE, ...)
###
### xqplot
###
#' Extended Quantile Plots
#'
#' An easy way to see a dataset's variables at a glance. Shows uniform quantile
#' plot for numerical varibles and barcharts for factors. Quantile plots also
#' show a horizontal line at the position of the mean and at mean plus or minus
#' one standard deviation.
#'
#' @param x a data frame or list of variables to plot
#' @param ptype "quantile" (default) or "normal": kind of quantile to plot on x
#' axis.
#' @param labels names for each plot
#' @param \dots additional arguments passed to 'plot' command
#' @param mfrow number of rows and columns per page. If missing, an attempt is
#' made to choose a reasonable number.
#' @param ask
#' @param mcex character expansion factor for marginal text
#' \code{mcex}
#' @param maxlab maximum number of categories to label in barcharts
#' @param debug if TRUE, print additional information
#' @param mar size of margins
#' @param text.cex.factor character expansion factor for barchart labels
#' @param left.labs determines placement of barchart labels
#' @param maxvarnamelength maximum length of variable name without splitting on
#' two lines.
#' @note Bugs:
#' 'mfrow' should take the total number of variables into account if they will
#' fill more than one page so the last page is close to being full.
#'
#' The current version of the function could be made much simpler and more
#' transparent. Some code is redundant.
#' @examples
#' require(car)
#' xqplot(Prestige)
#' xqplot(Prestige,"n") # normal quantiles
#' @export
xqplot <- function(x,
ptype = "quantile",
labels = dimnames(x)[[2]], ...,
mfrow = findmfrow ( ncol(x)),
ask = prod(mfrow) <
ncol(x) && dev.interactive(),
mcex = 0.8, maxlab = 12 , debug = F,
mar = c(5,2,3,1),
text.cex.factor = 1 ,
left.labs = F,
maxvarnamelength = 20)
{
## Adapted from myplot.data.frame for R by G. Monette, Oct. 25, 2004
## maxlab is maximum number of labels
# Turn matrices into variables:
if (! is.list(x)) x <- as.data.frame(x)
if ( any ( sapply( x, class) == 'matrix') ) {
zz <- list()
for ( ii in seq_along( x )) {
if ( is.matrix( x[[ii]])) {
if ( is.null (colnames( x[[ii]]))) {
cnames <- paste( names(x)[ii], 1:ncol(x[[ii]]), sep ='.')
} else {
cnames <- paste( names(x)[ii], colnames(x[[ii]]), sep = '.')
}
for ( jj in seq_len( ncol ( x[[ii]]))) {
zz[[cnames[jj] ]] <- x[[ii]][,jj]
}
} else {
zz[[ names(x)[[ii]] ]] <- x[[ii]]
}
}
x <- as.data.frame(zz)
#disp( x )
}
left.labs <- rep( left.labs, length = length(x))
findmfrow <- function( x ) {
if ( x > 9) c(3,4)
else cbind( '1'=c(1,1),'2'=c(1,2),'3'=c(2,2),
'4'=c(2,2),'5'=c(2,3),'6'=c(2,3),
'7'=c(3,3), '8'=c(3,3), '9'=c(3,3)) [, x]
}
opt <- par( mfrow = mfrow, ask = ask , mar = mar + 0.1 )
on.exit(par(opt))
if(debug) { cat("opt:\n");print(opt)}
iscat <- function( x ) is.factor(x) || is.character(x)
Levels <- function(x) {
if ( is.factor(x)) levels(x) else unique(x)
}
compute.cex <- function( x ) {
ll <- length(x)
cex <- 2 * ifelse( ll < 5, 2,
ifelse( ll < 10, 1,
ifelse( ll < 20, .7, .5)))/mfrow[1]
}
for ( ii in 1: dim(x)[2]) {
vv <- x[[ii]]
nam <- labels[[ii]]
Nmiss <- sum(is.na(vv))
N <- length(vv)
if ( iscat(vv) ){
tt <- table(vv)
xlab <- paste("N =", N )
if ( Nmiss > 0 ) {
tt <- c( "<NA>" = sum(is.na(vv)), tt)
xlab <- paste(xlab, " Nmiss =", Nmiss)
}
ll <- names(tt)
nn <- length(ll)
if ( left.labs[ii] ) barplot( tt, horiz = TRUE,
xlab = xlab,
cex.names = text.cex.factor * compute.cex(nn) )
else {
zm <- barplot( tt, names = rep("",nn), horiz = TRUE, xlab = xlab)
## If nn > maxlab drop labels for smaller frequencies
sel <- rep( T, length(tt))
tt.sorted <- rev(sort(tt))
if ( nn > maxlab ) sel <- tt > tt.sorted[maxlab]
if (debug) {
disp(sel)
disp(nam)
disp(tt)
disp(tt.sorted)
disp(maxlab)
disp(tt.sorted[maxlab])
disp(sel)
disp(zm[sel])
disp(rep(max(tt),nn)[sel])
disp( ll[sel])
}
if ( any(sel) ) text( rep( max( tt ), nn)[sel] ,
zm[sel], ll[sel], adj = 1, cex = text.cex.factor * compute.cex( nn ))
}
} # end of iscat(vv)
else {
sublab <- ""
N <- length( vv )
Ninfinite <- 0
if ( any( is.infinite ( vv ) ) ){
n.pi <- sum( vv == Inf , na.rm = TRUE)
n.ni <- sum( vv == -Inf, na.rm = TRUE )
Ninfinite <- n.pi + n.ni
vv <- vv[!is.infinite(vv)]
sublab <- paste( sublab,"-Inf:",n.ni,"+Inf:",n.pi)
}
Nmiss <- 0
if ( any ( is.na( vv ) )) {
Nmiss <- sum( is.na(vv) )
vv <- vv[!is.na(vv)]
sublab <- paste( sublab, "NA:", Nmiss)
}
Nok <- N - Nmiss - Ninfinite
if ( pmatch( ptype, 'normal', nomatch = 0) == 1 ) {
xxvar <- qnorm( ppoints(length(vv)) )
xlab <- paste("Normal quantile for", Nok, "obs.")
}
else {
xxvar <- ppoints( length(vv) )
xlab <- paste("Fraction of", Nok, "obs.")
}
## Plot continuous
if ( Nok == 0 ) {
xxvar <- 1
vv <- 1
if ( sublab == "") {
plot( xxvar, vv, xlab = xlab, ylab="", type = 'n')
} else {
plot( xxvar, vv, xlab = xlab, ylab="", type = 'n', sub = sublab)
}
text( 1, 1, "NA")
}
else {
if ( sublab == "") {
plot(xxvar, sort(vv), xlab = xlab, ylab = "Data", ...)
} else {
plot(xxvar, sort(vv), xlab = xlab, ylab = "Data", ..., sub = sublab)
}
xm <- mean(vv)
xs <- sqrt(var(vv))
abline( h= xm,lty=1)
abline( h= c(xm-xs,xm+xs),lty=2)
}
}
## Titles for all plots
vlab <- labels[ii]
line.offset <- 1.0
if ( nchar( vlab ) > maxvarnamelength) {
vlab <- paste( substring(vlab,1,maxvarnamelength), "\n",substring(vlab, maxvarnamelength + 1))
line.offset <- 0.2
}
mtext(vlab, 3, line.offset , cex = mcex)
}
# par(opt)
if(debug) { disp(par()) }
invisible(0)
}
#' Show available characters, colours, etc.
#'
#' @param n
#' @export
sampler <-
function( n=24 ) {
# sample of lines and symbols
old.par <- par(ask=T)
on.exit( par(old.par))
require(lattice)
y <- 0:n
x <- 0:n
print(xyplot( y ~ x, type = 'n', xlab = 'lty', ylab = 'col',
panel = function(x,y,...) {
for ( i in x) {
panel.xyplot(c(i,i),range(y),type='l',lty=i,col=1,lwd = 3)
}
for ( i in y) {
for ( j in seq(0,.9, by = .1)) {
panel.xyplot(c(min(x)+ j*(max(x)-min(x)),min(x)+ (j+.1)*(max(x)-min(x))),c(i,i),type='l',lty=1,col=i, lwd = 3)
}
}
}))
# print(z$x, z$y, ylim=c(0,7))
spl <-trellis.par.get('superpose.line')
z <- expand.grid( y = 1:length(spl$lty), x = 0:2)
print(xyplot( y ~ x , z, ylim =c(0,length(spl$lty)),groups = y, type='b',
main="superpose.line and .symbol"))
y <- 10*(0:25)
x <- 0:9
print(xyplot( y ~ x, type = 'n', main = 'pch',
xlab = expression( ~ alpha + beta + gamma + delta[epsilon] + zeta^eta + theta + iota+kappa),
ylab = expression( ~ lambda + mu + nu + xi + omicron + pi + rho + sigma + tau + upsilon + phi + chi +psi + omega),
panel = function(x,y,...) {
for ( i in x) {
for ( j in y ) {
panel.xyplot(i,j,pch=i+j,cex = 2)
}
}
}))
invisible(0)
}
#' Generate a palette of colours -- possibly superseded
#'
#' @param col colors to show
#' @param border (default 'light gray')
#' @param \dots
#' @export
pal <- function(col=c('blue','pink'), border = "light gray", ...) {
n <- length(col)
plot(0, 0, type = "n", xlim = c(0, 1), ylim = c(0, 1), axes = FALSE,
xlab = "", ylab = "", ...)
rect(0, 0:(n - 1)/n, .6, 1:n/n, col = col, border = border)
ret <- col2rgb(col)
dimnames(ret)[[2]] <- col
ret <- t(ret)
txt <- paste( as.character(col), "(",
apply( ret, 1, paste, collapse=" "), ")")
text( rep(.6, n), (0:(n-1)+.5)/n, txt, adj = 0)
ret <- col2rgb(col)
dimnames(ret)[[2]] <- col
t(ret)
}
#' Display colors n at a time
#'
#' @param pp
#' @export
pals <- function(pp=30){
n <- length(cc <- colors())
ii <- 1
while( ii < n ){
pal(cc[ii:min(ii+pp,n)], ask = TRUE)
ii <- ii + pp + 1
}
}
## brace() now moved to brace.R
#' Replace elements of x with correspondingly named elements of ll
#'
#' @param x
#' @param ll
#' @export
change <- function(x,ll) {
#
# Modifies elements in a list
# Ideal for changing ... arguments in calls to panel.groups etc.
#
nams <- names(ll)
for ( ii in seq_along(ll) ) {
x[[nams[ii]]] <- ll[[ii]]
}
x
}
#' Panel function to display subgroups within groups within panels
#'
#' This function is designed to be used as the argument to \code{panel.groups}
#' in \code{xyplot}. It effectively adds another level of subgrouping to that
#' implemented by the \code{groups} argument in \code{xyplot}. Useful mainly
#' to display data and fitted lines in groups within panels.
#'
#' This function is designed to be used as the argument to 'panel.groups' in
#' 'xyplot'. It allows the plotting of points versus lines within subgroups of
#' the data identified by the 'groups' argument in xyplot. It requires a
#' variable to identify the subgroups. Points or lines are used within
#' subgroups depending on 'subgroups.type' where the order is that of the
#' levels of the 'subgroups' argument coerced as a factor, if necessary. See
#' the examples below.
#'
#' @param x,y coordinates of the points to be displayed
#' @param subscripts subscripts giving indices in original data frame
#' @param subgroups a subgrouping variable. Use a full reference, e.g.
#' data$subvar
#' @param subgroups.type plotting type, typically 'p' or 'l', for each level of
#' the variable passed through the \code{subgroups} argument
#' @param type
#' @param panel.subgroups function use to plot data within in each group
#' referring to the levels of the variable passed by \code{subgroups}. Define
#' a \code{panel.subgroups} argument in the call to \code{xyplot} and it will
#' be used to plot the groups. See the examples below.
#' @param \dots any other arguments to be passed to the panel plotting function
#' @seealso \code{link[lattice]{panel.superpose}},
#' \code{link[lattice]{panel.superpose.2}}, \code{link[lattice]{panel.xyplot}}
#' @examples
#' \dontrun{
#' library(car)
#' data(Prestige)
#' fit <- lm( prestige ~ (education +I(education^2)) * type, Prestige, na.action = na.omit)
#' pred <- expand.grid( education = seq( 6, 18, .5), type = levels( Prestige$type))
#' pred$prestige <- predict( fit, newdata = pred )
#'
#' Prestige$what <- 'data'
#' pred$what <- 'fit' # this works because 'fit' follows 'data' lexicographically
#'
#' combined <- merge( Prestige, pred, all = T)
#'
#' xyplot( prestige ~ education, combined,
#' groups = type,
#' subgroups = combined$what, # note that a full reference to the variable is needed
#' panel = panel.superpose, # might not be necessary in future version of lattice
#' panel.groups = panel.subgroups) # uses the default of points for the first level of 'what'
#' # and lines for the second level
#'
#' ## Using the argument 'panel.subgroups' instead of the default 'panel.xyplot'
#' ## Note that panel.subgroups is a function (this one) and also an argument that
#' ## is a function passed to the function. The argument defines the action to
#' ## be taken within each level of 'what'
#'
#' xyplot( prestige ~ education, combined,
#' groups = type,
#' subgroups = combined$what, # note that a full reference to the variable is needed
#' panel = panel.superpose, # might not be necessary in future version of lattice
#' panel.groups = panel.subgroups,
#' panel.subgroups = function( x, y, subgroup, type, ...) {
#' # note that you need to include 'type' among the arguments
#' # if you need to prevent it from being passed through '...'
#' # When called, this function will be passed arguments
#' # subgroup, subgroup.number, subscripts, and type from
#' # subgroups.type.
#' if ( subgroup == 'data' ) {
#' panel.xyplot( x, y, ...)
#' panel.lines( dell(x,y), ...)
#' } else {
#' panel.lines( x,y, ...)
#' }
#' })
#' }
#' @export
panel.subgroups <- function( x, y, subscripts,
subgroups, subgroups.type = c('p','l'),type,
panel.subgroups = panel.xyplot, ...) {
help = "Use help: ?panel.subgroups"
subgroups <- as.factor(subgroups)
levs <- levels(subgroups)
subgroups.type <- rep( subgroups.type, length.out = length(levs))
subgroups = subgroups[subscripts]
for ( i in seq_along( levs) ) {
sel <- subgroups == levs[i]
if ( any( sel )) {
panel.subgroups( x[sel], y[sel], type = subgroups.type[i],
subscripts = subscripts[sel], subgroup.number = i,
subgroup = levs[i], ...)
}
}
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.