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)
Related
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")
Let's say I'm doing a linear model with y ~ x. I get the residuals plot for example with
plot(lm(y ~ x, data.frame(x=c(1,2,3), y=c(4,6,9))), 1)
How can I set the ylim for this plot? (Supplying e.g. ylim=c(-1,1) to this function doesn't work).
ylim is hard-coded into the function stats:::plot.lm (i.e., the s3 plot method for objects of class "lm"). This function is not exported from the stats package. To get around this, you could copy the function and modify it:
plotlm <- stats:::plot.lm
You can edit it using fix("plotlm"). Add a ylim formal argument to the function definition and then find the relevant part of the code. You should change:
if (show[1L]) {
ylim <- range(r, na.rm = TRUE)
if (id.n > 0)
ylim <- extendrange(r = ylim, f = 0.08)
dev.hold()
plot(yh, r, xlab = l.fit, ylab = "Residuals", main = main,
ylim = ylim, type = "n", ...)
# ...
to:
if (show[1L]) {
if(missing(ylim)) {
ylim <- range(r, na.rm = TRUE)
if (id.n > 0)
ylim <- extendrange(r = ylim, f = 0.08)
}
dev.hold()
plot(yh, r, xlab = l.fit, ylab = "Residuals", main = main,
ylim = ylim, type = "n", ...)
# ...
Then you can call this new function:
plotlm(lm(y ~ x, data.frame(x=c(1,2,3), y=c(4,6,9))), 1, ylim = c(-1,1))
And obtain the desired result:
I want to visualize time series data with a 'scatter plot' and a histogram on the right side, but I haven't been able to figure out how to turn OFF the histogram on the upper side.
Code Example:
install.packages("psych")
library(psych)
data = matrix(rnorm(n=100000,mean=2,sd=1.5), nrow = 100, ncol=1000)
fs = list()
fs$p_Z = 1*(data>2)
n_p = 1;
for(i in floor(seq(1,dim(data)[2],length.out=n_p)))
{
scatter.hist(x = rep(1:length(data[,i])), y = data[,i],
xlab = 'observations',
ylab = 'log(TPM)',
title = 'Mixture Plot',
col = c("red","blue")[fs$p_Z[,i]+1],
correl = FALSE, ellipse = FALSE, smooth = FALSE)
}
Result:
Expected Result:
Same as the one I have but with no histogram on the upper side. I.e., ONLY the histogram on the right side for log(TPM).
Note: I am using psych package, scatter.hist function which seemed easy and nice to use, but couldn't find how to turn off one histogram.
Where flexibility ends, hacking begins. If you look at scatter.hist function, you will see that it is pretty basic usage of R base graphics. Following modified code would create the plot you want:
scat.hist <- function(x, y, xlab = NULL, ylab = NULL, title = "", ...) {
## Create layout
layout(matrix(c(1,2),1,2,byrow=TRUE), c(3,1), c(1,3))
## Plot scatter
par(mar=c(5,5,3,1))
plot(x= x, y = y, xlab = xlab, ylab = ylab, main = title, ...)
## Right histogram
yhist <- hist(y, plot = FALSE, breaks = 11)
par(mar=c(5,2,3,1))
mp <- barplot(yhist$density, space=0, horiz=TRUE, axes = FALSE)
## Density
d <- density(y, na.rm = TRUE, bw = "nrd", adjust = 1.2)
temp <- d$y
d$y <- (mp[length(mp)] - mp[1] + 1) * (d$x - min(yhist$breaks))/(max(yhist$breaks) - min(yhist$breaks))
d$x <- temp
lines(d)
}
Let's try it for the first row:
i = 1
scat.hist(x = seq_along(data[,i]), y = data[,i], col = c("red", "blue")[fs$p_Z[,i]+1], xlab = 'observations', ylab = 'log(TPM)', title = 'Mixture Plot')
I would like to do a graph in R using our company colors. This means the background of all charts should be a light blue, the plotting region however should be white. I was searching for answers and found that drawing a rect does the job (almost). However the plotting region is now white and the graph not visible anymore. Is this even possible?
getSymbols('SPY', from='1998-01-01', to='2011-07-31', adjust=T)
GRAPH_BLUE<-rgb(43/255, 71/255,153/255)
GRAPH_ORANGE<-rgb(243/255, 112/255, 33/255)
GRAPH_BACKGROUND<-rgb(180/255, 226/255, 244/255)
par(bg=GRAPH_BACKGROUND)
colorPlottingBackground<-function(PlottingBackgroundColor = "white"){
rect(par("usr")[1], par("usr")[3], par("usr")[2], par("usr")[4], col ="white")
}
plot.xts(SPY, col=GRAPH_BLUE)
colorPlottingBackground()
I know you already accepted #plannapus's answer, but this is a much simpler solution
par(bg="lightblue")
plot(0, 0, type="n", ann=FALSE, axes=FALSE)
u <- par("usr") # The coordinates of the plot area
rect(u[1], u[3], u[2], u[4], col="white", border=NA)
par(new=TRUE)
plot(1:10, cumsum(rnorm(10)))
What you basically do is to overlay two plots using par(new=TRUE): one with only a white rectangle; and another one with the contents you actually want to plot.
The issue is that you plot your white rectangle after plotting your data, therefore overwriting them. Since plot.xts doesn't have an argument add that would allow you to call it after drawing the rectangle, the only solution I see would be to modify function plot.xts.
plot.xtsMODIFIED<-function (x, y = NULL, type = "l", auto.grid = TRUE, major.ticks = "auto",
minor.ticks = TRUE, major.format = TRUE, bar.col = "grey",
candle.col = "white", ann = TRUE, axes = TRUE, ...)
{
series.title <- deparse(substitute(x))
ep <- axTicksByTime(x, major.ticks, format.labels = major.format)
otype <- type
if (is.OHLC(x) && type %in% c("candles", "bars")) {
x <- x[, has.OHLC(x, TRUE)]
xycoords <- list(x = .index(x), y = seq(min(x), max(x),
length.out = NROW(x)))
type <- "n"
}
else {
if (NCOL(x) > 1)
warning("only the univariate series will be plotted")
if (is.null(y))
xycoords <- xy.coords(.index(x), x[, 1])
}
###The next three lines are the only modifications i made to the function####
plot(xycoords$x, xycoords$y, type = "n", axes = FALSE, ann = FALSE)
rect(par("usr")[1], par("usr")[3], par("usr")[2], par("usr")[4], col ="white")
if(type=="l"){lines(xycoords$x, xycoords$y, ...)}
if (auto.grid) {
abline(v = xycoords$x[ep], col = "grey", lty = 4)
grid(NA, NULL)
}
if (is.OHLC(x) && otype == "candles")
plot.ohlc.candles(x, bar.col = bar.col, candle.col = candle.col,
...)
dots <- list(...)
if (axes) {
if (minor.ticks)
axis(1, at = xycoords$x, labels = FALSE, col = "#BBBBBB",
...)
axis(1, at = xycoords$x[ep], labels = names(ep), las = 1,
lwd = 1, mgp = c(3, 2, 0), ...)
axis(2, ...)
}
box()
if (!"main" %in% names(dots))
title(main = series.title)
do.call("title", list(...))
assign(".plot.xts", recordPlot(), .GlobalEnv)
}
Then your script become:
library(quantmod)
getSymbols('SPY', from='1998-01-01', to='2011-07-31', adjust=T)
GRAPH_BLUE<-rgb(43/255, 71/255,153/255)
GRAPH_BACKGROUND<-rgb(180/255, 226/255, 244/255)
par(bg=GRAPH_BACKGROUND)
plot.xtsMODIFIED(SPY, col=GRAPH_BLUE)
The error you're getting (Error in axis(1, at = xycoords$x, labels = FALSE, col = "#BBBBBB", ...) : formal argument "col" matched by multiple actual arguments.) was also thrown with your previous script. It has to do with the fact that plot.xts uses several time argument ... and that argument col is both valid for axis and plot(or here in my modified version, lines). If you want to avoid it, i see two solutions:
Either you want your axis to be of the same color as your line and therefore you have to change the line that says:
...
axis(1, at = xycoords$x, labels = FALSE, col = "#BBBBBB",
...)
...
Into
...
axis(1, at = xycoords$x, labels = FALSE, ...)
...
Or you want the axis to have the color intended by the writer of the original plot.xts in which case you need to differenciate the color of the lines and that of the axis.
plot.xtsMODIFIED<-function (x, y = NULL, type = "l", auto.grid = TRUE, major.ticks = "auto",
minor.ticks = TRUE, major.format = TRUE, bar.col = "grey",
candle.col = "white", ann = TRUE, axes = TRUE,
lcol, ...)
{
...
if(type=="l"){lines(xycoords$x, xycoords$y, lcol, ...)}
...
}
And then in your actual call:
plot.xtsMODIFIED(SPY, lcol=GRAPH_BLUE)
plot.xts will accept the panel.first argument, which is another way to draw the rectangle before plotting the line.
library(quantmod)
getSymbols('SPY', from='1998-01-01', to='2011-07-31', adjust=T)
GRAPH_BLUE<-rgb(43/255, 71/255,153/255)
GRAPH_BACKGROUND<-rgb(180/255, 226/255, 244/255)
par(bg=GRAPH_BACKGROUND)
white.rect=function() do.call(rect,as.list(c(par()$usr[c(1,3,2,4)],col="white")))
plot.xts(SPY,panel.first=white.rect())
This does not address the issue with col=GRAPH_BLUE pointed out by #plannapus.
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")?