#' Contour Plot
#'
#' Produces a contour plot or a colored surface with colors corresponding to
#'values in \code{z}.
#'
#' @details Missing values are permitted in \code{z}, \code{x}, and \code{y} for the default
#'method and are removed, with a warning. before constructing the surface. Duplicated values,
#'identical \code{x} and \code{y}, are not permitted and generate an error.
#'
#'Missing values are not permitted in \code{rows} or \code{columns} but are permitted
#'in \code{z} for the matrix method. Missing values in \code{z} result in blank areas
#'in the plot.
#'
#'The \code{Grid} argument must be a tagged list with these components:
#'\describe{
#'\item{method}{The method to use for constructung the grid. Must be either "interpolate"
#'or "loess." If "interpolate," then the \code{z} values are interpolated directly from the
#'\code{x} and \code{y} values. If "loess," then the \code{z} values are smoothed prior to
#'interpolation}
#'\item{linear}{Logical, if \code{TRUE}, then use linear interpolation, if \code{FALSE}, then
#'use spline interpolation.}
#'\item{extrapolate}{Logical, if \code{TRUE}, then extrapolate to the limits of the grid, if
#'\code{FALSE}, then do not extrapoalte outsite of the hull of the data values.}
#'\item{density}{The density of the grid---the number of cells along \code{x} and \code{y}.}
#'\item{span}{The \code{span} argument for \code{loess} if \code{method} is "loess." }
#'\item{degree}{The \code{degree} argument for \code{loess} if \code{method} is "loess."}
#'\item{family}{}The \code{family} argument for \code{loess} if \code{method} is "loess."
#'}
#'
#'#'The \code{Contour} argument must be a tagged list with these components:
#'\describe{
#'\item{name}{The name to use to describe the contours. If "Auto" and \code{filled} is
#'\code{TRUE}, then the descripotion is blank. If "Auto" and \code{filled} is \code{FALSE},
#'the the description is Line of equal value." In all other cases, the description is the
#'text assigned to \code{name}.}
#'\item{levels}{Either the number of levels of contours or a vector of the desired contour
#'levels.}
#'\item{filled}{Logical, if \code{TRUE}, then draw filled contours, if \code{FALSE}, then
#'only contour lines are drawn.}
#'\item{lineColor}{The color to draw the contour lines. Can be set to "none" to supress
#'drawing lines for filled contours.}
#'\item{lineLabel}{A character string indicating how to draw the labels on the contours. May be
#'"none" to supress draing the labels, or any valid value for the \code{method} argument
#'to \code{\link{contour}}.}
#'\item{fillColors}{The prefix corresponding to a color ramp generating function, like "warmCool"
#'for the \code{\link{warmCool.colors}} function.}
#'}
#' @aliases contourPlot contourPlot.default contourPlot.matrix
#' @param z the values representing the surface data.
#' @param x the x-axis coordinates for each value in \code{z}.
#' @param y the y-axis coordinates for each value in \code{z}.
#' @param rows the coordinates for \code{z} represented by the rows in the matrix.
#' @param cols the coordinates for \code{z} represented by the columns in the matrix.
#' @param matrix.rows a single character, either "x" or "y" indicating whether the rows in z should be
#'plotted along the x or y axis.
#' @param Grid control parameters for gridding irregularly spaced data. See \bold{Details}.
#' @param Contours control parameters for the coutour lines or levels in the filled plot.
#'See \bold{Details}.
#' @param yaxis.range set the range of the y-axis.
#' @param xaxis.range set the range of the x-axis.
#' @param ylabels set up y-axis labels. See \code{\link{linearPretty}} for details.
#' @param xlabels set up x-axis labels. See \code{\link{linearPretty}} for details.
#' @param xtitle the x-axis title (also called x-axis caption).
#' @param ytitle the y-axis title (also called y-axis caption).
#' @param caption the figure caption.
#' @param margin set the plot area margins, in units of lines of text. Generally
#'all NA or the output from \code{setGraph} if appropriate.
#' @param \dots not used, required for other methods.
#' @return Information about the graph.
#' @importFrom akima interp
#' @examples
#' \dontrun{
#' set.seed(1)
#' Xbig <- runif(100)
#' Ybig <- runif(100)
#' # Make a hill
#' Zbig <- 1 - ((Xbig-.5)^2 + (Ybig-.5)^2)^.75
#' setGD()
#' contourPlot(Zbig, Xbig, Ybig)
#' # See for examples of contourPlot see
#' vignette(topic="GraphGallery", package="smwrGraphs")
#' }
#' @export contourPlot
contourPlot <- function(z, ...)
UseMethod("contourPlot")
# Coding history:
# 2011Jun21 DLLorenz Initial coding
# 2013Mar08 DLLorenz Completed and added option for x to be of class "Date"
# 2013Apr09 DLLorenz Added setGD
# 2014Jun25 DLLorenz Converted to roxygen
#' @rdname contourPlot
#' @export
#' @method contourPlot default
## The "default" method--numeric z with x and y coordinates
contourPlot.default <- function(z, x, y, # data specs
Grid=list(method="interpolate",
linear=TRUE, extrapolate=FALSE, density=90, # interp options
## Loess options
span=0.75, degree=1, family="symmetric"), # Grid
Contours=list(name="Auto",
levels=10,
filled=FALSE,
lineColor="black",
lineLabel="flattest",
fillColors="coolWarm"), # Contour controls
yaxis.range=c(NA,NA), # y-axis controls
xaxis.range=c(NA,NA), # x-axis controls
ylabels=4, xlabels=4, # axis labels
xtitle=deparse(substitute(x)),
ytitle=deparse(substitute(y)), # axis titles
caption="",# caption
margin=c(NA, NA, NA, NA), ...) { # margin control
##
## Set up the axes titles
xtitle=xtitle # needed to 'set' names
ytitle=ytitle
## Process the z data: create a matrix from irregular x, y data
## Force defaults in Grid
Grid <- setDefaults(Grid, method='interpolate',
linear=TRUE, extrapolate=FALSE, density=90,
span=0.75, degree=1, family='symmetric')
## Remove missings
Bad <- is.na(x) | is.na(y) | is.na(z)
if(any(Bad)) {
warning(sum(Bad), " missing value(s) removed")
x <- x[!Bad]
y <- y[!Bad]
z <- z[!Bad]
}
## To maintain a consistent scale in x and y scale to a common range
## Map xax$range[1] to 0 and xax$range[2] to 10
## Note numeric conversion required for dates, recovered below
xrng <- as.double(range(x))
yrng <- range(y)
xs <- scaleRng(as.double(x), Min=0, Max=10, x.range=xrng)
ys <- scaleRng(y, Min=0, Max=10, x.range=yrng)
if(Grid$method == "loess") # Create a smooth surface first
z <- fitted(loess(z ~ xs + ys, span=Grid$span, degree=Grid$degree,
family=Grid$family, normalize=F))
xo <- seq(0, 10, length=Grid$density)
yo <- seq(0, 10, length=Grid$density)
zo <- interp(xs, ys, z, xo=xo, yo=yo, linear=Grid$linear,
extrap=Grid$extrapolate)$z
## Scale xo and y back to real-world units
xo <- as.vector(scaleRng(xo, Min=xrng[1], Max=xrng[2], x.range=c(0,10)))
yo <- as.vector(scaleRng(yo, Min=yrng[1], Max=yrng[2], x.range=c(0,10)))
# Convert Date like x to Date
if(class(x) == "Date")
xo <- as.Date(xo, origin=as.Date("1970-01-01"))
else if(inherits(x, "POSIXt"))
xo <- as.Date(as.POSIXct(xo, origin=as.POSIXct("1970-01-01")))
## Call the matrix version to create the plot
invisible(contourPlot.matrix(zo, xo, yo, Contours=Contours,
yaxis.range=yaxis.range, xaxis.range=xaxis.range,
ylabels=ylabels, xlabels=xlabels,
xtitle=xtitle, ytitle=ytitle,
caption=caption, margin=margin))
}
#' @rdname contourPlot
#' @export
#' @method contourPlot matrix
contourPlot.matrix <- function(z, rows, cols, matrix.rows="x", # data specs
Contours=list(name="Auto",
levels=10,
filled=FALSE,
lineColor="black",
lineLabel="flattest",
fillColors="coolWarm"), # Contour controls
yaxis.range=c(NA,NA), # y-axis controls
xaxis.range=c(NA,NA), # x-axis controls
ylabels=4, xlabels=4, # axis labels
xtitle=deparse(substitute(x)),
ytitle=deparse(substitute(y)), # axis titles
caption="",# caption
margin=c(NA, NA, NA, NA), ...) { # margin control
## Set up the matrix and axes
xtitle <- xtitle # needed to 'set' names
ytitle <- ytitle
roworder <- order(rows)
colorder <- order(cols)
z <- z[roworder, colorder] # just in case
if(dev.cur() == 1)
setGD("ContourPlot")
if(matrix.rows == "x") {
x <- rows[roworder]
y <- cols[colorder]
}
else {
y <- rows[roworder]
x <- cols[colorder]
z <- t(z) # transopose to rows as x
}
if(is.list(ylabels))
yax <- c(list(data=y, axis.range=yaxis.range, axis.log=FALSE,
axis.rev=FALSE), ylabels)
else
yax <- list(data=y, axis.range=yaxis.range, axis.log=FALSE,
axis.rev=FALSE, axis.labels=ylabels)
yax$extend.range <- FALSE
yax <- do.call("setAxis", yax)
y <- yax$data
yax <- yax$dax
if(is.list(xlabels))
xax <- c(list(data=x, axis.range=xaxis.range, axis.log=FALSE,
axis.rev=FALSE), xlabels)
else
xax <- list(data=x, axis.range=xaxis.range, axis.log=FALSE,
axis.rev=FALSE, axis.labels=xlabels)
xax$extend.range <- FALSE
xax <- do.call("setAxis", xax)
x <- xax$data
xax <- xax$dax
## Set margins and controls
margin.control <- setMargin(margin, yax)
margin <- margin.control$margin
right <- margin.control$right
top <- margin.control$top
left <- margin.control$left
bot <- margin.control$bot
par(mar=margin)
## Set up the plot
plot(range(x), range(y), type='n', xlim=xax$range, xaxs='i', axes=F,
ylim=yax$range, yaxs='i', ylab="", xlab="")
## Force defaults for the coutours
## If filled is TRUE and lineColor is not set, then set the line color
## to "none"
if(!is.null(Contours$filled) && Contours$filled &&
is.null(Contours$lineColor))
Contours$lineColor <- "none" # This overrides the following call
Contours <- setDefaults(Contours, name="Auto", levels=10,
filled=F, lineColor="black", lineLabel="flattest",
fillColors="coolWarm")
# Set line weigth automatically
if(Contours$lineColor != "black") {
Contours$lineWt <- lineWt("color")
lineWid <- "color"
} else {
Contours$lineWt <- lineWt("standard")
lineWid <- "standard"
}
## Process levels if necessary
if(length(Contours$levels) == 1)
Contours$levels <- pretty(range(z, na.rm=TRUE), Contours$levels)
## Make a very dense grid (50 lines per inch) if filled is requested
if(Contours$filled) {
usr <- par("usr")
den <- (c(usr[2] - usr[1], usr[4] - usr[3])/ par("pin")) / 72
xrng <- range(x)
yrng <- range(y)
grd <- expand.grid(x=x, y=y)
grd$z <- as.vector(z)
grd <- na.omit(grd)
xyz <- interp(grd$x, grd$y, grd$z, xo=seq(xrng[1], xrng[2], by=den[1]),
yo=seq(yrng[1], yrng[2], by=den[2])) # accept other defaults
## reconstruct x, y, and z
x <- xyz$x
y <- xyz$y
z <- xyz$z
## set up for image and do it
Colors <- get(paste(Contours$fillColors, "colors", sep='.'))
Contours$fillColors <- Colors(length(Contours$levels) - 1)
image(x, y, z, col=Contours$fillColors, add=TRUE,
breaks=Contours$levels)
} # end of filled
## Get contours for return
xyz <- contourLines(x, y, z, levels=Contours$levels)
par(family="USGS")
if(Contours$lineColor != "none") # OK, draw lines
contour(x, y, z, levels=Contours$levels,
drawlabels=Contours$lineLabel != "none", labcex=0.75,
method=ifelse(Contours$lineLabel == "none", "flattest", Contours$lineLabel),
col=Contours$lineColor, lwd=Contours$lineWt, add=TRUE)
## Finish
box(lwd=frameWt())
## label the axes
renderY(yax, lefttitle=ytitle, left=left, right=right)
renderX(xax, bottitle=xtitle, bottom=bot, top=top, caption=caption)
## Need explantion
if(Contours$filled) {
zvalues <- matrix(Contours$levels[-1L] - diff(Contours$levels)/2, nrow=1)
fillcol <- Contours$fillColors
breaks <- Contours$levels
xvals <- c(.1, .35)
yvals <- seq(to=.5, by=-.25, length.out=length(breaks)) # offset from top
linecol <- Contours$lineColor
name <- Contours$name
if(name == "Auto")
name <- ""
contour <- list(zvalues=zvalues, fillcol=fillcol, breaks=breaks, xvals=xvals,
yvals=yvals, linecol=linecol, name=name, linewt=Contours$lineWt)
explan <- list(contour=contour)
}
else { # Simple explanation
name <- if(Contours$name == "Auto") "Line of equal value" else Contours$name
Plot <- setPlot(list(), name=name, what="lines", type="solid",
width=lineWid, symbol="circle", filled=TRUE,
size=0.09, Contours$lineColor) # force defaults if not set
explan <- setExplan(Plot) # add info to set up explanation
}
invisible(list(xyz=xyz, yaxis.log=FALSE, yaxis.rev=FALSE,
xaxis.log=FALSE, explanation=explan, margin=margin,
yax=yax, xax=xax))
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.