R+gráficamente: sólido de revolución

shiny using html (4)

Esto no responde a su pregunta, pero le dará un resultado con el que puede interactuar en una página web: no use plot_ly , use rgl . Por ejemplo,

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

Podrías mejorar los colores con un poco de juego: probablemente quieras crear una función que use x o r(x) para establecer el color en lugar de simplemente repetir los colores como lo hice.

Aquí está el resultado:

Tengo una función r(x) que quiero girar alrededor del eje x para obtener un sólido de revolución que deseo agregar a un trazado plot_ly existente mediante add_surface (coloreado por x ).

Aquí hay un ejemplo:

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

¿Cómo puedo generar la forma indicada por los puntos anteriores como una superficie de `plotly` (idealmente abierta en ambos extremos)?

editar (1) :

Aquí está mi mejor intento hasta ahora:

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

Si bien esto le da la forma deseada,

Tiene ''dientes de afeitar'' cerca del plano x / y .
~~Las partes de las mitades no se tocan.~~ ( resuelto mediante la inclusión de 0 y pi en los vectores theta )
~~No me di cuenta de cómo colorearlo con x lugar de z (aunque hasta ahora no he investigado mucho).~~ ( resuelto por matriz de gradient )

editar (2) :

Aquí hay un intento de usar una sola superficie:

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

Sorprendentemente, si bien esto debería conectar las dos mitades ortogonales al plano x / y dos para crear la forma completa, todavía sufre el mismo efecto de "dientes de afeitar" que la solución anterior:

editar (3) :

Resulta que las partes faltantes resultan de que los valores de z son NaN cuando están cerca de 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''))

~~Esto podría deberse a la inestabilidad numérica de la sustracción cuando r^2 y y se acercan demasiado, resultando en una entrada negativa para sqrt donde la entrada real aún no es negativa.~~

Estas costuras no están relacionadas con problemas numéricos, ya que incluso cuando se considera + -4 ''cerca'' de cero, el efecto ''dientes de afeitar'' no se puede evitar por completo:

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

He tenido otra grieta en eso y tengo una solución más cercana, utilizando el tipo "superficie". Lo que ayudó fue ver los resultados de su primer gráfico de superficie con nx = 5 y ntheta = 18. La razón por la que es jaggardy se debe a la forma en que vincula las columnas en zs (a través de los puntos x). Es necesario vincular parcialmente el anillo más grande a su alrededor, y esto hace que la densidad aumente para cumplir con este punto.

No puedo deshacerme de este jaggardy comportamiento al 100%. He hecho estos cambios:

agregue algunos puntos pequeños a theta alrededor de los bordes: donde se unen las dos densidades. Esto reduce el tamaño de la parte de jaggardy ya que hay algunos puntos más cerca del límite
cálculo de mod zs a zs2: asegúrese de que cada anillo tenga una dimensión igual al exterior del anillo, agregando los 0 en.
aumentado nx a 40 y reducido ntheta a 18 - más x hace que el paso sea más pequeño. reduce ntheta para el tiempo de ejecución, ya que he agregado más puntos

Los pasos vienen en cómo trata de unir los anillos x. En teoría, si tiene más anillos X, debería eliminar esta irregularidad, pero eso requiere mucho tiempo para ejecutarse.

No creo que esto responda a la Q 100%, y no estoy seguro de si esta biblioteca es la mejor para este trabajo. Póngase en contacto si hay alguna Q''s.

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 <- 40 # number of points along the rotation ntheta <- 18 # set x points and get corresponding radii coords <- data_frame(x = seq(int[1], int[2], length.out = nx), r = r(x)) # theta: add small increments at the extremities for the density plot theta <- seq(0, pi, length.out = ntheta / 2 + 1) theta <- c(theta, pi + theta) theta <- theta[theta != 2*pi] inc <- 0.00001 theta <- c(theta, inc, pi + inc, pi - inc, 2*pi - inc) theta <- sort(theta) coords %<>% rowwise() %>% do(data_frame(x = .$x, r = .$r, theta = theta)) %>% ungroup %>% mutate(y = r * cos(theta), z = r * sin(theta)) # 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) zs2 <- zs L <- ncol(zs) for(i in (L-1):1){ w <- which(!is.na(zs[, (i+1)]) & is.na(zs[, i])) zs2[w, i] <- 0 } # 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 = zs2, surfacecolor = gradient, type = "surface", colorbar = list(title = ''x'')) # plot lower have of shape as second surface p %>% add_surface(z = -zs2, showscale = FALSE)

Una pregunta interesante es que he luchado para usar la densidad de la superficie para mejorar su solución. Hay un truco que podría hacer con capas múltiples líneas, que resulta agradable para esto, por ejemplo, solo los cambios realizados en el original, por ejemplo, es usar muchos más puntos x: nx a 1000, y cambiar add_markers a add_lines. Puede que no sea escalable, pero funciona bien para este tamaño de datos :)

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 <- 1000 # 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_lines()

Mejor, jonny

Una solución sería voltear sus ejes para que gire alrededor del eje z en lugar del eje x. No sé si esto es factible, dado el gráfico existente al que está agregando esta figura, pero resuelve fácilmente el problema de los "dientes".

xs <- seq(-9,9,length.out = 20) ys <- seq(-9,9,length.out = 20) coords <- expand.grid(x = xs, y = ys) %>% mutate(z2 = (x^2 + y^2)^(1/4)) zs <- matrix(coords$z2, ncol = length(xs), byrow = TRUE) plot_ly(x = xs, y = ys, z = zs, surfacecolor = zs, type = "surface", colorbar = list(title = ''x'')) %>% layout(scene = list(zaxis = list(range = c(1,3))))

R+gráficamente: sólido de revolución

shiny using html (4)

¿Cómo puedo generar la forma indicada por los puntos anteriores como una superficie de plotly (idealmente abierta en ambos extremos)?

¿Cómo puedo generar la forma indicada por los puntos anteriores como una superficie de `plotly` (idealmente abierta en ambos extremos)?