Related
I am attempting to use the plotlyProxy() functionality (Documented here) to allow users of a shiny application to add and remove traces with minimal latency.
Adding traces proves to be relatively simple, but I'm having difficulty figuring out how to remove traces by name (I'm only seeing documented examples that remove by trace number).
Is there a way to remove traces by name using plotlyProxy()?
If not, is there a way that I can parse through the output object to derive what trace numbers are associated with a given name?
I can determine the associated trace number of a given name in an interactive R session using the standard schema indices, but when I attempt to apply the same logic in a shiny application I get an error: "Error in $.shinyoutput: Reading objects from shinyoutput object not allowed."
A minimal example is below. Neither observer watching the Remove button actually works, but they should give an idea for the functionality I'm trying to achieve.
library(shiny)
library(plotly)
ui <- fluidPage(
textInput("TraceName", "Trace Name"),
actionButton("Add","Add Trace"),
actionButton("Remove","Remove Trace"),
plotlyOutput("MyPlot")
)
server <- function(input,output,session) {
## Creaing the plot
output$MyPlot <- renderPlotly({
plot_ly() %>%
layout(showlegend = TRUE)
})
## Adding traces is smooth sailing
observeEvent(input$Add,{
plotlyProxy("MyPlot", session) %>%
plotlyProxyInvoke("addTraces", list(x = rnorm(10),y = rnorm(10),
type = "scatter",mode = "markers",
name = input$TraceName))
})
## Ideal Solution (that does not work)
observeEvent(input$Remove,{
plotlyProxy("MyPlot", session) %>%
plotlyProxyInvoke("deleteTraces", input$TraceName)
})
## Trying to extract tracenames throws an error:
## Warning: Error in $.shinyoutput: Reading objects from shinyoutput object not allowed.
observeEvent(input$Remove,{
TraceNames <- unlist(lapply(seq_along(names(output$MyPlot$x$attrs)),
function(x) output$MyPlot$x$attrs[[x]][["name"]]))
ThisTrace <- which(TraceNames == input$TraceName)
plotlyProxy("MyPlot", session) %>%
plotlyProxyInvoke("deleteTraces", ThisTrace)
})
}
shinyApp(ui, server)
Edit using plotlyProxy:
Update #SeGa, thanks for adding support to delete traces with duplicated names!
Finally, I found a solution to realize the expected behaviour by adapting this answer. I'm receiving the trace.name / trace.index mapping by using onRender from library(htmlwidgets) after the remove-button is clicked:
library(shiny)
library(plotly)
library(htmlwidgets)
js <- "function(el, x, inputName){
var id = el.getAttribute('id');
var d3 = Plotly.d3;
$(document).on('shiny:inputchanged', function(event) {
if (event.name === 'Remove') {
var out = [];
d3.select('#' + id + ' g.legend').selectAll('.traces').each(function(){
var trace = d3.select(this)[0][0].__data__[0].trace;
out.push([name=trace.name, index=trace.index]);
});
Shiny.setInputValue(inputName, out);
}
});
}"
ui <- fluidPage(
textInput("TraceName", "Trace Name"),
verbatimTextOutput("PrintTraceMapping"),
actionButton("Add", "Add Trace"),
actionButton("Remove", "Remove Trace"),
plotlyOutput("MyPlot")
)
server <- function(input, output, session) {
output$MyPlot <- renderPlotly({
plot_ly(type = "scatter", mode = "markers") %>%
layout(showlegend = TRUE) %>% onRender(js, data = "TraceMapping")
})
output$PrintTraceMapping <- renderPrint({unlist(input$TraceMapping)})
observeEvent(input$Add, {
req(input$TraceName)
plotlyProxy("MyPlot", session) %>%
plotlyProxyInvoke("addTraces", list(x = rnorm(10),y = rnorm(10),
type = "scatter",mode = "markers",
name = input$TraceName))
})
observeEvent(input$Remove, {
req(input$TraceName, input$TraceMapping)
traces <- matrix(input$TraceMapping, ncol = 2, byrow = TRUE)
indices <- as.integer(traces[traces[, 1] == input$TraceName, 2])
plotlyProxy("MyPlot", session) %>%
plotlyProxyInvoke("deleteTraces", indices)
})
}
shinyApp(ui, server)
Result:
Useful articles in this context:
shiny js-events
plotly addTraces
plotly deleteTraces
Solution for Shiny Modules using plotlyProxy:
library(shiny)
library(plotly)
library(htmlwidgets)
js <- "function(el, x, data){
var id = el.getAttribute('id');
var d3 = Plotly.d3;
$(document).on('shiny:inputchanged', function(event) {
if (event.name.indexOf('Remove') > -1) {
var out = [];
d3.select('#' + id + ' g.legend').selectAll('.traces').each(function(){
var trace = d3.select(this)[0][0].__data__[0].trace;
out.push([name=trace.name, index=trace.index]);
});
Shiny.setInputValue(data.ns + data.x, out);
}
});
}"
plotly_ui_mod <- function(id) {
ns <- NS(id)
tagList(
textInput(ns("TraceName"), "Trace Name"),
verbatimTextOutput(ns("PrintTraceMapping")),
actionButton(ns("Add"), "Add Trace"),
actionButton(ns("Remove"), "Remove Trace"),
plotlyOutput(ns("MyPlot"))
)
}
plotly_server_mod <- function(input, output, session) {
sessionval <- session$ns("")
output$MyPlot <- renderPlotly({
plot_ly(type = "scatter", mode = "markers") %>%
layout(showlegend = TRUE) %>% onRender(js, data = list(x = "TraceMapping",
ns = sessionval))
})
output$PrintTraceMapping <- renderPrint({unlist(input$TraceMapping)})
observeEvent(input$Add, {
req(input$TraceName)
plotlyProxy("MyPlot", session) %>%
plotlyProxyInvoke("addTraces", list(x = rnorm(10),y = rnorm(10),
type = "scatter",mode = "markers",
name = input$TraceName))
})
observeEvent(input$Remove, {
req(input$TraceName, input$TraceMapping)
traces <- matrix(input$TraceMapping, ncol = 2, byrow = TRUE)
indices <- as.integer(traces[traces[, 1] == input$TraceName, 2])
plotlyProxy("MyPlot", session) %>%
plotlyProxyInvoke("deleteTraces", indices)
})
}
ui <- fluidPage(
plotly_ui_mod("plotly_mod")
)
server <- function(input, output, session) {
callModule(plotly_server_mod, "plotly_mod")
}
shinyApp(ui, server)
Previous Solution avoiding plotlyProxy:
I came here via this question.
You were explicitly asking for plotlyProxy() so I'm not sure if this is helpful to you, but here is a workaround to realize the expected behaviour via updating the data provided to plot_ly() instead of using plotlyProxy():
library(shiny)
library(plotly)
ui <- fluidPage(
selectizeInput(inputId="myTraces", label="Trace names", choices = NULL, multiple = TRUE, options = list('plugins' = list('remove_button'), 'create' = TRUE, 'persist' = TRUE, placeholder = "...add or remove traces")),
plotlyOutput("MyPlot")
)
server <- function(input, output, session){
myData <- reactiveVal()
observeEvent(input$myTraces, {
tmpList <- list()
for(myTrace in input$myTraces){
tmpList[[myTrace]] <- data.frame(name = myTrace, x = rnorm(10),y = rnorm(10))
}
myData(do.call("rbind", tmpList))
return(NULL)
}, ignoreNULL = FALSE)
output$MyPlot <- renderPlotly({
if(is.null(myData())){
plot_ly(type = "scatter", mode = "markers")
} else {
plot_ly(myData(), x = ~x, y = ~y, color = ~name, type = "scatter", mode = "markers") %>%
layout(showlegend = TRUE)
}
})
}
shinyApp(ui, server)
I couldn't find the names attributes of the traces, and I think the deleteTrace function is not able to delete by name. Based on the reference it just deletes based on index.
I tried to implement something for Shiny, which records the added traces in a dataframe and adds an index to them. For deletion, it matches the given names with the dataframe and gives those indeces to the delete method of plotlyProxyInvoke, but it is not working correctly. Maybe someone could add some insight into why this is happening?
One problem seems to be the legend, which is showing wrong labels after deletion and I dont think that plotly and R/shiny are keeping the same indices of the traces, which leads to strange behaviour. So this code definitly needs some fixing.
--
I included a small JQuery snippet, which records all the traces of the plot and sends them to a reactiveVal(). Interestingly, it differs from the data.frame, that listens to the AddTraces event. There will always be one remaining trace in the plot.
library(shiny)
library(plotly)
library(shinyjs)
ui <- fluidPage(
useShinyjs(),
tags$head(tags$script(HTML(
"$(document).on('shiny:value', function(event) {
var a = $('.scatterlayer.mlayer').children();
if (a.length > 0) {
var text = [];
for (var i = 0; i < a.length; i++){
text += a[i].className.baseVal + '<br>';
}
Shiny.onInputChange('plotlystr', text);
}
});"
))),
textInput("TraceName", "Trace Name"),
actionButton("Add","Add Trace"),
actionButton("Remove","Remove Trace by Name"),
plotlyOutput("MyPlot"),
splitLayout(
verbatimTextOutput("printplotly"),
verbatimTextOutput("printreactive")
)
)
server <- function(input,output,session) {
## Reactive Plot
plt <- reactive({
plot_ly() %>%
layout(showlegend = T)
})
## Reactive Value for Added Traces
addedTrcs <- reactiveValues(tr = NULL, id = NULL, df = NULL)
## Creaing the plot
output$MyPlot <- renderPlotly({
plt()
})
## Adding traces is smooth sailing
observeEvent(input$Add,{
req(input$TraceName)
plotlyProxy("MyPlot", session) %>%
plotlyProxyInvoke("addTraces", list(x = rnorm(10),y = rnorm(10),
type = "scatter",mode = "markers", colors ="blue",
name = input$TraceName))
})
## Adding trace to reactive
observeEvent(input$Add, {
req(input$TraceName)
x <- input$TraceName
addedTrcs$id <- c(addedTrcs$id, length(addedTrcs$id))
addedTrcs$tr <- c(addedTrcs$tr, x)
addedTrcs$df <- data.frame(id=addedTrcs$id, tr=addedTrcs$tr, stringsAsFactors = F)
})
## Remove Trace from Proxy by NAME
observeEvent(input$Remove,{
req(input$TraceName %in% addedTrcs$tr)
ind = which(addedTrcs$df$tr == input$TraceName)
ind = addedTrcs$df[ind,"id"]
plotlyProxy("MyPlot", session) %>%
plotlyProxyInvoke("deleteTraces", as.integer(ind))
})
## Remove Trace from Reactive
observeEvent(input$Remove, {
req(input$TraceName %in% addedTrcs$df$tr)
whichInd <- which(addedTrcs$tr == input$TraceName)
addedTrcs$df <- addedTrcs$df[-whichInd,]
addedTrcs$id <- addedTrcs$id[-whichInd]
addedTrcs$tr <- addedTrcs$tr[-whichInd]
req(nrow(addedTrcs$df)!=0)
addedTrcs$df$id <- 0:(nrow(addedTrcs$df)-1)
})
tracesReact <- reactiveVal()
observe({
req(input$plotlystr)
traces <- data.frame(traces=strsplit(input$plotlystr, split = "<br>")[[1]])
tracesReact(traces)
})
output$printplotly <- renderPrint({
req(tracesReact())
tracesReact()
})
## Print Reactive Value (added traces)
output$printreactive <- renderPrint({
req(addedTrcs$df)
addedTrcs$df
})
}
shinyApp(ui, server)
It appears the Plotly.D3 method has been depreciated and no longer works in the above code. I was able to replicate a simple solution with the below code.
library(shiny)
library(plotly)
library(htmlwidgets)
js <- "function(el){
$(document).on('shiny:inputchanged', function(event) {
if (event.name === 'Remove') {
var traceName = document.getElementById('TraceName').value
var plotlyData = document.getElementById('MyPlot').data
plotlyData.forEach(function (item, index) {
if (item.name === traceName){
Plotly.deleteTraces('MyPlot', index);
}
});
}
});
}"
ui <- fluidPage(
textInput("TraceName", "Trace Name"),
actionButton("Remove", "Remove Trace"),
plotlyOutput("MyPlot")
)
server <- function(input, output, session) {
output$MyPlot <- renderPlotly({
print("renderPlotlyRan")
plot_ly(type = "scatter", mode = "markers") %>%
add_markers(x = rnorm(10),y = rnorm(10), name = "Trace1") %>%
add_markers(x = rnorm(10),y = rnorm(10), name = "Trace2") %>%
add_markers(x = rnorm(10),y = rnorm(10), name = "Trace3") %>%
add_markers(x = rnorm(10),y = rnorm(10), name = "Trace4") %>%
layout(showlegend = TRUE) %>%
htmlwidgets::onRender(x = ., jsCode = js)
})
}
shinyApp(ui, server)
I have a shiny app in which more than one reactive component uses the same result from a function that is slow to calculate. To avoid calculating the slow function more than once, I can use reactiveValues() to recalculate the function when its inputs change, and make the result available to all reactive components that require it.
But, if the reactiveValues object is a data.table, and I update it using :=, shiny does not detect the change, and the outputs that rely on it do not get updated.
Is there any way to use data.table assign by reference either with reactiveValues or another way that avoids recalculating the function multiple times.
Here is a reproducible example using data.table assign-by-reference in which output$result2 fails to get updated when the input changes:
library(shiny)
library(data.table)
library(plotly)
ui = fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput('x1', 'x1', min=0, max=2, value=1, step=0.1)
),
mainPanel(
plotlyOutput('result1'),
verbatimTextOutput('result2')
)
)
)
server = function(input, output) {
values <- reactiveValues()
values$dt = data.table(v1 = 1:100, v2 = 1)
slow.func = function(my.dt, x) {
Sys.sleep(2)
my.dt[, v2 := v1^x]
}
output$result1 = renderPlotly({
values$dt = slow.func(values$dt, input$x1)
plot_ly(values$dt) %>%
add_lines(x = ~v1, y = ~v2)
})
output$result2 = renderText({
paste('Final value =', values$dt[.N, v2])
})
}
shinyApp(ui = ui, server = server)
For comparison, here is a version of the server function using standard assignment of data.frames, which does perform as expected:
server = function(input, output) {
values <- reactiveValues()
values$dt = data.frame(v1 = 1:100, v2 = 1)
slow.func = function(my.dt, x) {
my.dt$v2 = my.dt$v1^x
Sys.sleep(2)
my.dt
}
output$result1 = renderPlotly({
values$dt = slow.func(values$dt, input$x1)
plot_ly(values$dt) %>%
add_lines(x = ~v1, y = ~v2)
})
output$result2 = renderText({
paste('Final value =', values$dt[100,]$v2)
})
}
say you have defined a reactive variable table_updated so you can increment it by one each time the slow function is done. Other values/plots will only need to observe table_updated.
Actually the actionButton(see description section) does the same thing, every time it gets clicked, its value is incremented by 1.
values <- reactiveValues(table_updated = 0)
slow.func = function(my.dt, x) {
# do stuff
values$table_updated <- values$table_updated + 1
}
output$result2 = renderText({
values$table_updated
paste('Final value =', values$dt[100,]$v2)
})
For my shiny application I use a module with a variant number of inputs. In my main application I want now to create an interactive plot. I added a click event (click = "onClick") handler to the plotOutput. When I click on a point, input$onClick gets updated, but becomes NULL right afterwards.
You can try it out in the application: if you click on a point in the left graph, the values of input$onClick are printed, but become NULL right afterwards.
This has to have something to do with the module, becasue if you click on a point in the right graph the information is persistent.
So it seems that there is some sort of communication between client and server which invalidates input$onclick when using modules. Anything I could do about it?
Code
library(shiny)
library(plyr)
library(ggplot2)
testUI <- function(id) {
ns <- NS(id)
uiOutput(ns("placeholder"))
}
test <- function(input, output, session, n) {
output$placeholder <- renderUI({
do.call(tagList, llply(1:n(), function(i)
numericInput(session$ns(paste("n", i, sep = ".")),
session$ns(paste("n", i, sep = ".")), sample(0:100, 1), 0, 100)))
})
getData <- reactive(unlist(reactiveValuesToList(input)[1:n()]))
list(getData = getData)
}
ui <- fluidPage(
flowLayout(
numericInput("n", "Number of Elements", 3, 1, 10),
testUI("x"),
testUI("y")),
flowLayout(
plotOutput("plot", click = "onClick"),
plotOutput("plot2", click = "onClick2")),
verbatimTextOutput("debug")
)
server <- function(input, output, session) {
getN <- reactive(input$n)
handler <- list(x = callModule(test, "x", getN),
y = callModule(test, "y", getN))
output$plot <- renderPlot({
req(handler$x$getData(), handler$y$getData())
dat <- data.frame(x = handler$x$getData(),
y = handler$y$getData())
qplot(x, y, data = dat)})
output$plot2 <- renderPlot(qplot(mpg, cyl, data = mtcars))
output$debug <- renderPrint(list(input$onClick, input$onClick2))
}
runApp(shinyApp(ui, server))
I rewrote the server, in a trial to track the issue. First, I will highlight what I suspect to be the issue, Then I will write an alternative solution.
First: Possible Issues
I think output$plot is rendered twice, if you put print("here") inside output$plot <- renderPlot({}) , you'll see that with each click, it gets executed twice.
Probably, it gets invalidated twice. I suspect that the issue might be related to using getData <- reactive(unlist(reactiveValuesToList(input)[1:n()])). Because when I replaced it with an alternative reactive expression getData <- reactive(1:n()) , it worked properly.
I think, when one clicks on the plot:
input changes (because it includes input$onClick)
getData <- reactive(unlist(reactiveValuesToList(input)[1:n()])) gets invalidated
the plot object for output$plot gets invalidated because it depends on the previous values.
input reads the current value of onClick which is NULL
library(shiny)
library(plyr)
library(ggplot2)
testUI <- function(id) {
ns <- NS(id)
uiOutput(ns("placeholder"))
}
test <- function(input, output, session, n) {
output$placeholder <- renderUI({
do.call(tagList,
llply(1:n(), function(i)
numericInput(session$ns(paste("n", i, sep = ".")),
session$ns(paste("n", i, sep = ".")), sample(0:100, 1), 0, 100)))
})
getData <- reactive(unlist(reactiveValuesToList(input)[1:n()]))
## TEST: this will work ----------
# getData <- reactive(1:n())
list(getData = getData)
}
ui <- fluidPage(
flowLayout(
numericInput("n", "Number of Elements", 3, 1, 10),
testUI("x"),
testUI("y")),
flowLayout(
plotOutput("plot", click = "onClick"),
plotOutput("plot2", click = "onClick2")),
verbatimTextOutput("debug")
)
server <- function(input, output, session) {
# handler <- list(x = callModule(test, "x", getN),
# y = callModule(test, "y", getN))
#
# output$plot <- renderPlot({
# req(handler$x$getData(), handler$y$getData())
# dat <- data.frame(x = handler$x$getData(),
# y = handler$y$getData())
# qplot(x, y, data = dat)})
getN <- reactive(input$n)
## call modules -------------------
xx <- callModule(test, "x", getN)
yy <- callModule(test, "y", getN)
## data to be plotted in left plot
dat <- reactive({
data.frame(x = xx$getData(),
y = yy$getData())
})
## left plot ------------------
output$plot <- renderPlot({
req(xx$getData(),yy$getData())
print("here")
qplot(x, y, data = dat())
})
## right plot ------------------
output$plot2 <- renderPlot({
qplot(mpg, cyl, data = mtcars)
})
output$debug <- renderPrint(c(input$onClick$x,input$onClick2$y))
# output$debug <- renderPrint(dat())
}
shinyApp(ui = ui, server = server)
Second: Alternative Solution
In this alternative solutions:
test will return nothing
get the coordinates of the numericInput fields in x_coord() & y_coord() (There might be other ways to achieve this).
form the dataframe dat().
req() condition was roughly chosen, but could be anything to achieve the desired result.
library(shiny)
library(plyr)
library(ggplot2)
testUI <- function(id) {
ns <- NS(id)
uiOutput(ns("placeholder"))
}
test <- function(input, output, session, n) {
output$placeholder <- renderUI({
do.call(tagList,
llply(1:n(), function(i)
numericInput(session$ns(paste("n", i, sep = ".")),
session$ns(paste("n", i, sep = ".")), sample(0:100, 1), 0, 100)))
})
}
ui <- fluidPage(
flowLayout(
numericInput("n", "Number of Elements", 3, 1, 10),
testUI("x"),
testUI("y")),
verbatimTextOutput("debug"),
flowLayout(
plotOutput("plot", click = "onClick"),
plotOutput("plot2", click = "onClick2"))
)
server <- function(input, output, session) {
getN <- reactive(input$n)
## call modules -------------------
callModule(test, "x", getN)
callModule(test, "y", getN)
## get coordinates fromnumeric inputs ----------
x_coord <- reactive(sapply((1:input$n),function(x) input[[paste0("x-n.",x)]]))
y_coord <- reactive(sapply((1:input$n),function(x) input[[paste0("y-n.",x)]]))
## create data frame
dat <- reactive({
req(input[[paste0("y-n.",input$n)]]) # could be changed
data.frame(x = x_coord(),
y = y_coord())
})
## render left plot ------------------
output$plot <- renderPlot({
req(input[[paste0("y-n.",input$n)]]) # could be changed
qplot(x, y, data = dat())
})
## render right plot ------------------
output$plot2 <- renderPlot({
qplot(mpg, cyl, data = mtcars)
})
## cat coordinates of clicked points ---------------
output$debug <- renderPrint(c(input$onClick$x,input$onClick$y))
}
shinyApp(ui = ui, server = server)
I want to plot a plotly 3D graph inside my Shiny App, but only the data with values that are in the range of input range slider. However I want to prevent plotting when there are no values in the range of the sliders - currently this causes the following error when there are no inputs:
Warning: Error in UseMethod: no applicable method for 'plotly_build' applied
to an object of class "NULL"
or in the example code:
Error in : length(Lab) == 3L is not TRUE
This is an example code which has a similar error as original problem:
library(shiny)
library(plotly)
d = diamonds[1:100,]
ui = fluidPage(
headerPanel("Data"),
sliderInput(inputId="slider", label = "Choose a range", value =c(0,max(d$price)),
min = 0,max = max(d$price)),
# saves space for the plot in the user interface. Id allows communication
plotlyOutput(outputId="trendPlot", width="100%", height=800)
)
server = function(input, output)
{
NROF = reactiveValues(test = 1)
output$trendPlot= renderPlotly({
d_sub=d[d$price >= input$slider[1] & d$price <= input$slider[2],]
NROF = nrow(d)
if(NROF != 0)
{
plot_ly(d_sub, x=d_sub$cut, y=d_sub$color, z=factor(d_sub$color),
type='scatter3d', mode='markers',
sizemode='diameter', size=d_sub$price, color=d_sub$price,colors = 'Set1')
}
})
}
shinyApp(ui=ui, server=server)
SOLUTION: I've made a mistake using reactive values - it should have been NROF$TEST
Sounds like req() or validate() are what you're looking for:
http://shiny.rstudio.com/articles/req.html
http://shiny.rstudio.com/articles/validation.html
library(shiny)
library(plotly)
d <- diamonds[1:100,]
ui <- fluidPage(
headerPanel("Data"),
sliderInput(inputId="slider",
label = "Choose a range",
value =c(0,max(d$price)),
min = 0,max = max(d$price)),
# saves space for the plot in the user interface. Id allows communication
plotlyOutput(outputId="trendPlot",
width="100%", height=800)
)
server <- function(input, output) {
output$trendPlot <- renderPlotly({
d_sub <- d[d$price >= input$slider[1] & d$price <= input$slider[2],]
req(nrow(d_sub) > 0)
# validate(need(nrow(d_sub) > 0, "No data selected!"))
plot_ly(d_sub, x=d_sub$cut, y=d_sub$color,
z=factor(d_sub$color), type='scatter3d',
mode='markers', sizemode='diameter',
size=d_sub$price, color=d_sub$price,
colors = 'Set1')
})
}
shinyApp(ui=ui, server=server)
I tried to reproduce it. My suggestion is that there was a small typo (you meant NROF = nrow(d_sub) instead of NROF = nrow(d)). Plus, you did not include any return value for the else case.
Does this help you?
server = function(input, output)
{
NROF = reactiveValues(test = 1)
output$trendPlot= renderPlotly({
d_sub=d[d$price >= input$slider[1] & d$price <= input$slider[2],]
NROF = nrow(d_sub)
if(NROF != 0)
{
plot_ly(d_sub, x=d_sub$cut, y=d_sub$color, z=factor(d_sub$color),
type='scatter3d', mode='markers',
sizemode='diameter', size=d_sub$price, color=d_sub$price,colors = 'Set1')
} else {
plot_ly(type='scatter3d')
}
})
}
Following the example at: https://plot.ly/r/shinyapp-linked-click/ I was able to in a blank shiny project get this working (correlation matrix linked to a scatter graph). However, when I do the same in a shiny module the event_data based click action doesnt seem to work (the scatter remains blank no mater what happens, seems like the click is not connecting).
My reproducible example is below, any ideas or solutions would be much appreciated.
library(plotly)
#### Define Modules ####
correlation_matrix_shinyUI <- function(id) {
ns <- NS(id)
mainPanel(
plotlyOutput(ns("corr_matrix"), height = '650px'),
plotlyOutput(ns("scatterplot"), height = '550px')
)
}
correlation_matrix_shiny <- function(input, output, session) {
data_df <- reactive({
mtcars
})
corr_data <- reactive({
if (is.null(data_df()))
return()
corr_data <- cor(data_df())
diag(corr_data) <- NA
corr_data <- round(corr_data, 4)
corr_data
})
corr_names <- reactive({
if (is.null(data_df()))
return()
corr_names <- colnames(data_df())
corr_names
})
output$corr_matrix <- renderPlotly({
if (is.null(corr_names()))
return()
if (is.null(corr_data()))
return()
g <- plot_ly(x = corr_names(), y = corr_names(), z = corr_data(),
key = corr_data(), type = "heatmap", source = "CORR_MATRIX", zmax = 1, zmin = -1)
g
})
output$scatterplot <- renderPlotly({
if (is.null(data_df()))
return()
data_use <- data_df()
s <- event_data("plotly_click", source = "CORR_MATRIX")
if (length(s)) {
vars <- c(s[["x"]], s[["y"]])
d <- setNames(data_use[vars], c("x", "y"))
yhat <- fitted(lm(y ~ x, data = d))
plot_ly(d, x = x, y = y, mode = "markers") %>%
plotly::add_trace(x = x, y = yhat, mode = "lines") %>%
plotly::layout(xaxis = list(title = s[["x"]]),
yaxis = list(title = s[["y"]]),
showlegend = FALSE)
} else {
plot_ly()
}
})
}
############ End Module Definition ######
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
),
correlation_matrix_shinyUI(id = "cor_module")
)
)
server <- function(input, output, session) {
callModule(correlation_matrix_shiny, id = "cor_module")
}
shinyApp(ui = ui, server = server)
Your question really is interesting. I will answer with some text passages from the shiny modules page.
Foremost, your problem is a scoping issue. In more detail:
[...] input, output, and session cannot be used to access inputs/outputs that are outside of the namespace, nor can they directly access reactive expressions and reactive values from elsewhere in the application [...]
In your module, you are trying to access the plotly-owned and therefore server-level variable event_data that is used to store click (or other) events. The plots react normal, as you could see if you'd add
observe({print(event_data("plotly_click", source = "CORR_MATRIX"))})
inside your server function (and outside of the module). But this kind of input was not defined directly within the correlation_matrix_shinyUI namespace and so it remains inaccessible.
These restrictions are by design, and they are important. The goal is not to prevent modules from interacting with their containing apps, but rather, to make these interactions explicit.
This is well meant, but in your case, you weren't really given the chance to assign a name to this variable, since plotly handles everything under its cover. Luckily, there is a way:
If a module needs to access an input that isn’t part of the module, the containing app should pass the input value wrapped in a reactive expression (i.e. reactive(...)):
callModule(myModule, "myModule1", reactive(input$checkbox1))
This of course goes a bit contrary to the whole modularization...
So, the way this can be fixed is to fetch the click event outside of the module and then send it as extra input to the callModule function. This part in the code may look a bit redundant, but I found this to be the only way it worked.
Well, the rest can be best explained by the code itself. Changes have only been made to the server function and inside the correlation_matrix_shiny, where the variable s is defined.
I hope this helps!
Best regards
Code:
library(plotly)
#### Define Modules ####
correlation_matrix_shinyUI <- function(id) {
ns <- NS(id)
mainPanel(
plotlyOutput(ns("corr_matrix"), height = '650px'),
plotlyOutput(ns("scatterplot"), height = '550px')
)
}
correlation_matrix_shiny <- function(input, output, session, plotlyEvent) {
data_df <- reactive({
mtcars
})
corr_data <- reactive({
if (is.null(data_df()))
return()
corr_data <- cor(data_df())
diag(corr_data) <- NA
corr_data <- round(corr_data, 4)
corr_data
})
corr_names <- reactive({
if (is.null(data_df()))
return()
corr_names <- colnames(data_df())
corr_names
})
output$corr_matrix <- renderPlotly({
if (is.null(corr_names()))
return()
if (is.null(corr_data()))
return()
g <- plot_ly(x = corr_names(), y = corr_names(), z = corr_data(),
key = corr_data(), type = "heatmap", source = "CORR_MATRIX", zmax = 1, zmin = -1)
g
})
output$scatterplot <- renderPlotly({
if (is.null(data_df()))
return()
data_use <- data_df()
s <- plotlyEvent()
if (length(s)) {
vars <- c(s[["x"]], s[["y"]])
d <- setNames(data_use[vars], c("x", "y"))
yhat <- fitted(lm(y ~ x, data = d))
plot_ly(d, x = x, y = y, mode = "markers") %>%
plotly::add_trace(x = x, y = yhat, mode = "lines") %>%
plotly::layout(xaxis = list(title = s[["x"]]),
yaxis = list(title = s[["y"]]),
showlegend = FALSE)
} else {
plot_ly()
}
})
}
############ End Module Definition ######
ui <- shinyUI(fluidPage(
sidebarLayout(
sidebarPanel(
),
correlation_matrix_shinyUI(id = "cor_module")
)
))
server <- function(input, output, session) {
plotlyEvent <- reactive(event_data("plotly_click", source = "CORR_MATRIX"))
callModule(correlation_matrix_shiny, id = "cor_module", reactive(plotlyEvent()))
}
shinyApp(ui = ui, server = server)