R + plotly : solid of revolution

Question

我有一个函数r(x)我想围绕 x 旋转轴获得 solid of revolution我想添加到现有的 plot_ly使用 add_surface 绘制(由 x 着色)。
这是一个例子:

library(dplyr)
library(plotly)

# radius depends on x
r <- function(x) x^2

# interval of interest
int <- c(1, 3)

# number of points along the x-axis
nx <- 20

# number of points along the rotation
ntheta <- 36

# set x points and get corresponding radii
coords <- data_frame(x = seq(int[1], int[2], length.out = nx), r = r(x))

# for each x: rotate r to get y and z coordinates
# edit: ensure 0 and pi are both amongst the angles used
coords %<>%
  rowwise() %>%
  do(data_frame(x = .$x, r = .$r,
                theta = seq(0, pi, length.out = ntheta / 2 + 1) %>%
                c(pi + .[-c(1, length(.))]))) %>%

  ungroup %>%
  mutate(y = r * cos(theta), z = r * sin(theta))

# plot points to make sure the coordinates define the desired shape
coords %>%
  plot_ly(x = ~x, y = ~y, z = ~z, color = ~x) %>%
  add_markers()

如何生成由上述点指示的形状为 plotly表面(理想情况下两端都是开放的)？

编辑 (1) :
这是我迄今为止最好的尝试:

# get all x & y values used (sort to connect halves on the side)
xs <-
  unique(coords$x) %>%
  sort
ys <-
  unique(coords$y) %>%
  sort

# for each possible x/y pair: get z^2 value
coords <-
  expand.grid(x = xs, y = ys) %>%
  as_data_frame %>%
  mutate(r = r(x), z2 = r^2 - y^2)

# format z coordinates above x/y plane as matrix where columns
# represent x and rows y
zs <- matrix(sqrt(coords$z2), ncol = length(xs), byrow = TRUE)

# format x coordiantes as matrix as above (for color gradient)
gradient <-
  rep(xs, length(ys)) %>%
  matrix(ncol = length(xs), byrow = TRUE)
  
# plot upper half of shape as surface
p <- plot_ly(x = xs, y = ys, z = zs, surfacecolor = gradient,
             type = "surface", colorbar = list(title = 'x'))

# plot lower have of shape as second surface
p %>%
  add_surface(z = -zs, showscale = FALSE)

虽然这给出了所需的形状，

它有接近 x 的“ Razor 齿”/y飞机。

两半部分不接触。 (通过在 0 向量中包含 pi 和 theta 来解决)

我不知道如何通过 x 给它上色而不是 z (尽管到目前为止我并没有对此进行过多研究)。 (由gradient 矩阵解析)

编辑 (2) :
这是使用单个表面的尝试:

# close circle in y-direction
ys <- c(ys, rev(ys), ys[1])

# get corresponding z-values
zs <- rbind(zs, -zs[nrow(zs):1, ], zs[1, ])

# as above, but for color gradient
gradient <-
  rbind(gradient, gradient[nrow(gradient):1, ], gradient[1, ])

# plot single surface
plot_ly(x = xs, y = ys, z = zs, surfacecolor = gradient,
        type = "surface", colorbar = list(title = 'x'))

令人惊讶的是，虽然这应该连接与 x 正交的两半/y平面创造完整的形状，
它仍然遭受与上述解决方案相同的“ Razor 齿”效应:


编辑 (3) :
原来丢失的部分是由 z 造成的。 -值为NaN接近 0 时:

# color points 'outside' the solid purple
gradient[is.nan(zs)] <- -1

# show those previously hidden points
zs[is.nan(zs)] <- 0

# plot exactly as before
plot_ly(x = xs, y = ys, z = zs, surfacecolor = gradient,
        type = "surface", colorbar = list(title = 'x'))

这可能是由于 r^2 时减法的数值不稳定造成的。和 y靠得太近，导致 sqrt 的负输入其中实际输入仍然是非负的。
这与数值问题无关，因为即使考虑到 +-4“接近”为零，也无法完全避免“ Razor 齿”效应:

# re-calculate z-values rounding to zero if 'close'
eps <- 4
zs <- with(coords, ifelse(abs(z2) < eps, 0, sqrt(z2))) %>%
      matrix(ncol = length(xs), byrow = TRUE) %>%
      rbind(-.[nrow(.):1, ], .[1, ])

# plot exactly as before
plot_ly(x = xs, y = ys, z = zs, surfacecolor = gradient,
        type = "surface", colorbar = list(title = 'x'))

Answer 1

这不会回答您的问题，但它会给出一个您可以在网页中与之交互的结果:不要使用 plot_ly , 使用 rgl .例如，

library(rgl)

# Your initial values...

r <- function(x) x^2
int <- c(1, 3)
nx <- 20
ntheta <- 36

# Set up x and colours for each x

x <- seq(int[1], int[2], length.out = nx)
cols <- colorRampPalette(c("blue", "yellow"), space = "Lab")(nx)

clear3d()
shade3d(turn3d(x, r(x), n = ntheta,  smooth = TRUE, 
        material = list(color = rep(cols, each = 4*ntheta))))
aspect3d(1,1,1)
decorate3d()
rglwidget()

您可以通过一些摆弄在颜色上做得更好:您可能想要创建一个使用 x 的函数或 r(x)设置颜色，而不是像我一样重复颜色。

结果如下: