r - R:将校准轴添加到ggplot2中的PCA双图

Question

我正在使用ggplot2处理整理包。现在，我正在以传统方式构造双兵部队，并用箭头表示载荷。我也想使用校准轴并将加载轴表示为通过原点的线，并在绘图区域外部显示加载标签。在R的基础上实现

library(OpenRepGrid)
biplot2d(boeker)

但我正在寻找 ggplot2解决方案。有人会想到如何在 ggplot2中实现这样的目标吗？我想可以在变量区域外添加变量名称 like here，但是如何在变量区域外绘制线段呢？

目前我所拥有的是

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

负载在 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

如何添加通过原点，外部刻度线和轴区域外部的标签的线（明显包括上面重叠标签所应用的冷抖动）？

注意：由于某些绘图元素有时可能会超出边界框，因此我不想关闭剪辑

编辑： Someone else apparently asked a similar question before，尽管问题仍然没有答案。它指出在基数R中做这样的事情（尽管很丑），例如

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)

ggplot2中的最小可行示例是

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))

但是正如您所看到的那样，标签没有运气，我正在寻找一种不需要关闭裁剪的解决方案。

EDIT2：一个相关问题的一点是如何在X轴顶部和Y轴右侧添加红色的自定义中断/刻度线和标签，以红色显示，以显示因子加载的坐标系？ （以防我相对于因子分数缩放比例，使箭头更清晰，通常与单位圆结合使用）

Answer 1

也许可以选择完全删除默认的面板框和轴，然后在绘图区域中绘制一个较小的矩形。剪裁线条以免与文本标签发生冲突有点棘手，但这可能有用。

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)