I'm a beginner in coding. I was trying to create an interaction plot. Here's my code:
data is clinicaltrials from the data of the book "Learning Statistics with R."
library(sciplot)
library(lsr)
library(gplots)
lineplot.CI(x.factor = clin.trial$drug,
response = clin.trial$mood.gain,
group = clin.trial$therapy,
ci.fun = ciMean,
xlab = "Drug",
ylab = "Mood Gain")
and it produces the graph like this:
As can be seen in the graph, the legend box is not within my screen.
Also I tried creating another plot using the following code:
interaction.plot(x.factor = clin.trial$drug,
trace.factor = clin.trial$therapy,
response = clin.trial$mood.gain,
fun = mean,
type = "l",
lty = 1, # line type
lwd = 2, # line width
legend = T,
xlab = "Drug", ylab = "Mood Gain",
col = c("#00AFBB", "#E7B800"),
xpd = F,
trace.label = "Therapy")
For this code, I got the graph like this:
In this graph, the legend does not have labels.
Could anyone help me with these problems regarding legend?
You probably plan to save the plot via RStudio GUI. When you resize the plot window with your mouse, you need to run the code again to refresh the legend dimensions.
However, it's advantageous to use a more sophisticated method, e.g. to save it as a png with fixed dimensions like so:
library("sciplot")
library("lsr")
library("gplots")
png("Plot_1.png", height=400, width=500)
lineplot.CI(x.factor=clin.trial$drug,
response=clin.trial$mood.gain,
group=clin.trial$therapy,
ci.fun=ciMean,
xlab="Drug",
ylab="Mood Gain"
)
dev.off()
png("Plot_2.png", height=400, width=500)
interaction.plot(x.factor=clin.trial$drug,
trace.factor=clin.trial$therapy,
response=clin.trial$mood.gain,
fun=mean,
type="l",
lty=1, # line type
lwd=2, # line width
legend=T,
xlab="Drug", ylab="Mood Gain",
col=c("#00AFBB", "#E7B800"),
xpd=F,
trace.label="Therapy")
dev.off()
The plots are saved into your working directory, check getwd() .
Edit
You could also adjust the legend position.
In lineplot.CI you may use arguments; either by using characters just for x, e.g. x.leg="topleft" or both coordinates as numeric x.leg=.8, y.leg=2.2.
interaction.plot does not provide yet this functionality. I provide a hacked version below. Arguments are called xleg and yleg, functionality as above.
See ?legend for further explanations.
interaction.plot <- function (x.factor, trace.factor, response, fun = mean,
type = c("l", "p", "b", "o", "c"), legend = TRUE,
trace.label = deparse(substitute(trace.factor)),
fixed = FALSE, xlab = deparse(substitute(x.factor)),
ylab = ylabel, ylim = range(cells, na.rm = TRUE),
lty = nc:1, col = 1, pch = c(1L:9, 0, letters),
xpd = NULL, leg.bg = par("bg"), leg.bty = "n",
xtick = FALSE, xaxt = par("xaxt"), axes = TRUE,
xleg=NULL, yleg=NULL, ...) {
ylabel <- paste(deparse(substitute(fun)), "of ", deparse(substitute(response)))
type <- match.arg(type)
cells <- tapply(response, list(x.factor, trace.factor), fun)
nr <- nrow(cells)
nc <- ncol(cells)
xvals <- 1L:nr
if (is.ordered(x.factor)) {
wn <- getOption("warn")
options(warn = -1)
xnm <- as.numeric(levels(x.factor))
options(warn = wn)
if (!anyNA(xnm))
xvals <- xnm
}
xlabs <- rownames(cells)
ylabs <- colnames(cells)
nch <- max(sapply(ylabs, nchar, type = "width"))
if (is.null(xlabs))
xlabs <- as.character(xvals)
if (is.null(ylabs))
ylabs <- as.character(1L:nc)
xlim <- range(xvals)
if (is.null(xleg)) {
xleg <- xlim[2L] + 0.05 * diff(xlim)
xlim <- xlim + c(-0.2/nr, if (legend) 0.2 + 0.02 * nch else 0.2/nr) *
diff(xlim)
}
dev.hold()
on.exit(dev.flush())
matplot(xvals, cells, ..., type = type, xlim = xlim, ylim = ylim,
xlab = xlab, ylab = ylab, axes = axes, xaxt = "n",
col = col, lty = lty, pch = pch)
if (axes && xaxt != "n") {
axisInt <- function(x, main, sub, lwd, bg, log, asp,
...) axis(1, x, ...)
mgp. <- par("mgp")
if (!xtick)
mgp.[2L] <- 0
axisInt(1, at = xvals, labels = xlabs, tick = xtick,
mgp = mgp., xaxt = xaxt, ...)
}
if (legend) {
yrng <- diff(ylim)
if (is.null(yleg))
yleg <- ylim[2L] - 0.1 * yrng
if (!is.null(xpd) || {
xpd. <- par("xpd")
!is.na(xpd.) && !xpd. && (xpd <- TRUE)
}) {
op <- par(xpd = xpd)
on.exit(par(op), add = TRUE)
}
# text(xleg, ylim[2L] - 0.05 * yrng, paste(" ",
# trace.label), adj = 0)
if (!fixed) {
ord <- sort.list(cells[nr, ], decreasing = TRUE)
ylabs <- ylabs[ord]
lty <- lty[1 + (ord - 1)%%length(lty)]
col <- col[1 + (ord - 1)%%length(col)]
pch <- pch[ord]
}
legend(xleg, yleg, legend = ylabs, col = col,
title = if (trace.label == "") NULL else trace.label,
pch = if (type %in% c("p", "b"))
pch, lty = if (type %in% c("l", "b"))
lty, bty = leg.bty, bg = leg.bg)
}
invisible()
}
Data:
lk <- "https://learningstatisticswithr.com/data.zip"
tmp <- tempfile()
tmp.dir <- tempdir()
download.file(lk, tmp)
unzip(tmp, exdir=tmp.dir)
load("data/clinicaltrial.Rdata")
Related
We can get marginal effects of a linear model with margins::margins() and can select variables of interest with option variables.
fit <- lm(mpg ~ factor(vs) + gear:factor(vs) + qsec, mtcars)
library(margins)
marg1 <- margins(fit, variables="vs")
> summary(marg1)
factor AME SE z p lower upper
vs1 4.8023 2.6769 1.7940 0.0728 -0.4443 10.0490
The package has a implemented method plot.margins, so we can plot the marginal effects
plot(marg1)
at allows us to specify the values at which to calculate the marginal effects:
marg2 <- margins(fit, variables="vs", at=list(gear=c(3, 4, 5)))
> summary(marg2)
factor gear AME SE z p lower upper
vs1 3.0000 2.8606 3.3642 0.8503 0.3952 -3.7332 9.4544
vs1 4.0000 5.6849 2.6713 2.1282 0.0333 0.4493 10.9206
vs1 5.0000 8.5093 3.8523 2.2089 0.0272 0.9588 16.0597
However, attempting to plot these specified margins will yield an error:
plot(marg2)
Error in `[.data.frame`(summ, , names(attributes(x)[["at"]]), drop = FALSE) :
undefined columns selected
Since the margins package claims to be "an R-port of Stata's 'margins' command ", I'd expect a plot similar to the one Stata gives:
So, how can we plot the predicted margins when they are specified with at?
edit:
Note that this is not really an ordinary interaction plot, since
with(mtcars[mtcars$gear %in% c(3, 4, 5), ],
interaction.plot(gear, vs, mpg, pch=rep(1, 2), type="b"))
gives a different output:
The error comes from what seems to be a bug in the plot method for objects of class "margins", plot.margins.
This is an attempt to correct it. The changes are in the function body, just execute this or save it in a file "plotmargins.R" and then source("plotmargins.R").
plot.margins <-
function (x, pos = seq_along(marginal_effects(x, with_at = FALSE)),
which = colnames(marginal_effects(x, with_at = FALSE)), labels = gsub("^dydx_",
"", which), horizontal = FALSE, xlab = "", ylab = "Average Marginal Effect",
level = 0.95, pch = 21, points.col = "black", points.bg = "black",
las = 1, cex = 1, lwd = 2, zeroline = TRUE, zero.col = "gray",
...)
{
pars <- list(...)
summ <- summary(x, level = level, by_factor = TRUE)
MEs <- summ[, "AME", drop = TRUE]
lower <- summ[, ncol(summ) - 1L]
upper <- summ[, ncol(summ)]
r <- max(upper) - min(lower)
#--- changes start here
nms <- intersect(names(summ), names(attributes(x)[["at"]]))
at_levels <- unique(summ[, nms, drop = FALSE])
#--- changes end here
n_at_levels <- nrow(at_levels)
if (n_at_levels > 1) {
pos2 <- rep(pos, each = n_at_levels)
pos2 <- pos2 + seq(from = -0.2, to = 0.2, length.out = n_at_levels)
}
else {
pos2 <- pos
}
if (isTRUE(horizontal)) {
xlim <- if ("xlim" %in% names(pars))
xlim
else c(min(lower) - 0.04 * r, max(upper) + 0.04 * r)
ylim <- if ("ylim" %in% names(pars))
xlim
else c(min(pos2) - (0.04 * min(pos2)), max(pos2) + (0.04 *
max(pos2)))
}
else {
xlim <- if ("xlim" %in% names(pars))
xlim
else c(min(pos2) - (0.04 * min(pos2)), max(pos2) + (0.04 *
max(pos2)))
ylim <- if ("ylim" %in% names(pars))
xlim
else c(min(lower) - 0.04 * r, max(upper) + 0.04 * r)
}
if (isTRUE(horizontal)) {
plot(NA, xlim = xlim, ylim = ylim, yaxt = "n", xlab = ylab,
ylab = xlab, las = las, ...)
if (isTRUE(zeroline)) {
abline(v = 0, col = zero.col)
}
points(MEs, pos2, col = points.col, bg = points.bg, pch = pch)
axis(2, at = pos, labels = as.character(labels), las = las)
mapply(function(pos, upper, lower, lwd) {
segments(upper, pos, lower, pos, col = points.col,
lwd = lwd)
}, pos2, upper, lower, seq(max(lwd), 0.25, length.out = length(MEs)))
}
else {
plot(NA, xlim = xlim, ylim = ylim, xaxt = "n", xlab = xlab,
ylab = ylab, las = las, ...)
if (isTRUE(zeroline)) {
abline(h = 0, col = zero.col)
}
points(pos2, MEs, col = points.col, bg = points.bg, pch = pch)
axis(1, at = pos, labels = as.character(labels), las = las)
mapply(function(pos, upper, lower, lwd) {
segments(pos, upper, pos, lower, col = points.col,
lwd = lwd)
}, pos2, upper, lower, seq(max(lwd), 0.25, length.out = length(MEs)))
}
invisible(x)
}
Now your code and the graph.
source("plotmargins.R")
marg2 <- margins(fit, variables = "vs",
at = list(gear = c(3, 4, 5)))
plot(marg2)
I am currently busy with a Vector Autoregressive Analysis in R, using the vars package. I was wondering if the following things are possible:
1) the previous solution for a better fit on the page worked properly, but now with more variables, we have more plots and the layout is screwed again. I already played with some of the win.graph() parameters, but nothing gives me a proper readable solution.
2) The plot(irf(...) function of the vars package gives a one-graph per page output. I was wondering if this is also possible for the plot(fevd() function by adding some extra (unkown to me) parameters options
3) Also, for readability, I would like to color the graphs, plot(fevd() gives an all-kinds-of-gray output, Is it possible to change those colors?
Thank you in advance
Olivier
You will have to modify the plot function for fevd to do what you want. Here's a modified plot.varfevd function that removes all calls to par(). This allows to use layout properly. The lines that have been removed have been commented out (#). I also removed the parameter that asked for confirmation in "single" plots.
plot.varfevd <-function (x, plot.type = c("multiple", "single"), names = NULL,
main = NULL, col = NULL, ylim = NULL, ylab = NULL, xlab = NULL,
legend = NULL, names.arg = NULL, nc, mar = par("mar"), oma = par("oma"),
addbars = 1, ...)
{
K <- length(x)
ynames <- names(x)
plot.type <- match.arg(plot.type)
if (is.null(names)) {
names <- ynames
}
else {
names <- as.character(names)
if (!(all(names %in% ynames))) {
warning("\nInvalid variable name(s) supplied, using first variable.\n")
names <- ynames[1]
}
}
nv <- length(names)
# op <- par(no.readonly = TRUE)
ifelse(is.null(main), main <- paste("FEVD for", names), main <- rep(main,
nv)[1:nv])
ifelse(is.null(col), col <- gray.colors(K), col <- rep(col,
K)[1:K])
ifelse(is.null(ylab), ylab <- rep("Percentage", nv), ylab <- rep(ylab,
nv)[1:nv])
ifelse(is.null(xlab), xlab <- rep("Horizon", nv), xlab <- rep(xlab,
nv)[1:nv])
ifelse(is.null(ylim), ylim <- c(0, 1), ylim <- ylim)
ifelse(is.null(legend), legend <- ynames, legend <- legend)
if (is.null(names.arg))
names.arg <- c(paste(1:nrow(x[[1]])), rep(NA, addbars))
plotfevd <- function(x, main, col, ylab, xlab, names.arg,
ylim, ...) {
addbars <- as.integer(addbars)
if (addbars > 0) {
hmat <- matrix(0, nrow = K, ncol = addbars)
xvalue <- cbind(t(x), hmat)
barplot(xvalue, main = main, col = col, ylab = ylab,
xlab = xlab, names.arg = names.arg, ylim = ylim,
legend.text = legend, ...)
abline(h = 0)
}
else {
xvalue <- t(x)
barplot(xvalue, main = main, col = col, ylab = ylab,
xlab = xlab, names.arg = names.arg, ylim = ylim,
...)
abline(h = 0)
}
}
if (plot.type == "single") {
# par(mar = mar, oma = oma)
# if (nv > 1)
# par(ask = TRUE)
for (i in 1:nv) {
plotfevd(x = x[[names[i]]], main = main[i], col = col,
ylab = ylab[i], xlab = xlab[i], names.arg = names.arg,
ylim = ylim, ...)
}
}
else if (plot.type == "multiple") {
if (missing(nc)) {
nc <- ifelse(nv > 4, 2, 1)
}
nr <- ceiling(nv/nc)
par(mfcol = c(nr, nc), mar = mar, oma = oma)
for (i in 1:nv) {
plotfevd(x = x[[names[i]]], main = main[i], col = col,
ylab = ylab[i], xlab = xlab[i], names.arg = names.arg,
ylim = ylim, ...)
}
}
# on.exit(par(op))
}
Then, you will need short variable names. Pick acronyms if needed.
library(vars)
data(Canada)
colnames(Canada) <-c("name1","name2","name3","name4")
var <- VAR(Canada , p=4 , type = "both")
Using a wide plot window (using win.graph) and using layout (to get the placement of your eight plots), you can get all charts displayed properly. I also changed the colors of the plots as requested. Finally, we are now using single plots as there are no calls to par() which do not sit well with layout().
win.graph(width=15,height=8)
layout(matrix(1:8,ncol=2))
plot.varfevd(fevd(var, n.ahead = 10 ),plot.type = "single", col=1:4)
plot.varfevd(fevd(var, n.ahead = 10 ),plot.type = "single", col=1:4)
I'm trying to achieve a similar plot to this one, using R's native plot command.
I was able to get something similar with the code below, however, I'd like the density polygons to overlap. Can anyone suggest a way to do this?
data = lapply(1:5, function(x) density(rnorm(100, mean = x)))
par(mfrow=c(5,1))
for(i in 1:length(data)){
plot(data[[i]], xaxt='n', yaxt='n', main='', xlim=c(-2, 8), xlab='', ylab='', bty='n', lwd=1)
polygon(data[[i]], col=rgb(0,0,0,.4), border=NA)
abline(h=0, lwd=0.5)
}
Outputs:
I would do it something like the following. I plot the densities in the same plot but add an integer to the y values. To make them overlapping i multiply by a constant factor fac.
# Create your toy data
data <- lapply(1:5, function(x) density(rnorm(100, mean = x)))
fac <- 5 # A factor to make the densities overlap
# We make a empty plot
plot(1, type = "n", xlim = c(-3, 10), ylim = c(1, length(data) + 2),
axes = FALSE, xlab = "", ylab = "")
# Add each density, shifted by i and scaled by fac
for(i in 1:length(data)){
lines( data[[i]]$x, fac*data[[i]]$y + i)
polygon(data[[i]]$x, fac*data[[i]]$y + i, col = rgb(0, 0, 0, 0.4), border = NA)
abline(h = i, lwd = 0.5)
}
(Note: This content was previously edited into the Question and was written by #by0.)
Thanks to #AEBilgrau, I quickly put together this function which works really nicely. Note: you need to play around with the factor fac depending on your data.
stacked.density <- function(data, fac = 3, xlim, col = 'black',
alpha = 0.4, show.xaxis = T,
xlab = '', ylab = ''){
xvals = unlist(lapply(data, function(d) d$x))
if(missing(xlim)) xlim=c(min(xvals), max(xvals))
col = sapply(col, col2alpha, alpha)
if(length(col) == 1) col = rep(col, length(data))
plot(1, type = "n", xlim = xlim, ylim = c(1,length(data) + 2),
yaxt='n', bty='n', xaxt=ifelse(show.xaxis, 'l', 'n'), xlab = xlab, ylab = ylab)
z = length(data):1
for(i in 1:length(data)){
d = data[[ z[i] ]]
lines(d$x, fac*d$y + i, lwd=1)
polygon(d$x, fac*d$y+ i, col=col[i], border=NA)
abline(h = i, lwd=0.5)
}
}
data <- lapply(1:5, function(x) density(rnorm(100, mean = x)))
stacked.density(data, col=c('red', 'purple', 'blue', 'green', 'yellow'), alpha=0.3, show.xaxis=T)
outputs:
I have a scatterplot and wish to color the points by a z value assigned to each point. Then I want to get the legend on the right hand side of the plot to show what colors correspond to what z values using a nice smooth color spectrum.
Here are some x,y,z values you can use so that this is a reproducible example.
x = runif(50)
y = runif(50)
z = runif(50) #determines color of the (x,y) point
I suppose the best answer would be one that is generalized for any color function, but I do anticipate using rainbow()
Translated from this previous question:
library(ggplot2)
d = data.frame(x=runif(50),y=runif(50),z=runif(50))
ggplot(data = d, mapping = aes(x = x, y = y)) + geom_point(aes(colour = z), shape = 19)
If you don't want to use ggplot2 I modified a solution to this provided by someone else, I don't remember who.
scatter_fill <- function (x, y, z,xlim=c(min(x),max(x)),ylim=c(min(y),max(y)),zlim=c(min(z),max(z)),
nlevels = 20, plot.title, plot.axes,
key.title, key.axes, asp = NA, xaxs = "i",
yaxs = "i", las = 1,
axes = TRUE, frame.plot = axes, ...)
{
mar.orig <- (par.orig <- par(c("mar", "las", "mfrow")))$mar
on.exit(par(par.orig))
w <- (3 + mar.orig[2L]) * par("csi") * 2.54
layout(matrix(c(2, 1), ncol = 2L), widths = c(1, lcm(w)))
par(las = las)
mar <- mar.orig
mar[4L] <- mar[2L]
mar[2L] <- 1
par(mar = mar)
# choose colors to interpolate
levels <- seq(zlim[1],zlim[2],length.out = nlevels)
col <- colorRampPalette(c("red","yellow","dark green"))(nlevels)
colz <- col[cut(z,nlevels)]
#
plot.new()
plot.window(xlim = c(0, 1), ylim = range(levels), xaxs = "i", yaxs = "i")
rect(0, levels[-length(levels)], 1, levels[-1L],col=col,border=col)
if (missing(key.axes)) {if (axes){axis(4)}}
else key.axes
box()
if (!missing(key.title))
key.title
mar <- mar.orig
mar[4L] <- 1
par(mar = mar)
# points
plot(x,y,type = "n",xaxt='n',yaxt='n',xlab="",ylab="",xlim=xlim,ylim=ylim,bty="n")
points(x,y,col = colz,xaxt='n',yaxt='n',xlab="",ylab="",bty="n",...)
## options to make mapping more customizable
if (missing(plot.axes)) {
if (axes) {
title(main = "", xlab = "", ylab = "")
Axis(x, side = 1)
Axis(y, side = 2)
}
}
else plot.axes
if (frame.plot)
box()
if (missing(plot.title))
title(...)
else plot.title
invisible()
}
Just run the function first and it is ready to be used. It is quite handy.
# random vectors
vx <- rnorm(40,0,1)
vy <- rnorm(40,0,1)
vz <- rnorm(40,10,10)
scatter_fill(vx,vy,vz,nlevels=15,xlim=c(-1,1),ylim=c(-1,5),zlim=c(-10,10),main="TEST",pch=".",cex=8)
As you can notice, it inherits the usual plot function capabilities.
Another alternative using levelplot in package latticeExtra, with three different colour palettes.
library(latticeExtra)
levelplot(z ~ x + y, panel = panel.levelplot.points, col.regions = heat.colors(50))
levelplot(z ~ x + y, panel = panel.levelplot.points,
col.regions =colorRampPalette(brewer.pal(11,"RdYlGn"))(50))
levelplot(z ~ x + y, panel = panel.levelplot.points, col.regions = rainbow(50))
I have a customized function for plotting filled contours which is heavily based on Carey McGilliard and Bridget Ferris work (http://wiki.cbr.washington.edu/qerm/sites/qerm/images/1/16/Filled.contour3.R) and http://wiki.cbr.washington.edu/qerm/index.php/R/Contour_Plots .
the filled.contour3 function runs perfectly in R 2.15.3 but throws an error in R 3.0.x
Error in .Internal(filledcontour(as.double(x), as.double(y), z, as.double(levels), :
there is no .Internal function 'filledcontour'
Could you please help me with a solution or a workarround so that I can use the filled.contour3() function in R 3.0.x . *A great deal of my work depends on this function and I am on LInux so changing R versions is not that easy on production machines. Will be happy to offer bounty.*
To reproduce the error please source first the following
filled.contour3 <-
function (x = seq(0, 1, length.out = nrow(z)),
y = seq(0, 1, length.out = ncol(z)), z, xlim = range(x, finite = TRUE),
ylim = range(y, finite = TRUE), zlim = range(z, finite = TRUE),
levels = pretty(zlim, nlevels), nlevels = 20, color.palette = cm.colors,
col = color.palette(length(levels) - 1), plot.title, plot.axes,
key.title, key.axes, asp = NA, xaxs = "i", yaxs = "i", las = 1,
axes = TRUE, frame.plot = axes,mar, ...)
{
# modification by Ian Taylor of the filled.contour function
# to remove the key and facilitate overplotting with contour()
# further modified by Carey McGilliard and Bridget Ferris
# to allow multiple plots on one page
if (missing(z)) {
if (!missing(x)) {
if (is.list(x)) {
z <- x$z
y <- x$y
x <- x$x
}
else {
z <- x
x <- seq.int(0, 1, length.out = nrow(z))
}
}
else stop("no 'z' matrix specified")
}
else if (is.list(x)) {
y <- x$y
x <- x$x
}
if (any(diff(x) <= 0) || any(diff(y) <= 0))
stop("increasing 'x' and 'y' values expected")
# mar.orig <- (par.orig <- par(c("mar", "las", "mfrow")))$mar
# on.exit(par(par.orig))
# w <- (3 + mar.orig[2]) * par("csi") * 2.54
# par(las = las)
# mar <- mar.orig
plot.new()
# par(mar=mar)
plot.window(xlim, ylim, "", xaxs = xaxs, yaxs = yaxs, asp = asp)
if (!is.matrix(z) || nrow(z) <= 1 || ncol(z) <= 1)
stop("no proper 'z' matrix specified")
if (!is.double(z))
storage.mode(z) <- "double"
.Internal(filledcontour(as.double(x), as.double(y), z, as.double(levels),
col = col))
if (missing(plot.axes)) {
if (axes) {
title(main = "", xlab = "", ylab = "")
Axis(x, side = 1)
Axis(y, side = 2)
}
}
else plot.axes
if (frame.plot)
box()
if (missing(plot.title))
title(...)
else plot.title
invisible()
}
filled.legend <-
function (x = seq(0, 1, length.out = nrow(z)), y = seq(0, 1,
length.out = ncol(z)), z, xlim = range(x, finite = TRUE),
ylim = range(y, finite = TRUE), zlim = range(z, finite = TRUE),
levels = pretty(zlim, nlevels), nlevels = 20, color.palette = cm.colors,
col = color.palette(length(levels) - 1), plot.title, plot.axes,
key.title, key.axes, asp = NA, xaxs = "i", yaxs = "i", las = 1,
axes = TRUE, frame.plot = axes, ...)
{
# modification of filled.contour by Carey McGilliard and Bridget Ferris
# designed to just plot the legend
if (missing(z)) {
if (!missing(x)) {
if (is.list(x)) {
z <- x$z
y <- x$y
x <- x$x
}
else {
z <- x
x <- seq.int(0, 1, length.out = nrow(z))
}
}
else stop("no 'z' matrix specified")
}
else if (is.list(x)) {
y <- x$y
x <- x$x
}
if (any(diff(x) <= 0) || any(diff(y) <= 0))
stop("increasing 'x' and 'y' values expected")
# mar.orig <- (par.orig <- par(c("mar", "las", "mfrow")))$mar
# on.exit(par(par.orig))
# w <- (3 + mar.orig[2L]) * par("csi") * 2.54
#layout(matrix(c(2, 1), ncol = 2L), widths = c(1, lcm(w)))
# par(las = las)
# mar <- mar.orig
# mar[4L] <- mar[2L]
# mar[2L] <- 1
# par(mar = mar)
# plot.new()
plot.window(xlim = c(0, 1), ylim = range(levels), xaxs = "i",
yaxs = "i")
rect(0, levels[-length(levels)], 1, levels[-1L], col = col)
if (missing(key.axes)) {
if (axes)
axis(4)
}
else key.axes
box()
}
#
# if (!missing(key.title))
# key.title
# mar <- mar.orig
# mar[4L] <- 1
# par(mar = mar)
# plot.new()
# plot.window(xlim, ylim, "", xaxs = xaxs, yaxs = yaxs, asp = asp)
# if (!is.matrix(z) || nrow(z) <= 1L || ncol(z) <= 1L)
# stop("no proper 'z' matrix specified")
# if (!is.double(z))
# storage.mode(z) <- "double"
# .Internal(filledcontour(as.double(x), as.double(y), z, as.double(levels),
# col = col))
# if (missing(plot.axes)) {
# if (axes) {
# title(main = "", xlab = "", ylab = "")
# Axis(x, side = 1)
# Axis(y, side = 2)
# }
# }
# else plot.axes
# if (frame.plot)
# box()
# if (missing(plot.title))
# title(...)
# else plot.title
# invisible()
#}
and then run
#Example Four Panel Contour Plot with One Legend
#Author: Carey R McGilliard
#September 2010
#This code uses a modified version of filled.contour called filled.contour3 (created by Carey McGilliard, Ian Taylor, and Bridget Ferris)
#to make an example figure of four contour plots sharing a legend (to the right).
#The example demonstrates how to use various color schemes for the contour plots and legend, but the user will want to
#pick one color scheme for all four plots such that the legend matches the plots.
#Changing the x- and y-axis values will change the placement of text added to the figure using the text() function and adjustments will be necessary
#Source the following functions (change the paths as necessary)
#source("./print.letterTrevor.R")
#gplots has the function colorpanel, which is handy for making gray-scale contour plots
library(gplots)
#------------------------------------------------------
#Generate some fake data
x = rep(c(10,11,12),length = 9)
y = rep(c(1,2,3),each = 3)
z = rnorm(n=9,mean = 0,sd = 1)
xcoords = unique(x)
ycoords = unique(y)
surface.matrix = matrix(z,nrow=length(xcoords),ncol=length(ycoords),byrow=T)
#------------------------------------------------------
#plot.new() is necessary if using the modified versions of filled.contour
plot.new()
#I am organizing where the plots appear on the page using the "plt" argument in "par()"
par(new = "TRUE",
plt = c(0.1,0.4,0.60,0.95), # using plt instead of mfcol (compare
# coordinates in other plots)
las = 1, # orientation of axis labels
cex.axis = 1, # size of axis annotation
tck = -0.02 ) # major tick size and direction, < 0 means outside
#Top left plot:
#
# the filled contour - coloured areas
filled.contour3(xcoords,
ycoords,
surface.matrix,
color=terrain.colors,
xlab = "", # suppress x-axis annotation
ylab = "", # suppress y-axis annotation
xlim = c(min(xcoords),max(xcoords)),
ylim = c(min(ycoords),max(ycoords)),
zlim = c(min(surface.matrix),max(surface.matrix))
)
# the contour part - draw iso-lines
contour(xcoords,
ycoords,
surface.matrix,
color=terrain.colors,
xlab = "",
ylab = "",
xlim = c(min(xcoords),max(xcoords)),
ylim = c(min(ycoords),max(ycoords)),
zlim = c(min(surface.matrix),max(surface.matrix)),
add=TRUE, # add the contour plot to filled-contour,
#thus making an overlay
col = grey(0.4) # color of overlay-lines
)
#
# An annotation inside first plot
#The xpd=NA allows for writing outside the plot limits, but still using the the x and y axes to place the text
par(xpd = NA)
text(x=11,y=1.5,"x",cex = 1.5,font = 2)
print.letter(text = "(a)")
######################################################################
#
#
#Top right plot:
par(new = "TRUE",
plt = c(0.5,0.8,0.60,0.95), # defining window for second plot
las = 1,
cex.axis = 1)
#
filled.contour3(
xcoords,
ycoords,
surface.matrix,
color=heat.colors,
xlab = "",
ylab = "",
xlim = c(min(xcoords),max(xcoords)),
ylim = c(min(ycoords),max(ycoords)),
zlim = c(-1,1)
)
#
contour(
xcoords,
ycoords,
surface.matrix,
xlab = "",
ylab = "",
xlim = c(min(xcoords),max(xcoords)),
ylim = c(min(ycoords),max(ycoords)),
zlim = c(-1,1),
add=TRUE
)
#
#Alternatively, you could set z axis limits to depend
#on the min and max values in surface.matrix.
#filled.contour3(xcoords,ycoords,surface.matrix,color=heat.colors,xlab = "",ylab = "",xlim = c(min(xcoords),max(xcoords)),ylim = c(min(ycoords),max(ycoords)),zlim = c(min(surface.matrix),max(surface.matrix)))
#
# Add annotation
text(x=11,
y=1.5,
"x",
cex = 1.5,
font = 2)
######################################################################
#
#Bottom left plot:
par(new = "TRUE",
plt = c(0.1,0.4,0.15,0.5),
las = 1,
cex.axis = 1)
#
filled.contour3(xcoords,
ycoords,
surface.matrix,
col=colorpanel(11, "white", "grey10"),
nlevels=11,
xlab = "",
ylab = "",
xlim = c(min(xcoords),max(xcoords)),
ylim = c(min(ycoords),max(ycoords)),
zlim = c(-1,1))
#
contour(xcoords,
ycoords,
surface.matrix,
xlab = "",
ylab = "",
xlim = c(min(xcoords),max(xcoords)),
ylim = c(min(ycoords),max(ycoords)),
zlim = c(-1,1),
add = TRUE)
#
text(x=11,
y=1.5,
"x",
cex = 1.5,
font = 2,
col = "white")
######################################################################
#
#Bottom right plot:
par(new = "TRUE",
plt = c(0.5,0.8,0.15,0.5),
las = 1,
cex.axis = 1)
#
filled.contour3(
xcoords,
ycoords,
surface.matrix,
color = terrain.colors,
xlab = "",
ylab = "",
xlim = c(min(xcoords),max(xcoords)),
ylim = c(min(ycoords),max(ycoords)),
zlim = c(-1,1)
)
#
contour(
xcoords,
ycoords,
surface.matrix,
xlab = "",
ylab = "",
xlim = c(min(xcoords),max(xcoords)),
ylim = c(min(ycoords),max(ycoords)),
zlim = c(-1,1),
add=TRUE
)
text(x=11,
y=1.5,
"hello",
cex = 1.5,
font = 2)
#
######################################################################
#Add a legend:
par(new = "TRUE",
plt = c(0.85,0.9,0.25,0.85), # define plot region for legend
las = 1,
cex.axis = 1)
#
filled.legend(
xcoords,
ycoords,
surface.matrix,
color = terrain.colors,
xlab = "",
ylab = "",
xlim = c(min(xintercepts),max(xintercepts)),
ylim = c(min(slopes),max(slopes)),
zlim = c(-1,1))
#Add some figure labels
par(xpd=NA,cex = 1.3)
text(x = -16.7,y = 0,"slope",srt = 90,cex = 1.3)
text(x = -8,y = -1.62,expression(paste(italic(x),"-intercept",sep = "")),cex = 1.3)
This happens if you use a non-standard API. You are allowed to do that, but cannot expect that it is maintained.
Change
.Internal(filledcontour(as.double(x), as.double(y), z, as.double(levels),
col = col))
to
.filled.contour(as.double(x), as.double(y), z, as.double(levels),
col = col)
The change was announced with the release notes:
The C code underlying base graphics has been migrated to the graphics
package (and hence no longer uses .Internal() calls).
Have you ever heard of a "minimal reproducible example" (emphasis on "minimal")?