r - 如何使用 ggplot2 在 R 中绘制钻石？

Question

我正在尝试在 R 中复制以下图片，特别是使用 ggplot2

我能够绘制红色 rss 轮廓线，但我不知道如何绘制钻石(如左图中的那个)。 “预期输出”应该是一种绘制具有给定边长的钻石的方法。

编辑:这是一个简短的可重复示例，用于在以下图中随机添加钻石:

mlb<- read.table('https://umich.instructure.com/files/330381/download?download_frd=1', as.is=T, header=T)
str(mlb)

fit<-lm(Height~Weight+Age-1, data = as.data.frame(scale(mlb[,4:6])))
points = data.frame(x=c(0,fit$coefficients[1]),y=c(0,fit$coefficients[2]),z=c("(0,0)","OLS Coef"))

Y=scale(mlb$Height)
X = scale(mlb[,c(5,6)])
beta1=seq(-0.556, 1.556, length.out = 100)
beta2=seq(-0.661, 0.3386, length.out = 100)
df <- expand.grid(beta1 = beta1, beta2 = beta2)

b = as.matrix(df)
df$sse <- rep(t(Y)%*%Y,100*100) - 2*b%*%t(X)%*%Y + diag(b%*%t(X)%*%X%*%t(b))

base <- ggplot() + 
  stat_contour(data=df, aes(beta1, beta2, z = sse),breaks = round(quantile(df$sse, seq(0, 0.2, 0.03)), 0), 
               size = 0.5,color="darkorchid2",alpha=0.8) +

  scale_x_continuous(limits = c(-0.4,1))+
  scale_y_continuous(limits = c(-0.55,0.4))+
  geom_point(data = points,aes(x,y))+
  geom_text(data = points,aes(x,y,label=z),vjust = 2,size=3.5)    
  base

Answer 1

您可以使用 geom_polygon 绘制形状。

library(ggplot2)
df <- data.frame(x = c(1, 0, -1, 0), y = c(0, 1, 0, -1))
ggplot(df) + geom_polygon(aes(x = x, y = y))

如果你想从中心和边长生成坐标，你可以变换一个基本矩阵。您还可以通过将坐标提供给 geom 的 data 参数而不是 ggplot() 来将其与现有绘图结合起来，如图所示。如果您希望角到中心作为参数而不是边长，请更改 sqrt2 缩放比例。

diamond <- function(side_length, center) {
  base <- matrix(c(1, 0, 0, 1, -1, 0, 0, -1), nrow = 2) * sqrt(2) / 2
  trans <- (base * side_length) + center
  as.data.frame(t(trans))
}

ggplot() + geom_polygon(data = diamond(2, c(1, 2)), mapping = aes(x = V1, y = V2))

这是一个将其添加到您提供的数据中的示例。请注意，我将它放在文本之前(下方)，并将参数命名为清晰(可能是该 object coercible by fortify 错误的来源。

mlb <- read.table("https://umich.instructure.com/files/330381/download?download_frd=1", as.is = T, header = T)

fit <- lm(Height ~ Weight + Age - 1, data = as.data.frame(scale(mlb[, 4:6])))
points <- data.frame(x = c(0, fit$coefficients[1]), y = c(0, fit$coefficients[2]), z = c("(0,0)", "OLS Coef"))

Y <- scale(mlb$Height)
X <- scale(mlb[, c(5, 6)])
beta1 <- seq(-0.556, 1.556, length.out = 100)
beta2 <- seq(-0.661, 0.3386, length.out = 100)
df <- expand.grid(beta1 = beta1, beta2 = beta2)

b <- as.matrix(df)
df$sse <- rep(t(Y) %*% Y, 100 * 100) - 2 * b %*% t(X) %*% Y + diag(b %*% t(X) %*% X %*% t(b))

ggplot(df) +
  stat_contour(aes(beta1, beta2, z = sse),
               breaks = round(quantile(df$sse, seq(0, 0.2, 0.03)), 0),
               size = 0.5, color = "darkorchid2", alpha = 0.8
  ) +
  geom_polygon(data = diamond(0.1, c(0, 0)), mapping = aes(x = V1, y = V2), fill = "cadetblue1") +
  scale_x_continuous(limits = c(-0.4, 1)) +
  scale_y_continuous(limits = c(-0.55, 0.4)) +
  geom_point(data = points, aes(x, y)) +
  geom_text(data = points, aes(x, y, label = z), vjust = 2, size = 3.5)
#> Warning: Removed 4215 rows containing non-finite values (stat_contour).

由 reprex package 创建于 2018 年 8 月 1 日(v0.2.0)。