如何用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而不是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))

以下是将其添加到您提供的数据中的示例.请注意,我把它放在文本之前(下面),并将参数命名为clear(可能是该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包(v0.2.0)于2018-08-01创建.