Related
I am trying to recreate the following plsr biplot:
plsr loading plots
plsr code
df.metric <- plsr(y ~ LMA + LDMC + Thick + Carbon + Nitrogen + Tough, scale
= TRUE, validation = "LOO", method = "oscorespls", data = df)
extract fungal taxa loadings
df2<-df.metric$Yloadings
comp1a <- df2[,1]
comp2a <- df2[,2]
namesa <- df2[,0]
df2<-as.data.frame(cbind(namesa,comp1a, comp2a))
extract leaf traits loadings
df1<-df.metric$loadings
comp1 <- df1[,1]
comp2 <- df1[,2]
names <- df1[,0]
df1<-as.data.frame(cbind(names, comp1, comp2))
Generate two plots, one for fungal taxa and one for leaf traits
#generate fungal taxa plot
plot.fungal.taxa<-ggplot(data=df2, aes(comp1a,comp2a))+
ylab("")+
xlab("")+
theme_bw()+
theme(panel.border = element_rect(colour = "black", fill=NA,
size=1),panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
axis.line = element_line(colour = "black"))+
geom_text(aes(label=rownames(df2)), color="red")+
scale_x_continuous(breaks = c(0.10,0.05,0,-0.05,-0.10,-0.15))+
scale_y_continuous(breaks = c(0.10,0.05,0,-0.05,-0.10,-0.15))+
coord_fixed(ylim=c(0.10, -0.15),xlim=c(0.10, -0.15))+
theme(axis.ticks = element_line(colour = "red")) +
theme(axis.text.y=element_text(angle = 90, hjust = 0.65)) +
theme(axis.text.y = element_text(margin=margin(10,10,10,5,"pt")))
#generate leaf traits plot
plot.leaf.traits<-ggplot(data=df1, aes(comp1,comp2))+
ylab("Comp 2")+
xlab("Comp 1")+
theme_bw() +
theme(panel.border = element_rect(colour = "black", fill=NA, size=1),
panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
axis.line = element_line(colour = "black"))+
geom_text(aes(label=rownames(df1)), color="black")+
scale_x_continuous(breaks = c(-0.8,-0.6,-0.4,-0.2,0,0.2,0.4,0.6))+
scale_y_continuous(breaks = c(-0.8,-0.6,-0.4,-0.2,0,0.2,0.4,0.6))+
coord_fixed(ylim=c(0.6, -0.8),xlim=c(0.6, -0.8))+
theme(axis.ticks = element_line(colour = "black")) +
theme(axis.text.y=element_text(angle = 90, hjust = 0.65)) +
theme(axis.text.y = element_text(margin=margin(10,10,10,5,"pt")))
function to overlay plots
ggplot_dual_axis = function(plot.leaf.traits, plot.fungal.taxa, which.axis =
"x")
{
# Update plot with transparent panel
plot.fungal.taxa = plot.fungal.taxa + theme(panel.background =
element_rect(fill = NA))
grid.newpage()
# Increase right margin if which.axis == "y"
if(which.axis == "y") plot.leaf.traits = plot.leaf.traits +
theme(plot.margin = unit(c(0.7, 1.5, 0.4, 0.4), "cm"))
# Extract gtable
g1 = ggplot_gtable(ggplot_build(plot.leaf.traits))
g2 = ggplot_gtable(ggplot_build(plot.fungal.taxa))
# Overlap the panel of the second plot on that of the first
pp = c(subset(g1$layout, name == "panel", se = t:r))
g = gtable_add_grob(g1, g2$grobs[[which(g2$layout$name=="panel")]], pp$t,
pp$l, pp$b, pp$l)
# Steal axis from second plot and modify
axis.lab = ifelse(which.axis == "x", "axis-b", "axis-l")
ia = which(g2$layout$name == axis.lab)
ga = g2$grobs[[ia]]
ax = ga$children[[2]]
# Switch position of ticks and labels
if(which.axis == "x") ax$heights = rev(ax$heights) else ax$widths =
rev(ax$widths)
ax$grobs = rev(ax$grobs)
if(which.axis == "x")
ax$grobs[[2]]$y = ax$grobs[[2]]$y - unit(1, "npc") + unit(0.15, "cm") else
ax$grobs[[1]]$x = ax$grobs[[1]]$x - unit(1, "npc") + unit(0.15, "cm")
# Modify existing row to be tall enough for axis
if(which.axis == "x") g$heights[[2]] = g$heights[g2$layout[ia,]$t]
# Add new row or column for axis label
if(which.axis == "x") {
g = gtable_add_grob(g, ax, 2, 4, 2, 4)
g = gtable_add_rows(g, g2$heights[1], 1)
g = gtable_add_grob(g, g2$grob[[6]], 2, 4, 2, 4)
} else {
g = gtable_add_cols(g, g2$widths[g2$layout[ia, ]$l], length(g$widths) - 1)
g = gtable_add_grob(g, ax, pp$t, length(g$widths) - 1, pp$b)
g = gtable_add_grob(g, g2$grob[[7]], pp$t, length(g$widths), pp$b - 1)
}
# Draw it
grid.draw(g)
}
Run function on individual plots
ggplot_dual_axis(plot.leaf.traits, plot.fungal.taxa, "y")
this is what I end up getting:
plsr loading plot using ggplot2
My question is how to I get the top x axis to match on top of the plot? Currently it sits on top and adjacent to the plot. I used a previous code I found here (Plotting Partial Least Squares Regression (plsr) biplot with ggplot2). Any help would be amazing!
In the future when you're posting a question, you should try to include a minimal reproducible example. You almost did that, except you didn't include any data to work with.
If you have a question related to code from a particular package, you should be able to grab data that comes with that package or R, just look at the help section for any of the functions. For example, below I just copied and pasted the line in the PLSR package to make an example PLSR model. Alternatively you could have grabbed the table from the post your reference at the end of your question.
The main problem is that the code you're building off of broke when ggplot updated. You can follow that conversation here and here. Below is some code that should work, with the package version numbers noted at the top.
#Make a ggplot object for a Partial Least Squares Regression (PLSR) plot
#####################################################
## Note that this code may break as ggplot updates,##
## as is noted on some of the below posts. ##
#####################################################
#Mostly taken from the posts below
#Links to posts-------------
#https://stackoverflow.com/questions/48664746/how-to-set-two-x-axis-and-two-y-axis-using-ggplot2
#https://stackoverflow.com/questions/39137287/plotting-partial-least-squares-regression-plsr-biplot-with-ggplot2
#https://stackoverflow.com/questions/21026598/ggplot2-adding-secondary-transformed-x-axis-on-top-of-plot
#https://stackoverflow.com/questions/36754891/ggplot2-adding-secondary-y-axis-on-top-of-a-plot/36759348#36759348
#load libraries------
library(pls) #version 2.7.1
library(ggplot2) #version 3.1.0
library(grid) #version 3.5.1
library(gtable) #version 0.2.0
library(cowplot) #version 0.9.3
library(ggplotify) #version 0.0.3
#Read data into PLSR model-----
dens1 <- plsr(density ~ NIR, ncomp = 5, data = yarn)
#Extract information from plsr (AKA mvr) model----
df1<-as.data.frame(dens1$loadings[,1:2])
names(df1) <- c("comp1", "comp2")
df2<-as.data.frame(dens1$scores[,1:2])
names(df2) <- c("comp1a", "comp2a")
#make ggplot objects------
#Plot Loadings - colored red
p1 <- ggplot(data=df1,
aes(x = comp1, y = comp2)) +
geom_text(aes(label = rownames(df1)),
color="red") +
theme_bw() +
theme(panel.border = element_rect(colour = "black",
fill=NA,
size=1),
panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
axis.line = element_line(colour = "black"),
axis.ticks = element_line(colour = "red"),
axis.text.y = element_text(margin = margin(10,10,10,5,"pt"),
angle = 90,
hjust = 0.65,
colour = "red"),
axis.text.x = element_text(colour = "red")) +
scale_y_continuous(limits = c(min(df1), max(df1))) +
scale_x_continuous(limits = c(min(df1), max(df1)))
#Plot 2 - scores in black
p2 <- ggplot(data=df2,
aes(x = comp1a, y = comp2a)) +
geom_text(aes(label = rownames(df2)),
color="black") +
theme_bw() +
theme(panel.border = element_rect(colour = "black",
fill=NA,
size=1),
panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
axis.line = element_line(colour = "black"),
axis.ticks = element_line(colour = "black"),
axis.text.y = element_text(margin = margin(10,10,10,5,"pt"),
angle = 90,
hjust = 0.65,
colour = "black"),
axis.text.x = element_text(colour = "black")) +
scale_y_continuous(limits = c(min(df2), max(df2))) +
scale_x_continuous(limits = c(min(df2), max(df2)))
#Final plot----
#Overlay plots in order to get two graphs with different axes on same plot
#rename plots in case you want to make adjustments without regenerating plots
plot1 <- p1
plot2 <- p2
# Update plot with transparent panel
plot2 = plot2 +
theme(panel.background = element_rect(fill = "transparent"))
#clean plot space
grid.newpage()
# Extract gtables from ggplot objects
g1 = ggplot_gtable(ggplot_build(plot1))
g2 = ggplot_gtable(ggplot_build(plot2))
# Get the location of the plot panel in g1.
# These are used later when transformed elements of g2 are put back into g1
pp <- c(subset(g1$layout, name == "panel", se = t:r))
# Overlap panel for second plot on that of the first plot
g1 <- gtable_add_grob(g1, g2$grobs[[which(g2$layout$name == "panel")]], pp$t, pp$l, pp$b, pp$l)
#Note from stack overflow post:
# Get the location of the plot panel in g1.
# These are used later when transformed elements of g2 are put back into g1
pp <- c(subset(g1$layout, name == "panel", se = t:r))
# Overlap panel for second plot on that of the first plot
g1 <- gtable_add_grob(g1, g2$grobs[[which(g2$layout$name == "panel")]], pp$t, pp$l, pp$b, pp$l)
# Then proceed as before:
# ggplot contains many labels that are themselves complex grob;
# usually a text grob surrounded by margins.
# When moving the grobs from, say, the left to the right of a plot,
# Make sure the margins and the justifications are swapped around.
# The function below does the swapping.
# Taken from the cowplot package:
# https://github.com/wilkelab/cowplot/blob/master/R/switch_axis.R
hinvert_title_grob <- function(grob){
# Swap the widths
widths <- grob$widths
grob$widths[1] <- widths[3]
grob$widths[3] <- widths[1]
grob$vp[[1]]$layout$widths[1] <- widths[3]
grob$vp[[1]]$layout$widths[3] <- widths[1]
# Fix the justification
grob$children[[1]]$hjust <- 1 - grob$children[[1]]$hjust
grob$children[[1]]$vjust <- 1 - grob$children[[1]]$vjust
grob$children[[1]]$x <- unit(1, "npc") - grob$children[[1]]$x
grob
}
# Get the y axis title from g2
# Which grob contains the y axis title?
index <- which(g2$layout$name == "ylab-l")
# Extract that grob
ylab <- g2$grobs[[index]]
# Swap margins and fix justifications
ylab <- hinvert_title_grob(ylab)
# Put the transformed label on the right side of g1
g1 <- gtable_add_cols(g1, g2$widths[g2$layout[index, ]$l], pp$r)
g1 <- gtable_add_grob(g1, ylab, pp$t, pp$r + 1, pp$b, pp$r + 1, clip = "off", name = "ylab-r")
# Get the y axis from g2 (axis line, tick marks, and tick mark labels)
# Which grob
index <- which(g2$layout$name == "axis-l")
# Extract the grob
yaxis <- g2$grobs[[index]]
# yaxis is a complex of grobs containing the axis line, the tick marks, and the tick mark labels.
# The relevant grobs are contained in axis$children:
# axis$children[[1]] contains the axis line;
# axis$children[[2]] contains the tick marks and tick mark labels.
# First, move the axis line to the left
yaxis$children[[1]]$x <- unit.c(unit(0, "npc"), unit(0, "npc"))
# Second, swap tick marks and tick mark labels
ticks <- yaxis$children[[2]]
ticks$widths <- rev(ticks$widths)
ticks$grobs <- rev(ticks$grobs)
# Third, move the tick marks
ticks$grobs[[1]]$x <- ticks$grobs[[1]]$x - unit(1, "npc") + unit(1, "mm")
# Fourth, swap margins and fix justifications for the tick mark labels
ticks$grobs[[2]] <- hinvert_title_grob(ticks$grobs[[2]])
# Fifth, put ticks back into yaxis
yaxis$children[[2]] <- ticks
# Put the transformed yaxis on the right side of g1
g1 <- gtable_add_cols(g1, g2$widths[g2$layout[index, ]$l], pp$r)
g1 <- gtable_add_grob(g1, yaxis, pp$t, pp$r + 1, pp$b, pp$r + 1, clip = "off", name = "axis-r")
#Draw it for a dummy check
grid.newpage()
grid.draw(g1)
# function that can vertically invert a title grob, with margins treated properly
# title grobs are used a lot in the new ggplot2 version (>1.0.1)
vinvert_title_grob <- function(grob) {
heights <- grob$heights
grob$heights[1] <- heights[3]
grob$heights[3] <- heights[1]
grob$vp[[1]]$layout$heights[1] <- heights[3]
grob$vp[[1]]$layout$heights[3] <- heights[1]
grob$children[[1]]$hjust <- 1 - grob$children[[1]]$hjust
grob$children[[1]]$vjust <- 1 - grob$children[[1]]$vjust
grob$children[[1]]$y <- unit(1, "npc") - grob$children[[1]]$y
grob
}
# Copy title xlab from g2 and swap margins
index <- which(g2$layout$name == "xlab-b")
xlab <- g2$grobs[[index]]
xlab <- vinvert_title_grob(xlab)
# Put xlab at the top of g1
g1 <- gtable_add_rows(g1, g2$heights[g2$layout[index, ]$t], pp$t-1)
g1 <- gtable_add_grob(g1, xlab, pp$t, pp$l, pp$t, pp$r, clip = "off", name="xlab-t")
# Get "feet" axis (axis line, tick marks and tick mark labels) from g2
index <- which(g2$layout$name == "axis-b")
xaxis <- g2$grobs[[index]]
# Move the axis line to the bottom (Not needed in your example)
xaxis$children[[1]]$y <- unit.c(unit(0, "npc"), unit(0, "npc"))
# Swap axis ticks and tick mark labels
ticks <- xaxis$children[[2]]
ticks$heights <- rev(ticks$heights)
ticks$grobs <- rev(ticks$grobs)
# Move tick marks
ticks$grobs[[2]]$y <- ticks$grobs[[2]]$y - unit(1, "npc") + unit(3, "pt")
# Swap tick mark labels' margins
ticks$grobs[[1]] <- vinvert_title_grob(ticks$grobs[[1]])
# Put ticks and tick mark labels back into xaxis
xaxis$children[[2]] <- ticks
# Add axis to top of g1
g1 <- gtable_add_rows(g1, g2$heights[g2$layout[index, ]$t], pp$t)
g1 <- gtable_add_grob(g1, xaxis, pp$t+1, pp$l, pp$t+1, pp$r, clip = "off", name = "axis-t")
#remove title and axes titles if you want
g1 <- gtable_remove_grobs(g1, c("title", "xlab-t", "xlab-b", "ylab-r", "ylab-l"))
# Draw it
grid.newpage()
my_PLS = ggplotify::as.ggplot(g1)
#save plot in square format----
ggsave(paste0("my_PLS_",Sys.Date(),".png"), width = 6, height = 6, units = "in", plot = my_PLS)
Should look like this:
PLSR_ggplot_example
I need to make a dual y axis in ggplot2. I have tried to follow #kohske solution published here: http://rpubs.com/kohske/dual_axis_in_ggplot2 However, two things are still undesired and I can't figure out how to solve them.
1. In the plot below the label of right y axis is absent, while I want to make it present
2. gridlines for right y axis is shown on top of bar plot, while it should be in the background.
Here's the plot:
and the code:
library(ggplot2)
library(grid)
library(gtable)
grid.newpage()
p1 <- ggplot(ex,
aes(factor(subgroups, levels = c('Monday', 'Tuesday', 'Wednesday', 'Thursday', 'Friday',
'Saturday', 'Sunday')),
y_left)) +
geom_bar(fill = rgb(16/255, 72/255, 128/255), stat = 'identity') +
theme_bw() +
labs(x = 'weekday')
p2 <- ggplot(ex, aes(factor(subgroups,
levels = c('Monday', 'Tuesday', 'Wednesday',
'Thursday', 'Friday', 'Saturday', 'Sunday')), y_right)) +
geom_line(colour = rgb(237/255, 165/255, 6/255), group = 1) +
geom_point(color = rgb(237/255, 165/255, 6/255), size = 3) +
scale_y_continuous(limits = c(0, 180)) +
labs(y = 'name for y_left axis') +
theme_bw() %+replace%
theme(panel.background = element_rect(fill = NA))
# extract gtable
g1 <- ggplot_gtable(ggplot_build(p1))
g2 <- ggplot_gtable(ggplot_build(p2))
# overlap the panel of 2nd plot on that of 1st plot
pp <- c(subset(g1$layout, name == "panel", se = t:r))
g <- gtable_add_grob(g1, g2$grobs[[which(g2$layout$name == "panel")]], pp$t,
pp$l, pp$b, pp$l)
# axis tweaks
ia <- which(g2$layout$name == "axis-l")
ga <- g2$grobs[[ia]]
ax <- ga$children[[2]]
ax$widths <- rev(ax$widths)
ax$grobs <- rev(ax$grobs)
ax$grobs[[1]]$x <- ax$grobs[[1]]$x - unit(1, "npc") + unit(0.15, "cm")
g <- gtable_add_cols(g, g2$widths[g2$layout[ia, ]$l], length(g$widths) - 1)
g <- gtable_add_grob(g, ax, pp$t, length(g$widths) - 1, pp$b)
# draw it
grid.draw(g)
They added a secondary axis option to ggplot a while back. Try putting both geoms on a single plot and adding scale_y_continuous(sec.axis = sec_axis(~.-280), name = "My Second Axis").
Instead of simple subtraction, you can compute a ratio. This can be done inline, using something like sec.axis = sec_axis(~. * max(myData$y) / max(myData$y2)), or you can compute it ahead of time and apply it to both the 2nd axis and the data you intend to be read on the second axis, like this:
library(ggplot2)
# Create Sample Data
myData <- data.frame(x = seq(1, 10, length.out = 10),
y = seq(0, 20, length.out = 10),
y2 = seq(0, 100, length.out = 10))
myData.ratio <- max(myData$y) / max(myData$y2)
ggplot(myData, (aes(x=x, y=y))) +
geom_bar(stat="identity", aes(y=y2 * myData.ratio), fill = "lightblue") +
geom_line(color="red") +
geom_point(color="red") +
scale_y_continuous(sec.axis = sec_axis(~. / myData.ratio, name = "My Second Axis"))
Note that we're multiplying the actual values by the ratio in the geom and dividing by it when computing the axis.
Output:
I copied line for line a code from someone on this site on how to overlay two plots with two y axes. However, the example uses two line plots, but I have one line plot and one barplot that I want to overlay. I can't seem to obtain an overlay at all and it just plots the line plot. Please help. Thanks.
library(ggplot2)
library(gtable)
library(grid)
require(ggplot2)
df1 <- data.frame(frax=c(0,30,60,114),solvb=c(0,0,100,100))
df2 <-data.frame(
type = factor(c("mascot","mstat"), levels=c("mascot","mstat")), frax = c(30,35,40,45,50,55), phos=c(542,413,233,500,600,650))
p1<-ggplot(df2,aes(x=frax, y=phos,fill=type)) + geom_bar(stat="identity",position="dodge") + scale_x_continuous("fractions",breaks=seq(1,115,2)) + scale_y_continuous("Phospho hits",breaks=seq(0,1400,250))
p2<-ggplot(df1,aes(x=frax,y=solvb)) + geom_line(colour="blue")
#extract gtable
g1<-ggplot_gtable(ggplot_build(p1))
g2<-ggplot_gtable(ggplot_build(p2))
#overlap the panel of 2nd plot on that of 1st plot
pp <-c(subset(g1$layout, name == "panel", se=t:r))
g<-gtable_add_grob(g1,
g2$grobs[[which(g2$layout$name == "panel")]],
pp$t,pp$l,pp$b,pp$l)
#axis tweaks
alab<-g2$grobs[[which(g2$layout$name=="ylab")]]
ia<-which(g2$layout$name == "axis-l")
ga<-g2$grobs[[ia]]
ax<-ga$children[[2]]
ax$widths<-rev(ax$widths)
ax$grobs<-rev(ax$grobs)
ax$grobs[[1]]$x<-ax$grobs[[1]]$x-unit(1,"npc")+
unit(0.15,"cm")
g<-gtable_add_cols(g,g2$widths[g2$layout[ia,]$l],
length(g$widths)-1)
g<-gtable_add_cols(g, g2$widths[g2$layout[ia,]$l],
length(g$widths)-1)
g<-gtable_add_grob(g,ax,pp$t,length(g$widths) - 2,pp$b)
g<-gtable_add_grob(g,alab,pp$t,length(g$widths) - 1,pp$b)
grid.draw(g)
I would like for the output to look exactly (or very similar) to this: However, I want the barplot "dodged"
This does most of what you want: inward pointing tick marks, combined legends from two plots, overlapping of two plots, and moving the y-axis of one to the right side of the plot.
library(ggplot2) # version 2.2.1
library(gtable) # version 0.2.0
library(grid)
# Your data
df1 <- data.frame(frax = c(16,30,60,64), solvb = c(0,0,100,100))
df2 <- data.frame(type = factor(c("mascot","mstat"), levels = c("mascot","mstat")),
frax = c(30,35,40,45,50,55), phos = c(542,413,233,500,600,650))
# Base plots
p1 <- ggplot(df2, aes(x = frax, y = phos, fill = type)) +
geom_bar(stat = "identity", position = "dodge") +
scale_x_continuous("fractions", expand = c(0,0), limits = c(16, 64),
breaks = seq(20,60,5), labels = seq(20, 60, 5)) +
scale_y_continuous("Phospho hits", breaks = seq(0,1400,250), expand = c(0,0),
limits = c(0, 700)) +
scale_fill_discrete("") +
theme_bw() +
theme(panel.grid = element_blank(),
legend.key = element_rect(colour = "white"),
axis.ticks.length = unit(-1, "mm"), #tick marks inside the panel
axis.text.x = element_text(margin = margin(t = 7, b = 0)), # Adjust the text margins
axis.text.y = element_text(margin = margin(l = 0, r = 7)))
p2 <- ggplot(df1, aes(x = frax, y = solvb)) +
geom_line(aes(linetype = "LC Gradient"), colour = "blue", size = .75) +
scale_x_continuous("fractions", expand = c(0,0), limits = c(16, 64)) +
scale_y_continuous("% Solvent B") +
scale_linetype_manual("", values="longdash") +
theme_bw() +
theme(panel.background = element_rect(fill = "transparent"),
panel.grid = element_blank(),
axis.ticks.length = unit(-1, "mm"),
axis.text.x = element_text(margin = margin(t = 7, b = 0)),
axis.text.y = element_text(margin = margin(l = 0, r = 7)),
legend.key.width = unit(1.5, "cm"), # Widen the key
legend.key = element_rect(colour = "white"))
# Extract gtables
g1 <- ggplotGrob(p1)
g2 <- ggplotGrob(p2)
# Get their legends
leg1 = g1$grobs[[which(g1$layout$name == "guide-box")]]
leg2 = g2$grobs[[which(g2$layout$name == "guide-box")]]
# Join them into one legend
leg = cbind(leg1, leg2, size = "first") # leg to be positioned later
# Drop the legends from the two gtables
pos = subset(g1$layout, grepl("guide-box", name), l)
g1 = g1[, -pos$l]
g2 = g2[, -pos$l]
## Code taken from http://stackoverflow.com/questions/36754891/ggplot2-adding-secondary-y-axis-on-top-of-a-plot/36759348#36759348
# to move y axis to right hand side
# Get the location of the plot panel in g1.
# These are used later when transformed elements of g2 are put back into g1
pp <- c(subset(g1$layout, name == "panel", se = t:r))
# Overlap panel for second plot on that of the first plot
g1 <- gtable_add_grob(g1, g2$grobs[[which(g2$layout$name == "panel")]], pp$t, pp$l, pp$b, pp$l)
# ggplot contains many labels that are themselves complex grob;
# usually a text grob surrounded by margins.
# When moving the grobs from, say, the left to the right of a plot,
# Make sure the margins and the justifications are swapped around.
# The function below does the swapping.
# Taken from the cowplot package:
# https://github.com/wilkelab/cowplot/blob/master/R/switch_axis.R
hinvert_title_grob <- function(grob){
# Swap the widths
widths <- grob$widths
grob$widths[1] <- widths[3]
grob$widths[3] <- widths[1]
grob$vp[[1]]$layout$widths[1] <- widths[3]
grob$vp[[1]]$layout$widths[3] <- widths[1]
# Fix the justification
grob$children[[1]]$hjust <- 1 - grob$children[[1]]$hjust
grob$children[[1]]$vjust <- 1 - grob$children[[1]]$vjust
grob$children[[1]]$x <- unit(1, "npc") - grob$children[[1]]$x
grob
}
# Get the y axis title from g2
index <- which(g2$layout$name == "ylab-l") # Which grob contains the y axis title?
ylab <- g2$grobs[[index]] # Extract that grob
ylab <- hinvert_title_grob(ylab) # Swap margins and fix justifications
# Put the transformed label on the right side of g1
g1 <- gtable_add_cols(g1, g2$widths[g2$layout[index, ]$l], pp$r)
g1 <- gtable_add_grob(g1, ylab, pp$t, pp$r + 1, pp$b, pp$r + 1, clip = "off", name = "ylab-r")
# Get the y axis from g2 (axis line, tick marks, and tick mark labels)
index <- which(g2$layout$name == "axis-l") # Which grob
yaxis <- g2$grobs[[index]] # Extract the grob
# yaxis is a complex of grobs containing the axis line, the tick marks, and the tick mark labels.
# The relevant grobs are contained in axis$children:
# axis$children[[1]] contains the axis line;
# axis$children[[2]] contains the tick marks and tick mark labels.
# First, move the axis line to the left
yaxis$children[[1]]$x <- unit.c(unit(0, "npc"), unit(0, "npc"))
# Second, swap tick marks and tick mark labels
ticks <- yaxis$children[[2]]
ticks$widths <- rev(ticks$widths)
ticks$grobs <- rev(ticks$grobs)
# Third, move the tick marks
ticks$grobs[[1]]$x <- ticks$grobs[[1]]$x - unit(1, "npc") + unit(-1, "mm")
# Fourth, swap margins and fix justifications for the tick mark labels
ticks$grobs[[2]] <- hinvert_title_grob(ticks$grobs[[2]])
# Fifth, put ticks back into yaxis
yaxis$children[[2]] <- ticks
# Put the transformed yaxis on the right side of g1
g1 <- gtable_add_cols(g1, g2$widths[g2$layout[index, ]$l], pp$r)
g1 <- gtable_add_grob(g1, yaxis, pp$t, pp$r + 1, pp$b, pp$r + 1, clip = "off", name = "axis-r")
# Draw it
grid.newpage()
grid.draw(g1)
# Add the legend in a viewport
vp = viewport(x = 0.3, y = 0.92, height = .2, width = .2)
pushViewport(vp)
grid.draw(leg)
upViewport()
g = grid.grab()
grid.newpage()
grid.draw(g)
Recently, I discovered that starting with version 2.2.0 of ggplot2, it is possible to add a secondary axis. Some demos: here or here; some already answered questions with this approach: here, here or here. An interesting discussion about adding a second OY axis here.
The main idea is that one needs to apply a transformation for the second OY axis. In the example below, the transformation factor is the ratio between the max values of each OY axis.
require(ggplot2)
my_factor <- 650/100
ggplot() +
geom_bar(data = df2,
aes(x = frax, y = phos, fill = type),
stat = "identity",
position = "dodge") +
geom_line(data = df1,
# Apply the factor on values appearing on second OY axis (multiplication)
aes(x = frax, y = solvb * my_factor),
colour = "blue") +
# add second OY axis; note the transformation back (division)
scale_y_continuous(sec.axis = sec_axis(trans = ~ . / my_factor,
name = "% Solvent B")) +
# final adjustments
labs(x = "Fractions",
y = "Phospho hits",
fill = "") +
theme_bw()
I have been trying to extend my scenario from here to make use of facets (specifically facet_grid()).
I have seen this example, however I can't seem to get it to work for my geom_bar() and geom_point() combo. I attempted to use the code from the example just changing from facet_wrap to facet_grid which also seemed to make the first layer not show.
I am very much a novice when it comes to grid and grobs so if someone can give some guidance on how to make P1 show up with the left y axis and P2 show up on the right y axis that would be great.
Data
library(ggplot2)
library(gtable)
library(grid)
library(data.table)
library(scales)
grid.newpage()
dt.diamonds <- as.data.table(diamonds)
d1 <- dt.diamonds[,list(revenue = sum(price),
stones = length(price)),
by=c("clarity","cut")]
setkey(d1, clarity,cut)
p1 & p2
p1 <- ggplot(d1, aes(x=clarity,y=revenue, fill=cut)) +
geom_bar(stat="identity") +
labs(x="clarity", y="revenue") +
facet_grid(. ~ cut) +
scale_y_continuous(labels=dollar, expand=c(0,0)) +
theme(axis.text.x = element_text(angle = 90, hjust = 1),
axis.text.y = element_text(colour="#4B92DB"),
legend.position="bottom")
p2 <- ggplot(d1, aes(x=clarity, y=stones, colour="red")) +
geom_point(size=6) +
labs(x="", y="number of stones") + expand_limits(y=0) +
scale_y_continuous(labels=comma, expand=c(0,0)) +
scale_colour_manual(name = '',values =c("red","green"), labels = c("Number of Stones"))+
facet_grid(. ~ cut) +
theme(axis.text.y = element_text(colour = "red")) +
theme(panel.background = element_rect(fill = NA),
panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
panel.border = element_rect(fill=NA,colour="grey50"),
legend.position="bottom")
Attempt to combine (based on example linked above)
This fails in the first for loop, I suspect to the hard coding of geom_point.points, however I don't know how to make it suit my charts (or fluid enough to suit a variety of charts)
# extract gtable
g1 <- ggplot_gtable(ggplot_build(p1))
g2 <- ggplot_gtable(ggplot_build(p2))
combo_grob <- g2
pos <- length(combo_grob) - 1
combo_grob$grobs[[pos]] <- cbind(g1$grobs[[pos]],
g2$grobs[[pos]], size = 'first')
panel_num <- length(unique(d1$cut))
for (i in seq(panel_num))
{
grid.ls(g1$grobs[[i + 1]])
panel_grob <- getGrob(g1$grobs[[i + 1]], 'geom_point.points',
grep = TRUE, global = TRUE)
combo_grob$grobs[[i + 1]] <- addGrob(combo_grob$grobs[[i + 1]],
panel_grob)
}
pos_a <- grep('axis_l', names(g1$grobs))
axis <- g1$grobs[pos_a]
for (i in seq(along = axis))
{
if (i %in% c(2, 4))
{
pp <- c(subset(g1$layout, name == paste0('panel-', i), se = t:r))
ax <- axis[[1]]$children[[2]]
ax$widths <- rev(ax$widths)
ax$grobs <- rev(ax$grobs)
ax$grobs[[1]]$x <- ax$grobs[[1]]$x - unit(1, "npc") + unit(0.5, "cm")
ax$grobs[[2]]$x <- ax$grobs[[2]]$x - unit(1, "npc") + unit(0.8, "cm")
combo_grob <- gtable_add_cols(combo_grob, g2$widths[g2$layout[pos_a[i],]$l], length(combo_grob$widths) - 1)
combo_grob <- gtable_add_grob(combo_grob, ax, pp$t, length(combo_grob$widths) - 1, pp$b)
}
}
pp <- c(subset(g1$layout, name == 'ylab', se = t:r))
ia <- which(g1$layout$name == "ylab")
ga <- g1$grobs[[ia]]
ga$rot <- 270
ga$x <- ga$x - unit(1, "npc") + unit(1.5, "cm")
combo_grob <- gtable_add_cols(combo_grob, g2$widths[g2$layout[ia,]$l], length(combo_grob$widths) - 1)
combo_grob <- gtable_add_grob(combo_grob, ga, pp$t, length(combo_grob$widths) - 1, pp$b)
combo_grob$layout$clip <- "off"
grid.draw(combo_grob)
EDIT to attempt to make workable for facet_wrap
The following code still works with facet_grid using ggplot2 2.0.0
g1 <- ggplot_gtable(ggplot_build(p1))
g2 <- ggplot_gtable(ggplot_build(p2))
pp <- c(subset(g1$layout, name == "panel", se = t:r))
g <- gtable_add_grob(g1, g2$grobs[which(g2$layout$name == "panel")], pp$t,
pp$l, pp$b, pp$l)
# axis tweaks
ia <- which(g2$layout$name == "axis-l")
ga <- g2$grobs[[ia]]
ax <- ga$children[[2]]
ax$widths <- rev(ax$widths)
ax$grobs <- rev(ax$grobs)
ax$grobs[[1]]$x <- ax$grobs[[1]]$x - unit(1, "npc") + unit(0.15, "cm")
g <- gtable_add_cols(g, g2$widths[g2$layout[ia, ]$l], length(g$widths) - 1)
g <- gtable_add_grob(g, ax, unique(pp$t), length(g$widths) - 1)
# Add second y-axis title
ia <- which(g2$layout$name == "ylab")
ax <- g2$grobs[[ia]]
# str(ax) # you can change features (size, colour etc for these -
# change rotation below
ax$rot <- 90
g <- gtable_add_cols(g, g2$widths[g2$layout[ia, ]$l], length(g$widths) - 1)
g <- gtable_add_grob(g, ax, unique(pp$t), length(g$widths) - 1)
# Add legend to the code
leg1 <- g1$grobs[[which(g1$layout$name == "guide-box")]]
leg2 <- g2$grobs[[which(g2$layout$name == "guide-box")]]
g$grobs[[which(g$layout$name == "guide-box")]] <-
gtable:::cbind_gtable(leg1, leg2, "first")
grid.draw(g)
Now that ggplot2 has secondary axis support this has become much much easier in many (but not all) cases. No grob manipulation needed.
Even though it is supposed to only allow for simple linear transformations of the same data, such as different measurement scales, we can manually rescale one of the variables first to at least get a lot more out of that property.
library(tidyverse)
max_stones <- max(d1$stones)
max_revenue <- max(d1$revenue)
d2 <- gather(d1, 'var', 'val', stones:revenue) %>%
mutate(val = if_else(var == 'revenue', as.double(val), val / (max_stones / max_revenue)))
ggplot(mapping = aes(clarity, val)) +
geom_bar(aes(fill = cut), filter(d2, var == 'revenue'), stat = 'identity') +
geom_point(data = filter(d2, var == 'stones'), col = 'red') +
facet_grid(~cut) +
scale_y_continuous(sec.axis = sec_axis(trans = ~ . * (max_stones / max_revenue),
name = 'number of stones'),
labels = dollar) +
theme(axis.text.x = element_text(angle = 90, hjust = 1),
axis.text.y = element_text(color = "#4B92DB"),
axis.text.y.right = element_text(color = "red"),
legend.position="bottom") +
ylab('revenue')
It also works nicely with facet_wrap:
Other complications, such as scales = 'free' and space = 'free' are also done easily. The only restriction is that the relationship between the two axes is equal for all facets.
EDIT: UPDATED TO GGPLOT 2.2.0
But ggplot2 now supports secondary y axes, so there is no need for grob manipulation. See #Axeman's solution.
facet_grid and facet_wrap plots generate different sets of names for plot panels and left axes. You can check the names using g1$layout where g1 <- ggplotGrob(p1), and p1 is drawn first with facet_grid(), then second with facet_wrap(). In particular, with facet_grid() the plot panels are all named "panel", whereas with facet_wrap() they have different names: "panel-1", "panel-2", and so forth. So commands like these:
pp <- c(subset(g1$layout, name == "panel", se = t:r))
g <- gtable_add_grob(g1, g2$grobs[which(g2$layout$name == "panel")], pp$t,
pp$l, pp$b, pp$l)
will fail with plots generated using facet_wrap. I would use regular expressions to select all names beginning with "panel". There are similar problems with "axis-l".
Also, your axis-tweaking commands worked for older versions of ggplot, but from version 2.1.0, the tick marks don't quite meet the right edge of the plot, and the tick marks and the tick mark labels are too close together.
Here is what I would do (drawing on code from here, which in turn draws on code from here and from the cowplot package).
# Packages
library(ggplot2)
library(gtable)
library(grid)
library(data.table)
library(scales)
# Data
dt.diamonds <- as.data.table(diamonds)
d1 <- dt.diamonds[,list(revenue = sum(price),
stones = length(price)),
by=c("clarity", "cut")]
setkey(d1, clarity, cut)
# The facet_wrap plots
p1 <- ggplot(d1, aes(x = clarity, y = revenue, fill = cut)) +
geom_bar(stat = "identity") +
labs(x = "clarity", y = "revenue") +
facet_wrap( ~ cut, nrow = 1) +
scale_y_continuous(labels = dollar, expand = c(0, 0)) +
theme(axis.text.x = element_text(angle = 90, hjust = 1),
axis.text.y = element_text(colour = "#4B92DB"),
legend.position = "bottom")
p2 <- ggplot(d1, aes(x = clarity, y = stones, colour = "red")) +
geom_point(size = 4) +
labs(x = "", y = "number of stones") + expand_limits(y = 0) +
scale_y_continuous(labels = comma, expand = c(0, 0)) +
scale_colour_manual(name = '', values = c("red", "green"), labels = c("Number of Stones"))+
facet_wrap( ~ cut, nrow = 1) +
theme(axis.text.y = element_text(colour = "red")) +
theme(panel.background = element_rect(fill = NA),
panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
panel.border = element_rect(fill = NA, colour = "grey50"),
legend.position = "bottom")
# Get the ggplot grobs
g1 <- ggplotGrob(p1)
g2 <- ggplotGrob(p2)
# Get the locations of the plot panels in g1.
pp <- c(subset(g1$layout, grepl("panel", g1$layout$name), se = t:r))
# Overlap panels for second plot on those of the first plot
g <- gtable_add_grob(g1, g2$grobs[grepl("panel", g1$layout$name)],
pp$t, pp$l, pp$b, pp$l)
# ggplot contains many labels that are themselves complex grob;
# usually a text grob surrounded by margins.
# When moving the grobs from, say, the left to the right of a plot,
# Make sure the margins and the justifications are swapped around.
# The function below does the swapping.
# Taken from the cowplot package:
# https://github.com/wilkelab/cowplot/blob/master/R/switch_axis.R
hinvert_title_grob <- function(grob){
# Swap the widths
widths <- grob$widths
grob$widths[1] <- widths[3]
grob$widths[3] <- widths[1]
grob$vp[[1]]$layout$widths[1] <- widths[3]
grob$vp[[1]]$layout$widths[3] <- widths[1]
# Fix the justification
grob$children[[1]]$hjust <- 1 - grob$children[[1]]$hjust
grob$children[[1]]$vjust <- 1 - grob$children[[1]]$vjust
grob$children[[1]]$x <- unit(1, "npc") - grob$children[[1]]$x
grob
}
# Get the y axis title from g2
index <- which(g2$layout$name == "ylab-l") # Which grob contains the y axis title? EDIT HERE
ylab <- g2$grobs[[index]] # Extract that grob
ylab <- hinvert_title_grob(ylab) # Swap margins and fix justifications
# Put the transformed label on the right side of g1
g <- gtable_add_cols(g, g2$widths[g2$layout[index, ]$l], max(pp$r))
g <- gtable_add_grob(g, ylab, max(pp$t), max(pp$r) + 1, max(pp$b), max(pp$r) + 1, clip = "off", name = "ylab-r")
# Get the y axis from g2 (axis line, tick marks, and tick mark labels)
index <- which(g2$layout$name == "axis-l-1-1") # Which grob. EDIT HERE
yaxis <- g2$grobs[[index]] # Extract the grob
# yaxis is a complex of grobs containing the axis line, the tick marks, and the tick mark labels.
# The relevant grobs are contained in axis$children:
# axis$children[[1]] contains the axis line;
# axis$children[[2]] contains the tick marks and tick mark labels.
# First, move the axis line to the left
# But not needed here
# yaxis$children[[1]]$x <- unit.c(unit(0, "npc"), unit(0, "npc"))
# Second, swap tick marks and tick mark labels
ticks <- yaxis$children[[2]]
ticks$widths <- rev(ticks$widths)
ticks$grobs <- rev(ticks$grobs)
# Third, move the tick marks
# Tick mark lengths can change.
# A function to get the original tick mark length
# Taken from the cowplot package:
# https://github.com/wilkelab/cowplot/blob/master/R/switch_axis.R
plot_theme <- function(p) {
plyr::defaults(p$theme, theme_get())
}
tml <- plot_theme(p1)$axis.ticks.length # Tick mark length
ticks$grobs[[1]]$x <- ticks$grobs[[1]]$x - unit(1, "npc") + tml
# Fourth, swap margins and fix justifications for the tick mark labels
ticks$grobs[[2]] <- hinvert_title_grob(ticks$grobs[[2]])
# Fifth, put ticks back into yaxis
yaxis$children[[2]] <- ticks
# Put the transformed yaxis on the right side of g1
g <- gtable_add_cols(g, g2$widths[g2$layout[index, ]$l], max(pp$r))
g <- gtable_add_grob(g, yaxis, max(pp$t), max(pp$r) + 1, max(pp$b), max(pp$r) + 1,
clip = "off", name = "axis-r")
# Get the legends
leg1 <- g1$grobs[[which(g1$layout$name == "guide-box")]]
leg2 <- g2$grobs[[which(g2$layout$name == "guide-box")]]
# Combine the legends
g$grobs[[which(g$layout$name == "guide-box")]] <-
gtable:::cbind_gtable(leg1, leg2, "first")
# Draw it
grid.newpage()
grid.draw(g)
I am trying to compose a dual y-axis chart using ggplot. Firstly let me say that I am not looking for a discussion on the merits of whether or not it is good practice to do so. I find them to be particularly useful when looking at time based data to identify trends in 2 discrete variables. A further discussion of this is better suited to crossvalidated in my opinion.
Kohske provides a very good example of how to do it, which I have used to great effect so far. I am however at my limits to include a legend for both y-axes. I have also seen similar questions here and here but none seem to address the issue of including a legend.
I've got a reproduceable example using the diamonds dataset from ggplot.
Data
library(ggplot2)
library(gtable)
library(grid)
library(data.table)
library(scales)
grid.newpage()
dt.diamonds <- as.data.table(diamonds)
d1 <- dt.diamonds[,list(revenue = sum(price),
stones = length(price)),
by=clarity]
setkey(d1, clarity)
Charts
p1 <- ggplot(d1, aes(x=clarity,y=revenue, fill="#4B92DB")) +
geom_bar(stat="identity") +
labs(x="clarity", y="revenue") +
scale_fill_identity(name="", guide="legend", labels=c("Revenue")) +
scale_y_continuous(labels=dollar, expand=c(0,0)) +
theme(axis.text.x = element_text(angle = 90, hjust = 1),
axis.text.y = element_text(colour="#4B92DB"),
legend.position="bottom")
p2 <- ggplot(d1, aes(x=clarity, y=stones, colour="red")) +
geom_point(size=6) +
labs(x="", y="number of stones") + expand_limits(y=0) +
scale_y_continuous(labels=comma, expand=c(0,0)) +
scale_colour_manual(name = '',values =c("red","green"), labels = c("Number of Stones"))+
theme(axis.text.y = element_text(colour = "red")) +
theme(panel.background = element_rect(fill = NA),
panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
panel.border = element_rect(fill=NA,colour="grey50"),
legend.position="bottom")
# extract gtable
g1 <- ggplot_gtable(ggplot_build(p1))
g2 <- ggplot_gtable(ggplot_build(p2))
pp <- c(subset(g1$layout, name == "panel", se = t:r))
g <- gtable_add_grob(g1, g2$grobs[[which(g2$layout$name == "panel")]], pp$t,
pp$l, pp$b, pp$l)
# axis tweaks
ia <- which(g2$layout$name == "axis-l")
ga <- g2$grobs[[ia]]
ax <- ga$children[[2]]
ax$widths <- rev(ax$widths)
ax$grobs <- rev(ax$grobs)
ax$grobs[[1]]$x <- ax$grobs[[1]]$x - unit(1, "npc") + unit(0.15, "cm")
g <- gtable_add_cols(g, g2$widths[g2$layout[ia, ]$l], length(g$widths) - 1)
g <- gtable_add_grob(g, ax, pp$t, length(g$widths) - 1, pp$b)
# draw it
grid.draw(g)
QUESTION: Does anyone have some tips on how to get the 2nd part of the legend to show?
The following are the charts produced in order p1, p2, combined p1&p2, you'll notice that the legend for p2 doesn't show in the combined chart.
p1
p2
combined p1 & p2
Similar to the technique you use above you can extract the legends, bind them and then overwrite the plot legend with them.
So starting from # draw it in your code
# extract legend
leg1 <- g1$grobs[[which(g1$layout$name == "guide-box")]]
leg2 <- g2$grobs[[which(g2$layout$name == "guide-box")]]
g$grobs[[which(g$layout$name == "guide-box")]] <-
gtable:::cbind_gtable(leg1, leg2, "first")
grid.draw(g)