I'm writing a function that takes two variables -- ideally columns from the same data frame -- and plots them. The plot will also include a legend using the names from the columns, and that's where I'm running into difficulty.
The code below is as close to the desired outcome as I can get. I'm only interested in using base R.
plotpairs <- function(x,y){
plot(x, type = "l", col = "red")
lines(y, type = "l", col = "blue")
legend(0,ylim_max, legend = paste0(x, y), lwd = c(5,5), col = c("red", "blue"), bty = "n")
}
plotpairs(df$F3, df$F4)
If you supply a data.frame or matrix as argument, you can extract the column names using colnames(), else you have to use deparse(substitute()), or match.call() as I've used here.
set.seed(1)
F3 <- cumsum(runif(1e3, -2, 2))+runif(1e3)
F4 <- cumsum(rnorm(1e3))+rnorm(1e3, 0, 0.5)
df <- data.frame(F3, F4)
plotpairs <- function(x, y) {
if (NCOL(x) > 1) {
nam <- colnames(x)[1:2]
y <- x[,2]
x <- x[,1]
} else {
nam <- as.character(match.call()[c("x", "y")])
}
plot(x, type="l", col="red", ylim=range(c(x, y)))
lines(y, type="l", col="blue")
legend("topleft", legend=nam, lwd=c(5, 5), col=c("red", "blue"), bty="n")
}
plotpairs(F3, F4)
with(df, plotpairs(F3, F4)) # same
plotpairs(df) # same
This plots the indicated columns from the data frame given as first argument or if no names are given then it plots the first two columns. Note that we first plot both together using type = "n" to ensure that the plot gets set up large enough to accommodate both variables. The example uses the builtin data frame trees.
plotpairs <- function(data, name1 = names(data)[1], name2 = names(data)[2]) {
both <- c(data[[name1]], data[[name2]])
plot(seq_along(both) / 2, both, type = "n", xlab = "", ylab = "")
lines(data[[name1]], type = "l", col = "red")
lines(data[[name2]], type = "l", col = "blue")
legend("topleft", legend = c(name1, name2), lwd = 5,
col = c("red", "blue"), bty = "n")
}
plotpairs(trees, "Girth", "Volume")
I also worked out an answer based on the comment #Rui Barradas that included regex. Since I'll be using inputs like "df$F3", I can count on the "$" symbol to be present, though this might limit the flexibility of the code.
plotpairs <- function(x,y){
xnam <- deparse(substitute(x))
ynam <- deparse(substitute(y))
xnam1 <- substring(xnam, regexpr("[$]", xnam)+1)
ynam1 <- substring(ynam, regexpr("[$]", ynam)+1)
plot(x, type = "l", col = "red")
lines(y, type = "l", col = "blue")
legend("topleft", legend = c(paste0(xnam1), paste0(ynam1)),lwd = c(5,5), col = c("red", "blue"), bty = "n")
}
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")
I have a function (col_grob) that calls another function (pal_bar) with a tilde-notation expression as follows:
## plots a colour bar with specified colour intervals
pal_bar <- function(cols) {
cols <- colorRampPalette(cols)(200)
par(mar = c(0, 0, 0, 0))
plot(1:200, rep(1, 200), col = cols, pch = 15, cex = 1.1, bty = 'n', xaxt = 'n', xlab = '', yaxt = 'n', ylab = '', main="")
}
## calls pal_bar function to plot the bar as a grob, tilde expression
col_grob <- function(pal) {
g <- ggplotify::as.grob(~pal_bar(pal))
grid::grid.draw(g)
}
I am returned the error "object 'pal' not found" when I run:
col_grob(pal = c("red", "blue"))
I came across resources and similar questions but I am not able to solve the issue with my lack of understanding of the evaluation rules. I tried ~pal_bar(I(pal)), bquote() function, and possibly structure(list(), *) but do not have sufficient knowledge of each to format the syntax correctly.
How would I get col_grob(pal = c("red", "blue")) to plot the desired colour bar for me?
A possible solution:
col_grob <- function(pal) {
txt <- substitute(pal_bar(pal))
g <- ggplotify::as.grob(as.expression(txt))
grid::grid.draw(g)
}
col_grob(pal = c("red", "blue"))
I ran metaMDS and want to plot and color code by a grouping based on certain data frame characters. In my original data frame, df$yr are years and df$2 are sites. I want to color by the years.
caltmds <- metaMDS(df[,3:12], k=3)
plot(caltmds, type = 'n')
cols <- c("red2", "mediumblue")
points(caltmds, col = cols[df$yr])
I also tried from this post:
scl <- 3
colvec <- c("red2", "mediumblue")
plot(caltmds, type = "n", scaling = scl)
with(df, points(caltmds, display = "sites", col = colvec[yr], pch = 21, bg = colvec[yr]))
text(caltmds, display = "species", cex = 0.8, col = "darkcyan")
with(df, legend("topright", legend = levels(yr), bty = "n", col = colvec, pch = 21, pt.bg = colvec))
Nothing plots
#DATA
df1 = mtcars
mycolors = df1$cyl #Identify the grouping vector
library(vegan)
m = metaMDS(df1)
x = scores(m) #Extract co-ordinates
plot(x, col = as.numeric(as.factor(mycolors)))
I want to plot a graph of a time series return on an asset with different colors for more volatile periods. I want the volatility clusters to be marked in red with the rest of the more calm periods marked in blue. I've attached an image of what I want to achieve.
My code:
plot.zoo(djr, xlab = "Time", ylab = "Returns", col = "blue")
If cond is a logical vector with your condition for more volatile periods (for example cond <- abs(Returns > 0.05)), you can use something like:
plot.zoo(djr, xlab = "Time", ylab = "Returns", col = "blue")
points(index(djr)[cond], djr[cond], type = "l", col = "red")
For multiple periods in red, lines may appear that go from one to the other. In the following example I solve this problem:
# Reproducible example:
library(zoo)
djr <- as.zoo(EuStockMarkets[, "DAX"])
djr <- (djr - mean(djr))/sd(djr)
cond <- abs(as.numeric(djr)) > 0.75
rlec <- rle(cond)
plot.zoo(djr, xlab = "Time", ylab = "Returns", col = "white")
ind <- 1
for(i in 1:length(rlec$values)) {
points(index(djr)[ind:(ind + rlec$lengths[i] - 1)],
djr[ind:(ind + rlec$lengths[i] - 1)],
type = "l", col = c("blue", "red")[rlec$values[i] + 1])
ind <- ind + rlec$lengths[i]
}
The answer by Juan works. Here's an alternate method that I found works as well
ling_segs <-ifelse(djr <= -0.02 | djr >= 0.02, cbind(djr), NA)
line_segs <- na.omit(ling_segs)
plot.zoo(cbind(djr, line_segs),
plot.type = "single",
xlab = "Date", ylab = "Returns",
col = c("blue", "red"))
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: