是否可以在r中生成3D条形图

fcg9iug3  于 2023-01-10  发布在  其他
关注(0)|答案(2)|浏览(134)

你能帮我生成如下的3D图吗?

dat <- tibble::tribble(
  ~subject, ~response, ~duration,
  '1', 10, 20,
  '2', -7, 30,
  '3', 5, 20,
  '4', 7, 50,
  '5', -5, 40
)

wrrgggsh

wrrgggsh1#

下面是使用plot3D时与原始代码更接近的代码
首先绘制框、轴、标题和平面:

library(plot3D)

persp3D(c(min(as.numeric(dat$subject)) - 1, max(as.numeric(dat$subject)) + 1), 
        c(0, max(dat$duration)),d = 50,  phi = 30, theta = 55, xlab = "subject",
        ylab = "Duration", zlab = "Response", ticktype = "detailed",
        matrix(rep(range(dat$response), 2), 2, 2), lwd = 3,
        col.panel = "gray95", colkey = FALSE, bty = "u")

title("Tumor response and duration", cex.main = 2)

rect3D(min(as.numeric(dat$subject)) - 1, 0, min(dat$response), 
       max(as.numeric(dat$subject)) + 1,
       max(dat$duration), NULL,
       col = "#e7e7e7",  add = TRUE)

rect3D(min(as.numeric(dat$subject)) - 1, 0, min(dat$response),
       NULL,
       max(dat$duration),
       max(dat$response),
       col = "#e0e0e0", add = TRUE)

rect3D(min(as.numeric(dat$subject)) - 1, max(dat$duration), min(dat$response),
       max(as.numeric(dat$subject)) + 1, NULL,
       max(dat$response),
       col = "#f0f0f0", add = TRUE)

rect3D(min(as.numeric(dat$subject)) - 1, 0, 0, 
       max(as.numeric(dat$subject)) + 1,
       max(dat$duration), NULL,
       col = "#FFFFFF20", border = "gray50", add = TRUE)

现在使用rect3D的条形图

for(i in seq(nrow(dat))) {
  rect3D(as.numeric(dat$subject[i]) - 0.2, 0, 0, 
         as.numeric(dat$subject[i]) + 0.2, dat$duration[i], NULL,
         col = "#7c95ca", add = TRUE)
}

for(i in seq(nrow(dat))) {
  rect3D(as.numeric(dat$subject[i]) - 0.2, 0, 0, 
         as.numeric(dat$subject[i]) + 0.2, NULL, 
         dat$response[i],
         col = "#de7e6f", add = TRUE)
}

最后,添加方框轮廓:

lines3D(c(min(as.numeric(dat$subject)) - 1, max(as.numeric(dat$subject)) + 1),
        c(0, 0), rep(max(dat$response), 2), lty = 2, add = TRUE, col = "black")

lines3D(rep(max(as.numeric(dat$subject)) + 1, 2),
        c(0, max(dat$duration)),  rep(max(dat$response), 2), 
        lty = 2, add = TRUE, col = "black")

lines3D(rep(max(as.numeric(dat$subject)) + 1, 2),
        c(0, 0),  range(dat$response), 
        lty = 2, add = TRUE, col = "black")

lines3D(c(rep(min(as.numeric(dat$subject)) - 1, 3),
          rep(max(as.numeric(dat$subject)) + 1, 3),
          min(as.numeric(dat$subject)) - 1),
        c(0, 0, rep(max(dat$duration), 3), 0, 0),
        c(min(dat$response), rep(max(dat$response), 3), 
          rep(min(dat$response),3)),add = TRUE, col = "black", lwd = 5)

然而,正如其他人在评论中指出的那样,尽管这样的图表面上令人印象深刻,但实际上不如用更熟悉、更优雅的2-D图显示数据有用。这样的图也更容易创建,并且以更可读的格式包含所有相同的信息

library(ggplot2)

ggplot(dat, aes(response, duration)) + 
  geom_point(size = 6, aes(color = "(subject id)"), alpha = 0.5) +
  geom_text(aes(label = subject), nudge_x = 0.5, nudge_y = 1) +
  geom_hline(yintercept = 0) +
  geom_vline(xintercept = 0) +
  ggtitle("Tumor response versus duration") +
  scale_color_manual(NULL, values = "navy") +
  theme_minimal(base_size = 20) +
  theme(plot.margin = margin(20, 20, 50, 20),
        plot.title = element_text(size = 32, color = "gray20",
                                  margin = margin(10, 10, 50, 10)))

7kjnsjlb

7kjnsjlb2#

我想你得自己写了。这里有几个半心半意的尝试;你得把它们清理干净。

library(scatterplot3d)
dat <- tibble::tribble(
  ~subject, ~response, ~duration,
  '1', 10, 20,
  '2', -7, 30,
  '3', 5, 20,
  '4', 7, 50,
  '5', -5, 40
)

rectx <- c(-0.4, 0.4, 0.4, -0.4, -0.4, NA)
recty <- c(0, 0, 1, 1, 0, NA)

rectangles <- data.frame(x = numeric(), y = numeric(), z = numeric() )
for (i in seq_len(nrow(dat))) {
  subj <- as.numeric(dat$subject[i])
  rectangles <- rbind(rectangles, 
                      data.frame(x = rectx + subj,
                                 y = 0,
                                 z = recty*dat$response[i]),
                      data.frame(x = rectx + subj,
                                 y = recty*dat$duration[i],
                                 z = 0))
}

with(dat, scatterplot3d(x = rectangles,
                        type= "l",
                        xlab = "Subject",
                        ylab = "Duration",
                        zlab = "Response"))

i <- seq_len(nrow(rectangles))
drop <- which(is.na(rectangles[i, 1]) )
drop <- c(drop, drop-1)
rectangles <- rectangles[!(i %in% drop),]

library(rgl)
open3d()
#> glX 
#>   1
quads3d(rectangles, col = c(rep("red",4), rep("blue", 4)))
aspect3d(1,1,1)
decorate3d(xlab = "Subject", 
           ylab = "Duration",
           zlab = "Response")

创建于2023年1月7日,使用reprex v2.0.2

相关问题