R:将校准轴添加到 ggplot2 中的 PCA 双标图
R: add calibrated axes to PCA biplot in ggplot2
我正在使用 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,尽管问题仍然没有答案。它指出,要在 base 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:一个相关的问题是我如何添加自定义 breaks/tick 标记和标签,比如在 X 轴的顶部和 Y 轴的右侧,以显示坐标系的因素负荷? (以防我将其相对于因子分数进行缩放以使箭头更清晰,通常与单位圆结合使用)
也许作为替代方案,您可以完全删除默认的面板框和轴,并在绘图区域中绘制一个较小的矩形。剪裁线条以使其不与文本标签冲突有点棘手,但这可能会奏效。
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)
这个怎么样:
使用以下代码。
如果您还希望标签位于顶部和右侧,请查看:
http://rpubs.com/kohske/dual_axis_in_ggplot2
require(ggplot2)
data(iris)
ord <- prcomp(iris[,1:4],scale=TRUE)
slope <- ord$rotation[,2]/ord$rotation[,1]
p <- ggplot() +
geom_point(data = as.data.frame(ord$x), aes(x = PC1, y = PC2)) +
geom_abline(data = as.data.frame(slope), aes(slope=slope))
info <- ggplot_build(p)
x <- info$panel$ranges[[1]]$x.range[1]
y <- info$panel$ranges[[1]]$y.range[1]
p +
scale_x_continuous(breaks=y/slope, labels=names(slope)) +
scale_y_continuous(breaks=x*slope, labels=names(slope)) +
theme(axis.text.x = element_text(angle=90, vjust=0.5),
panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
axis.title.x=element_blank(),
axis.title.y=element_blank())
我正在使用 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,尽管问题仍然没有答案。它指出,要在 base 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:一个相关的问题是我如何添加自定义 breaks/tick 标记和标签,比如在 X 轴的顶部和 Y 轴的右侧,以显示坐标系的因素负荷? (以防我将其相对于因子分数进行缩放以使箭头更清晰,通常与单位圆结合使用)
也许作为替代方案,您可以完全删除默认的面板框和轴,并在绘图区域中绘制一个较小的矩形。剪裁线条以使其不与文本标签冲突有点棘手,但这可能会奏效。
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)
这个怎么样:
使用以下代码。 如果您还希望标签位于顶部和右侧,请查看: http://rpubs.com/kohske/dual_axis_in_ggplot2
require(ggplot2)
data(iris)
ord <- prcomp(iris[,1:4],scale=TRUE)
slope <- ord$rotation[,2]/ord$rotation[,1]
p <- ggplot() +
geom_point(data = as.data.frame(ord$x), aes(x = PC1, y = PC2)) +
geom_abline(data = as.data.frame(slope), aes(slope=slope))
info <- ggplot_build(p)
x <- info$panel$ranges[[1]]$x.range[1]
y <- info$panel$ranges[[1]]$y.range[1]
p +
scale_x_continuous(breaks=y/slope, labels=names(slope)) +
scale_y_continuous(breaks=x*slope, labels=names(slope)) +
theme(axis.text.x = element_text(angle=90, vjust=0.5),
panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
axis.title.x=element_blank(),
axis.title.y=element_blank())