I'm targeting a specific plotly trace with my R shiny inputs but I'd like to do so without referring to the data behind all the other traces. As seen below, updating the cylinder trace depends on an else condition. I'd like to avoid that, as in my real data, I have many other traces, rather than the one here (the sphere trace).
library(shiny)
library(plotly)
library(purrr)
plot_cylinder <- function(x, y, z, radius, height, color = 'red') {
theta <- seq(0, 2*pi, length.out = 30)
z_cyl <- seq(z, z + height, length.out = 2)
x_cyl <- outer(x + radius * cos(theta), rep(1, length(z_cyl)))
y_cyl <- outer(y + radius * sin(theta), rep(1, length(z_cyl)))
z_cyl <- outer(rep(1, length(theta)), z_cyl)
list(
type = "surface",
x = x_cyl,
y = y_cyl,
z = z_cyl,
colorscale = list(c(0, color), c(1, color))
)
}
plot_sphere <- function(x, y, z, r, color = 'blue') {
theta <- seq(0, 2*pi, length.out = 30)
phi <- seq(0, pi, length.out = 30)
x_sphere <- x + r * outer(cos(theta), sin(phi))
y_sphere <- y + r * outer(sin(theta), sin(phi))
z_sphere <- z + r * outer(rep(1, length(theta)), cos(phi))
list(x = x_sphere, y = y_sphere, z = z_sphere, color = color)
}
# Static sphere data
sphere_radius <- 7.24
sphere_data <- plot_sphere(0, 0, 10, sphere_radius)
cylinder_data <- plot_cylinder(0, 0, 0, 3, 10)
ui <- fluidPage(
titlePanel("Cylinder Plotting"),
sidebarLayout(
sidebarPanel(
sliderInput("radius", "Cylinder Radius:", min = 1, max = 10, value = 3),
sliderInput("height", "Cylinder Height:", min = 1, max = 20, value = 10),
actionButton("initialize", "Initialize Cylinder")
),
mainPanel(
plotlyOutput("plot")
)
)
)
server <- function(input, output, session) {
plot <- plot_ly() |>
add_surface(x = sphere_data$x, y = sphere_data$y,
z = sphere_data$z, colors = sphere_data$color,
opacity = 0.5, name = "sphere") |>
add_surface(x = cylinder_data$x, y = cylinder_data$y,
z = cylinder_data$z, colorscale = cylinder_data$colorscale,
opacity = 0, name = "cylinder")
pb <- plotly_build(plot)
traces <- map(pb$x$data, "name")
output$plot <- renderPlotly({
plot
})
observeEvent(input$initialize, {
proxy <- plotlyProxy("plot", session)
plotlyProxyInvoke(proxy, "restyle", list(
opacity = lapply(traces, function(name) if(name %in% "cylinder") 0.1 else 0.5)
))
})
observeEvent(c(input$radius, input$height), {
proxy <- plotlyProxy("plot", session)
# Get the updated cylinder trace
cylinder_data <- plot_cylinder(0, 0, 0, input$radius, input$height)
# Update the trace with the new x, y, z values
plotlyProxyInvoke(proxy, "restyle", list(
x = lapply(traces, function(name) if(name %in% "cylinder") cylinder_data$x else sphere_data$x),
y = lapply(traces, function(name) if(name %in% "cylinder") cylinder_data$y else sphere_data$y),
z = lapply(traces, function(name) if(name %in% "cylinder") cylinder_data$z else sphere_data$z)
))
})
}
shinyApp(ui = ui, server = server)
Plotly's restyle function has a traceIndices parameter:
An efficient means of changing attributes in the data array in an existing plot. When restyling, you may choose to have the specified changes affect as many traces as desired. The update is given as a single object and the traces that are affected are given as a list of traces indices. Note, leaving the trace indices unspecified assumes that you want to restyle all the traces.
Here is how to update only the data of the first trace (index: 0) via plotlyProxyInvoke:
library(shiny)
library(plotly)
library(purrr)
plot_cylinder <- function(x, y, z, radius, height, color = 'red') {
theta <- seq(0, 2*pi, length.out = 30)
z_cyl <- seq(z, z + height, length.out = 2)
x_cyl <- outer(x + radius * cos(theta), rep(1, length(z_cyl)))
y_cyl <- outer(y + radius * sin(theta), rep(1, length(z_cyl)))
z_cyl <- outer(rep(1, length(theta)), z_cyl)
list(
type = "surface",
x = x_cyl,
y = y_cyl,
z = z_cyl,
colorscale = list(c(0, color), c(1, color))
)
}
plot_sphere <- function(x, y, z, r, color = 'blue') {
theta <- seq(0, 2*pi, length.out = 30)
phi <- seq(0, pi, length.out = 30)
x_sphere <- x + r * outer(cos(theta), sin(phi))
y_sphere <- y + r * outer(sin(theta), sin(phi))
z_sphere <- z + r * outer(rep(1, length(theta)), cos(phi))
list(x = x_sphere, y = y_sphere, z = z_sphere, color = color)
}
# Static sphere data
sphere_radius <- 7.24
sphere_data <- plot_sphere(0, 0, 10, sphere_radius)
cylinder_data <- plot_cylinder(0, 0, 0, 3, 10)
ui <- fluidPage(
titlePanel("Cylinder Plotting"),
sidebarLayout(
sidebarPanel(
sliderInput("radius", "Cylinder Radius:", min = 1, max = 10, value = 3),
sliderInput("height", "Cylinder Height:", min = 1, max = 20, value = 10)
),
mainPanel(
plotlyOutput("plot")
)
)
)
server <- function(input, output, session) {
plotly_object <- plot_ly(colors = sphere_data$color) |>
add_surface(x = cylinder_data$x, y = cylinder_data$y,
z = cylinder_data$z, colorscale = cylinder_data$colorscale,
opacity = 0.5, name = "cylinder") |>
add_surface(x = sphere_data$x, y = sphere_data$y,
z = sphere_data$z,
opacity = 0.5, name = "sphere")
pb <- plotly_build(plotly_object)
traces <- unlist(map(pb$x$data, "name"))
trace_indices <- setNames(seq_along(traces) - 1L, traces)
output$plot <- renderPlotly({
plotly_object
})
observeEvent(c(input$radius, input$height), {
proxy <- plotlyProxy("plot", session)
# Get the updated cylinder trace
cylinder_data <- plot_cylinder(0, 0, 0, input$radius, input$height)
# Update the trace with the new x, y, z values
plotlyProxyInvoke(proxy, "restyle", list(
x = list(cylinder_data$x),
y = list(cylinder_data$y),
z = list(cylinder_data$z)
), trace_indices[["cylinder"]])
# if you need to modify multiple traces at once (and leave others as they are):
# plotlyProxyInvoke(proxy, "restyle", list(
# x = list(cylinder_data$x, sphere_data$x + 100L),
# y = list(cylinder_data$y, sphere_data$y + 100L),
# z = list(cylinder_data$z, sphere_data$z + 100L)
# ), list(0L, 1L))
})
}
shinyApp(ui = ui, server = server)