R: add calibrated axes to PCA biplot in ggplot2

Question

I am working on an ordination package using ggplot2. Right now I am constructing biplots in the traditional way, with loadings being represented with arrows. I would also be interested though to use calibrated axes and represent the loading axes as lines through the origin, and with loading labels being shown outside the plot region. In base R this is implemented in

library(OpenRepGrid)
biplot2d(boeker)

but I am looking for a ggplot2 solution. Would anybody have any thoughts how to achieve something like this in ggplot2? Adding the variable names outside the plot region could be done like here I suppose, but how could the line segments outside the plot region be plotted?

Currently what I have is

install.packages("devtools")
library(devtools)
install_github("fawda123/ggord")
library(ggord)
data(iris)
ord <- prcomp(iris[,1:4],scale=TRUE)
ggord(ord, iris$Species)

The loadings are in ord$rotation

                    PC1         PC2        PC3        PC4
Sepal.Length  0.5210659 -0.37741762  0.7195664  0.2612863
Sepal.Width  -0.2693474 -0.92329566 -0.2443818 -0.1235096
Petal.Length  0.5804131 -0.02449161 -0.1421264 -0.8014492
Petal.Width   0.5648565 -0.06694199 -0.6342727  0.5235971

How could I add the lines through the origin, the outside ticks and the labels outside the axis region (plossibly including the cool jittering that is applied above for overlapping labels)?

NB I do not want to turn off clipping, since some of my plot elements could sometimes go outside the bounding box

EDIT: Someone else apparently asked a similar question before, though the question is still without an answer. It points out that to do something like this in base R (though in an ugly way) one can do e.g.

plot(-1:1, -1:1, asp = 1, type = "n", xaxt = "n", yaxt = "n", xlab = "", ylab = "")
abline(a = 0, b = -0.75)
abline(a = 0, b = 0.25)
abline(a = 0, b = 2)
mtext("V1", side = 4, at = -0.75*par("usr")[2])
mtext("V2", side = 2, at = 0.25*par("usr")[1])
mtext("V3", side = 3, at = par("usr")[4]/2)

Minimal workable example in ggplot2 would be

library(ggplot2)
df <- data.frame(x = -1:1, y = -1:1)
dfLabs <- data.frame(x = c(1, -1, 1/2), y = c(-0.75, -0.25, 1), labels = paste0("V", 1:3))
p <- ggplot(data = df, aes(x = x, y = y)) +  geom_blank() +
  geom_abline(intercept = rep(0, 3), slope = c(-0.75, 0.25, 2)) +
  theme_bw() + coord_cartesian(xlim = c(-1, 1), ylim = c(-1, 1)) +
  theme(axis.title = element_blank(), axis.text = element_blank(), axis.ticks = element_blank(),
        panel.grid = element_blank())
p + geom_text(data = dfLabs, mapping = aes(label = labels))

but as you can see no luck with the labels, and I am looking for a solution that does not require one to turn off clipping.

EDIT2: bit of a related question is how I could add custom breaks/tick marks and labels, say in red, at the top of the X axis and right of the Y axis, to show the coordinate system of the factor loadings? (in case I would scale it relative to the factor scores to make the arrows clearer, typically combined with a unit circle)

Maybe use geom_path() to get your lines? and then also use custom axes? See here for tips on that. However, Hadley doesn't like multiple plots on top of each other so you might not able to make what you want easily (see Hadley's answer here). — Richard Erickson
Yes for the lines I think I can manage (although I would run into problems I think if I would let the lines run outside the plot region, as I don't want to disable clipping in my case). For the labels would you suggest to place them at specific breaks then, but simply use the standard tick marks for them? (not entirely what I want, as they should ideally be oblique) And how can I get different breaks and labels on all 4 sides of the graph? — Tom Wenseleers
And yes re. Hadleys insistance of not wanting to support different scales: that gets me into trouble for biplots, as I still don't manage to add specific breaks and labels in a different colour at the top of the Y and the right of the X axis - if you would happen to know how to do that let me know; bit of a related problem.... — Tom Wenseleers
I'm not sure how to do the labels. As a hack, you might put the names inside next to the lines with geom_text, but that doesn't seem to do what you want. The question is if it is good enough? — Richard Erickson
Yeah on the inside is not good enough for me I'm afraid - think I'll have to wait for a reply of one of the gurus like baptiste... — Tom Wenseleers

baptiste baptiste · Accepted Answer · 2015-08-16T09:49:38

Maybe as an alternative, you could remove the default panel box and axes altogether, and draw a smaller rectangle in the plot region instead. Clipping the lines not to clash with the text labels is a bit tricky, but this might work.

df <- data.frame(x = -1:1, y = -1:1)
dfLabs <- data.frame(x = c(1, -1, 1/2), y = c(-0.75, -0.25, 1), 
                     labels = paste0("V", 1:3))
p <- ggplot(data = df, aes(x = x, y = y)) +  
  geom_blank() +
  geom_blank(data=dfLabs, aes(x = x, y = y)) +
  geom_text(data = dfLabs, mapping = aes(label = labels)) +
  geom_abline(intercept = rep(0, 3), slope = c(-0.75, 0.25, 2)) +
  theme_grey() +
  theme(axis.title = element_blank(), 
        axis.text = element_blank(), 
        axis.ticks = element_blank(),
        panel.grid = element_blank()) + 
  theme()

library(grid)
element_grob.element_custom <- function(element, ...)  {
  rectGrob(0.5,0.5, 0.8, 0.8, gp=gpar(fill="grey95"))
}

panel_custom <- function(...){ # dummy wrapper
  structure(
    list(...), 
    class = c("element_custom","element_blank", "element") 
  ) 

}

p <- p + theme(panel.background=panel_custom())


clip_layer <- function(g, layer="segment", width=1, height=1){
  id <- grep(layer, names(g$grobs[[4]][["children"]]))
  newvp <- viewport(width=unit(width, "npc"), 
                    height=unit(height, "npc"), clip=TRUE)
  g$grobs[[4]][["children"]][[id]][["vp"]] <- newvp

  g
}

g <- ggplotGrob(p)
g <- clip_layer(g, "segment", 0.85, 0.85)
grid.newpage()
grid.draw(g)

R: add calibrated axes to PCA biplot in ggplot2

2 Answers