如何在R中创建具有拟合曲线的3D Barplot

Question

我正在尝试制作一个类似于

library(rgl)
library(barplot3d)
library(tidyverse)

x_mat<- matrix(rep(-1:1, each=3),nrow = 3) #x coordinates
y_mat<- matrix(rev(rep(-1:1, each=3)),nrow = 3, byrow = TRUE) #y coordinates

df<- data.frame(x = as.vector(x_mat), y = as.vector(y_mat)) #dataframe
set.seed(5)
df<- df %>% mutate(z= x^2+ y^2 + rnorm(n = 9, mean = 0, sd = 0.1)) #add elevation values

m<- lm(z ~ I(x^2)+I(y^2)+I(x*y)+x+y, data = df) #fitted curve

rgl.open()
rgl::plot3d(m)
barplot3d(rows=3,cols=3, z=df$z,scalexy=1, gap=0, alpha=0.4,theta=30,phi=50,
          topcolors = "gray", gridlines = TRUE)

更新：更复杂的示例

该曲线似乎并未与当前解决方案正确地相交，以进行非对称曲线（已修复在大多数更新的答案中）。

library(rgl)
library(barplot3d)
library(tidyverse)

x_mat<- matrix(rep(-1:1, each=3),nrow = 3) #x coordinates
y_mat<- matrix(rev(rep(-1:1, each=3)),nrow = 3, byrow = TRUE) #y coordinates
A<- 0.2
B<- 0.2
C<- 0.4
D<- 0.4
E<- 0

df<- data.frame(x = as.vector(x_mat), y = as.vector(y_mat)) #dataframe
df<- df %>% mutate(z= A*x^2 + B*y^2 + C*x*y + D*x + E*y) #add elevation values
z_mat<- matrix(data = df$z, nrow=3)

m<- lm(z ~ I(x^2)+I(y^2)+I(x*y)+x+y, data = df) #fitted curve
df$zpred<- predict(m, data.frame(x=df$x, y=df$y))
round(df$z-df$zpred,10) #Predictions should fit observations almost exactly (i.e. intersect exactly with bars)
#0 0 0 0 0 0 0 0 0 

n<- 10
xvals <- seq(-1, 1, len = n)
xmat <- replicate(n, seq(1.5, 3.5, len = n))
ymat <- t(xmat)
pred <- expand.grid(x = xvals, y = xvals)
zmat <- matrix(predict(m, pred), nrow = n, ncol = n)

barplot3d(rows=3,cols=3, z=df$z, gap=0, alpha=0.4, phi = 45,
          topcolors = "gray", sidecolors = "cyan", linecolors= "blue", gridlines = FALSE, zlabels = FALSE)
surface3d(x = xmat, y = zmat,  z = ymat-5, color = "purple", alpha = 0.7)
axes3d()

Answer 1

如您所知，您的3D表面相对于应有的位置旋转90度。这不是你的错；与其他rgl形状相比，这只是barplot3d的方式之间的区别。您还需要一些转移和重新缩放才能使其适合。

barplot3d(rows=3,cols=3, z=df$z, gap=0, alpha=0.4, phi = 45,
          topcolors = "gray", gridlines = TRUE)

xvals <- seq(-1.5, 1.5, len = 10)
xmat <- replicate(10, seq(1, 4, len = 10))
ymat <- t(xmat)
pred <- expand.grid(x = xvals, y = xvals)
zmat <- matrix(predict(m, pred), 10, 10)

surface3d(xmat, zmat, color = "gold", alpha = 0.5, ymat - 5)

---

更新

要删除最高栏上方​​的点，只需将它们设置为na。但是，当您执行此操作时，您可能想增加分辨率：

xvals <- seq(-1.5, 1.5, len = 100)
xmat <- replicate(100, seq(1, 4, len = 100))
ymat <- t(xmat) - 5

pred <- expand.grid(x = xvals, y = xvals)
zmat <- matrix(predict(m, pred), 100, 100)

zmat[zmat > 2] <- NA

barplot3d(rows=3,cols=3, z=df$z, gap=0, alpha=0.4, phi = 45,
          topcolors = "gray", gridlines = TRUE)

surface3d(xmat, zmat, color = "gold", alpha = 0.5, ymat)

请注意，这给图形带来了不可避免的破烂边缘，

替代方案是缩小计算z的x，y网格：

xvals <- seq(-1, 1, len = 100)
xmat <- replicate(100, seq(1.5, 3.5, len = 100))
ymat <- t(xmat) - 5

pred <- expand.grid(x = xvals, y = xvals)
zmat <- matrix(predict(m, pred), 100, 100)

barplot3d(rows=3,cols=3, z=df$z, gap=0, alpha=0.4, phi = 45,
          topcolors = "gray", gridlines = TRUE)

surface3d(xmat, zmat, ymat, color = "gray20", alpha = 0.5)

---

进一步更新

看起来好像我们需要双翻转以使z值正确：

barplot3d(rows=3,cols=3, z=df$z, gap=0, alpha=0.4, phi = 45,
          topcolors = "gray", sidecolors = "cyan", linecolors= "blue", 
          gridlines = FALSE, zlabels = FALSE)
surface3d(x = xmat, y = t(apply(t(apply(zmat, 1, rev)), 2, rev)),  
          z = ymat-5, color = "purple", alpha = 0.7)
axes3d()