Plotting Ellipse3d in R Plotly with surface ellipse

问题

Similar to the question here but this didn't give me excatly what I needed and I couldn't figure it out: Plot ellipse3d in R plotly?. I want to recreate rgl's ellipse3d and surface ellipsoid in plotly. I know there there was an anwer which allowed plotting of an ellipse but as individual opaque markers, I need to get it as a surface ellipsoid that's slightly opaque so I can still see the data points in the ellipsoid.

I tried to figure out how dww's comment for "add_surface" instead works but couldn't figure it out.... Can anyone help please?

if (!require("rgl")) install.packages("rgl")
dt <- cbind(x = rnorm(100), y = rnorm(100), z = rnorm(100))
ellipse <- ellipse3d(cov(dt))
plot3d(dt)
plot3d(ellipse, add = T, color = "red", alpha = 0.5)

dww's answer was:

if (!require("plotly")) install.packages("plotly")
if (!require("rgl")) install.packages("rgl")
dt <- cbind(x = rnorm(100), y = rnorm(100), z = rnorm(100))
ellipse <- ellipse3d(cov(dt))

p <- plot_ly(mode = 'markers') %>% 
  add_trace(type = 'scatter3d', size = 1, 
  x = ellipse$vb[1,], y = ellipse$vb[2,], z = ellipse$vb[3,], 
  opacity=0.01) %>% 
  add_trace(type = 'scatter3d', x = dt[,1], y = dt[,2], z = dt[,3])
p

# shows more obviously what dww's code does to create the visual ellipsoid
w <- plot_ly(mode = 'markers') %>% 
  add_trace(type = 'scatter3d',  
  x = ellipse$vb[1,], y = ellipse$vb[2,], z = ellipse$vb[3,], 
  opacity=0.5) %>% 
  add_trace(type = 'scatter3d', x = dt[,1], y = dt[,2], z = dt[,3])
w

Their comment on how to use add_surface was

Note that for simplicity, I plotted the ellipse as a cloud using markers. If you want to use add_surface instead, you will have to first convert the ellipse into a different format, with a vector of x locations, a vector of y locations, z as a matrix (dimensions equal to x by y). You'll also need to split the z values into two separate surface layers one for the top half of the ellipsoid and one for the bottom. I don't have time right now to do all this, but if you get stuck I can work this out later

回答1:

This is my solution if anyone is interested in it. This allows using of the buttons in plotly to toggle the ellipsoid on and off so that you can still hover over and select data points inside the ellipsoid when desired:

if (!require("rgl")) install.packages("rgl", dependencies=TRUE, repos="http://cran.rstudio.com/")
if (!require("plotly")) install.packages("plotly", dependencies=TRUE, repos="http://cran.rstudio.com/")    
dt <- cbind(x = rnorm(100), y = rnorm(100), z = rnorm(100))
ellipse <- ellipse3d(cov(dt))

updatemenus <- list(
  list(
    active = 0,
    type= 'buttons',
    buttons = list(
      list(
        label = "Ellipsoid",
        method = "update",
        args = list(list(visible = c(TRUE, TRUE)))),
      list(
        label = "No Ellipsoid",
        method = "update",
        args = list(list(visible = c(TRUE, FALSE)))))
  )
)

plot<- plot_ly()%>%
  # Plot raw scatter data points
  add_trace(data = dt, x = dt[,1], y = dt[,2], z = dt[,3],
            type = "scatter3d", mode = 'markers', marker = list(size = 3))  %>%
  # Plot ellipsoid 
  add_trace(x=ellipse$vb [1,], y=ellipse$vb [2,], z=ellipse$vb [3,], 
            type='mesh3d', alphahull = 0, opacity = 0.4)%>%
  # Axes Titles
  layout(updatemenus = updatemenus)
plot

回答2:

Here is a possibility, using the mesh3d type, and with the help of the misc3d package.

pts <- cbind(x = rnorm(10), y = rnorm(10), z = rnorm(10))
C <- chol(cov(pts))
SVD <- svd(t(C))
A <- solve(t(SVD$u)) %*% diag(SVD$d)
cr <- colMeans(pts)

r <- sqrt(qchisq(0.95,3)) 

fx <- function(u,v){
  cr[1] + r*(A[1,1]*cos(u)*cos(v) + A[1,2]*cos(u)*sin(v) + A[1,3]*sin(u))
}
fy <- function(u,v){
  cr[2] + r*(A[2,1]*cos(u)*cos(v) + A[2,2]*cos(u)*sin(v) + A[2,3]*sin(u))
}
fz <- function(u,v){
  cr[3] + r*(A[3,1]*cos(u)*cos(v) + A[3,2]*cos(u)*sin(v) + A[3,3]*sin(u))
}

library(misc3d)
tris <- parametric3d(fx, fy, fz, 
                     umin=-pi/2, umax=pi/2, vmin=0, vmax=2*pi, 
                     n=100, engine="none")

n <- nrow(tris$v1)
cont <- matrix(NA_real_, ncol=3, nrow=3*n)
cont[3*(1:n)-2,] <- tris$v1
cont[3*(1:n)-1,] <- tris$v2
cont[3*(1:n),] <- tris$v3
idx <- matrix(0:(3*n-1), ncol=3, byrow=TRUE)

library(plotly)
p <- plot_ly() %>%
  add_trace(type = "mesh3d",
            x = cont[,1], y = cont[,2], z = cont[,3],
            i = idx[,1], j = idx[,2], k = idx[,3],
            opacity = 0.3) %>% 
  add_trace(type = "scatter3d", mode = "markers",
            data = as.data.frame(pts), 
            x = ~x, y = ~y, z = ~z, 
            marker = list(size = 5)) %>% 
  layout(scene = list(aspectmode = "data"))

To add some colors:

midpoints <- (tris$v1 + tris$v2 + tris$v3)/3
distances <- apply(midpoints, 1, function(x) crossprod(x-cr))
intervals <- cut(distances, 256)
colorsPalette <- viridisLite::viridis(256)
colors <- colorsPalette[as.integer(intervals)]

p <- plot_ly() %>%
  add_trace(type = "mesh3d",
            x = cont[,1], y = cont[,2], z = cont[,3],
            i = idx[,1], j = idx[,2], k = idx[,3],
            facecolor = colors,
            opacity = 0.3) %>% 
  add_trace(type = "scatter3d", mode = "markers",
            data = as.data.frame(pts), 
            x = ~x, y = ~y, z = ~z, 
            marker = list(size = 5)) %>% 
  layout(scene = list(aspectmode = "data"))

Another solution with the Rvcg package. We use the vcgSphere function which generates a triangulated sphere.

sphr <- Rvcg::vcgSphere() # triangualted sphere
library(rgl) # to use scale3d and transform3d
ell <- scale3d(transform3d(sphr, A), r, r, r)
vs <- ell$vb[1:3,] + cr
idx <- ell$it - 1
p <- plot_ly() %>%
  add_trace(type="mesh3d",
  x = vs[1,], y = vs[2,], z = vs[3,],
  i = idx[1,], j = idx[2,], k = idx[3,],
  opacity = 0.3) %>% 
  add_trace(type = "scatter3d", mode = "markers",
            data = as.data.frame(pts), 
            x = ~x, y = ~y, z = ~z, 
            marker = list(size = 5)) %>% 
  layout(scene = list(aspectmode = "data"))

来源：https://stackoverflow.com/questions/50412858/plotting-ellipse3d-in-r-plotly-with-surface-ellipse

标签

plotly

ellipse

r-plotly