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')
Related
I am planning to reproduce the attached figure, but I have no clue how to do so:
Let´s say I would be using the CO2 example dataset, and I would like to plot the relative change of the Uptake according to the Treatment. Instead of having the three variables in the example figure, I would like to show the different Plants grouped for each day/Type.
So far, I managed only to get this bit of code, but this is far away from what it should look like.
aov1 <- aov(CO2$uptake~CO2$Type+CO2$Treatment+CO2$Plant)
plot(TukeyHSD(aov1, conf.level=.95))
Axes should be switched, and I would like to add statistical significant changes indicated with letters or stars.
You can do this by building it in base R - this should get you started. See comments in code for each step, and I suggest running it line by line to see what's being done to customize for your specifications:
Set up data
# Run model
aov1 <- aov(CO2$uptake ~ CO2$Type + CO2$Treatment + CO2$Plant)
# Organize plot data
aov_plotdata <- data.frame(coef(aov1), confint(aov1))[-1,] # remove intercept
aov_plotdata$coef_label <- LETTERS[1:nrow(aov_plotdata)] # Example labels
Build plot
#set up plot elements
xvals <- 1:nrow(aov_plotdata)
yvals <- range(aov_plotdata[,2:3])
# Build plot
plot(x = range(xvals), y = yvals, type = 'n', axes = FALSE, xlab = '', ylab = '') # set up blank plot
points(x = xvals, y = aov_plotdata[,1], pch = 19, col = xvals) # add in point estimate
segments(x0 = xvals, y0 = aov_plotdata[,2], y1 = aov_plotdata[,3], lty = 1, col = xvals) # add in 95% CI lines
axis(1, at = xvals, label = aov_plotdata$coef_label) # add in x axis
axis(2, at = seq(floor(min(yvals)), ceiling(max(yvals)), 10)) # add in y axis
segments(x0=min(xvals), x1 = max(xvals), y0=0, lty = 2) #add in midline
legend(x = max(xvals)-2, y = max(yvals), aov_plotdata$coef_label, bty = "n", # add in legend
pch = 19,col = xvals, ncol = 2)
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 would like to add a 2nd y-axis (right) and a 2nd x-axis (top) to the following (lattice) levelplot. These axes should only indicate certain rows and columns (no labels) and thus mimick base-graphics' rug function. How can this be done?
library(lattice)
library(latticeExtra)
## Generate a correlation matrix
d <- 50
L <- diag(1:d)
set.seed(271)
L[lower.tri(L)] <- runif(choose(d,2))
Sigma <- L %*% t(L)
P <- cor(Sigma)
## Panel function
my_panel <- function(...) {
panel.levelplot(...)
panel.abline(h = (1:4)*10, v = (1:4)*10, lty = 2)
panel.axis(side = "top", at = (1:50)-0.5, draw.labels = FALSE) # maybe a panel axis could do it? why not centered?
}
## Plot
obj1 <- levelplot(P, xlab = "Column", ylab = "Row",
col.regions = grey(c(seq(1, 0, length.out = 600))),
panel = my_panel)
obj2 <- xyplot(NA~NA, ylim = c(0, 50),
scales = list(x = list(at = (1:50)-0.5, labels = rep("", 50)),
y = list(at = (1:50)-0.5, labels = rep("", 50))))
doubleYScale(obj1, obj2, use.style = FALSE) # idea based on latticeExtra; only gives a 2nd y-axis, though
You were onto a good idea with panel.rug(), but were stymied by lattice's default clipping of its plotting to the panel's interior. To get around that, you can turn off clipping via the par.settings= argument. If you want to suppress the plotting of default axis tick marks on the right and top panel borders, you can do so using the tck= argument, as shown below.
my_panel <- function(...) {
panel.levelplot(...)
panel.abline(h = (1:4)*10, v = (1:4)*10, lty = 2)
## Have panel.rug print tick marks starting at 1 npc (edge of panel)
## and extending to 1.02 npc (slightly outside of panel). (See ?unit)
panel.rug(x = (1:51)-0.5, y = (1:51)-0.5,
start = 1, end = 1.02,
col="black")
}
levelplot(P, xlab = "Column", ylab = "Row",
col.regions = grey(c(seq(1, 0, length.out = 600))),
## Suppress default scales on right and top sides, by setting their
## tick lengths to zero
scales = list(tck=c(1,0)),
## Turn off clipping, so that panel.rug can plot outside of the panel
par.settings = list(clip = list(panel = "off")),
panel = my_panel)
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)
how to
Combine a bar chart and line in single plot in R (from different data sources)?
Say I have two data sources as:
barData<-c(0.1,0.2,0.3,0.4) #In percentage
lineData<-c(100,22,534,52,900)
Note that they may not be in the same scale.
Can I plot both barData and LineData in one plot and make them good looking ?
I cant use ggplot in this case so this is not a duplicated question..
Something like the following:
Maybe this helps as a starting point:
par(mar = rep(4, 4))
barData<-c(0.1,0.2,0.3,0.4) * 100
y <- lineData<-c(100,22,534,900);
x <- barplot(barData,
axes = FALSE,
col = "blue",
xlab = "",
ylab = "",
ylim = c(0, 100) )[, 1]
axis(1, at = x, labels = c("Julia", "Pat", "Max", "Norman"))
ats <- c(seq(0, 100, 15), 100); axis(4, at = ats, labels = paste0(ats, "%"), las = 2)
axis(3, at = x, labels = NA)
par(new = TRUE)
plot(x = x, y = y, type = "b", col = "red", axes = FALSE, xlab = "", ylab = "")
axis(2, at = c(pretty(lineData), max(lineData)), las = 2)
mtext(text="Lines of code by Programmer", side = 3, line = 1)
box()