Is it possible to generate a 3D bar chart in r-CodePudding

Could you please help me how to generate the 3D plot something as below?

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

CodePudding user response：

Here's something a little closer to the original using plot3D

First draw the box, axes, title and plane:

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)

Now the bars using 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)
}

Finally, add the box outlines:

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)

However, as others have pointed out in the comments, although such a plot is superficially impressive, it is actually less useful than displaying the data in a more familiar, elegant 2-D plot. Such a plot is also far easier to create, and contains all the same information in a more readable format

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)))

CodePudding user response：

I think you'll have to write that yourself. Here are a couple of half-hearted attempts; you'll need to clean them up a lot.

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")

^{Created on 2023-01-07 with reprex v2.0.2}