Related
This is my code
library(shiny)
library(tidyverse)
mylist <- c(1,2,3) %>% as.list()
ui <- fluidPage(
plotOutput('chart_1'),
plotOutput('chart_2'),
plotOutput('chart_3')
)
server <- function(input, output, session) {
lapply(1:3, function(x){
output[[paste0("chart_", x)]] <-
renderPlot({ ggplot(gapminder::gapminder %>% filter(country == 'Chile'), aes(x = year, y = pop))+ geom_line()})
})
}
shinyApp(ui, server)
How can I achieve the same result using purrr::map function instead lapply?
I am doing something like this, but I have a error message:
mylist %>% map(~
output[[glue::glue("chart_{.x}")]] <-
renderPlot({ ggplot(gapminder::gapminder %>% filter(country == 'Chile'),
aes(x = year, y = pop))+ geom_line()})
)
I keep getting errors like Error in : object of type 'closure' is not subsettable or
'..1'. x Input '..1' must be of size 28 or 1, not size 0. I am trying to change the bar graph based on what options are selected or not in the checkbox.
I changed the column names for ease of use from where I got the data.
library(shiny)
library(dplyr)
library(plotly)
#dataset link: https://www.kaggle.com/mahirahmzh/starbucks-customer-retention-malaysia-survey?select=Starbucks+satisfactory+survey.csv
#c("Timestamp","Gender","age","currently","income","visit_freq","Enjoy","Time","Nearby","membership","freq_purchase","avg_spend","Ratevsother","rateprice","salesandpromotion","ambiance","wifi","service","meetup","heardaboutpromotions","continuepatronage")
data <-read.csv("Starbucks satisfactory survey.csv", header=TRUE)
Categorical.Variables <- c("visit_freq", "age", "income")
ui <- fluidPage(
sidebarPanel(
selectInput('category', choices = Categorical.Variables, label = 'Select filter options:'),
conditionalPanel(condition = "input.category != '-'",
uiOutput("select_category"))
)
)
server <- function(input, output) {
output$select_category <- renderUI({
choices <- as.list(unique(data[[input$category]]))
checkboxGroupInput('categorycheck', label = 'Select filter:',
choices = choices,selected = choices)
data2 <- reactive({
data %>%
group_by(gender,data[[input$category]], currently,membership) %>%
summarize(n = n(), .groups="drop") %>%
filter(data[[input$category]] %in% input$categorycheck) %>%
filter(membership == "Yes")})
renderPlotly({
data2 <- data2()
colnames(data2) <- c("gender","filtercategory","currently","membership","n")
plot_ly(data2, x = ~currently, y = ~n, type = "bar", color=~gender, colors="Dark2") %>%
layout(barmode = 'group')
})
})
}
shinyApp(ui, server)
You have several issues. You should close your renderUI prior to using input$categorycheck in the reactive object data2. In addition, columns names in the csv file are long. Once you define the column names of data the way you are analyzing, it will work. Try this
mydata <-read.csv("Starbucks satisfactory survey.csv", header=TRUE)
names(mydata)[1:10] <- c("Timestamp", "gender", "Age", "currently", "Income", "visit_freq","drink_freq","time_spent", "nearby","membership")
Categorical.Variables <- c("Age", "Income", "visit_freq")
ui <- fluidPage(
sidebarPanel(
selectInput('category', choices = Categorical.Variables, label = 'Select filter options:'),
#conditionalPanel(condition = "input.category != '-'",
uiOutput("select_category")
# )
),
mainPanel(plotlyOutput("myplot"),
DTOutput("t1")
)
)
server <- function(input, output) {
output$select_category <- renderUI({
req(input$category)
choices <- as.list(unique(mydata[[input$category]]))
checkboxGroupInput('categorycheck', label = 'Select filter:',
choices = choices,selected = choices)
})
data2 <- reactive({
req(input$category,input$categorycheck)
mydata %>%
group_by(gender,.data[[input$category]], currently,membership) %>%
dplyr::summarize(n = n(), .groups="drop") %>%
filter(.data[[input$category]] %in% input$categorycheck) %>%
filter(membership == "Yes")})
output$t1 <- renderDT(data2())
output$myplot <- renderPlotly({
req(data2())
data2 <- data2()
colnames(data2) <- c("gender","filtercategory","currently","membership","n")
plot_ly(data2, x = ~currently, y = ~n, type = "bar", color=~gender, colors="Dark2") %>%
layout(barmode = 'group')
})
}
shinyApp(ui, server)
In the example below, I am trying to produce a box and plot for each group within a dataset, using lapply within a renderUI function. However, some of these groups require an additional filter as they have sub-groupings.
This means creating a selectInput inside the box for those groups only and having the corresponding chart reference that selectInput only.
Here's the reproducible example... my problem is in the lapply loop creating a selectInput with the inputID of paste("selector_",i) and then immediately referencing this in the data to be output inside the corresponding box with input$(what goes here?)
library(shiny)
library(shinydashboard)
library(tidyverse)
library(nycflights13)
library(DT)
data <- planes %>%
select(manufacturer, type, model, year, seats) %>%
unique() %>%
filter(!is.na(year)) %>%
mutate(year = as.character(year))
ui <- dashboardPage(
dashboardHeader(title = "Testing"),
dashboardSidebar(),
dashboardBody(
fluidRow(
column(12, selectInput("type","Type", choices = unique(data$type)),
uiOutput("mytabs"))
)
)
)
server <- function(input, output) {
data_filtered <- reactive({
req(input$type)
data %>%
filter(type == input$type)
})
mfrs <- reactive({
data_filtered() %>%
select(manufacturer) %>%
unique() %>%
pull()
})
output$mytabs = renderUI({
fluidRow(
lapply(mfrs(), function(i) {
dt <- data_filtered() %>%
filter(manufacturer == i) %>%
arrange(year) %>%
select(model, year, seats)
models <- dt %>%
filter(!is.na(model)) %>%
select(model) %>%
unique() %>%
pull()
if(length(models) > 1) {
box(id = paste0('card', i), title = paste(i),
selectInput(inputId = paste0("selector_",i), "Question",
choices = models, selected = models[1]),
DT::datatable(dt[dt$qntext == input$the_one_above],
width = "100%", rownames = F,
options = list(
columnDefs = list(list(width = '40px', targets = "_all"))
))
)
} else {
box(id = paste0('card', i), title = paste(i),
DT::datatable(dt,
width = "100%", rownames = F,
options = list(
columnDefs = list(list(width = '40px', targets = "_all"))
))
)
}
})
)
})
}
shinyApp(ui, server)
As I am not sure what qns means, I have assigned qns to be models. Try this code:
data <- planes %>%
select(manufacturer, type, model, year, seats) %>%
unique() %>%
filter(!is.na(year)) %>%
mutate(year = as.character(year))
ui <- dashboardPage(
dashboardHeader(title = "Testing"),
dashboardSidebar(uiOutput("myqns")),
dashboardBody(
fluidRow(
column(12, selectInput("type","Type", choices = unique(data$type)), uiOutput("mytabs"))
)
)
)
server <- function(input, output) {
data_filtered <- reactive({
req(input$type)
data %>%
filter(type == input$type)
})
mfrs <- reactive({
req(data_filtered())
data_filtered() %>%
select(manufacturer) %>%
unique() %>%
pull()
})
output$myqns <- renderUI({
req(mfrs())
lapply(1:length(mfrs()), function(i) {
dt <- data_filtered() %>%
filter(manufacturer == mfrs()[i]) %>%
arrange(year) %>%
select(model, year, seats)
models <- dt %>%
filter(!is.na(model)) %>%
select(model) %>%
unique() %>%
pull()
qns <- models
selectInput(inputId = paste0("selector_",i), paste("Question",i), choices = as.list(qns), selected = 1)
})
})
output$mytabs = renderUI({
req(mfrs())
fluidRow(
lapply(1:length(mfrs()), function(i) {
req(input[[paste0("selector_",i)]])
dt <- data_filtered() %>%
filter(manufacturer == mfrs()[i]) %>%
arrange(year) %>%
select(model, year, seats)
models <- dt %>%
filter(!is.na(model)) %>%
select(model) %>%
unique() %>%
pull()
qns <- models
if(length(models) > 1) {
box(id = paste0('card', i), title = paste(mfrs()[i]),
# selectInput(inputId = paste0("selector_",i), "Question",
# choices = qns, selected = qns[1]),
DT::datatable(dt[dt$model == input[[paste0("selector_",i)]], ],
width = "100%", rownames = F,
options = list(
columnDefs = list(list(width = '40px', targets = "_all"))
))
)
} else {
box(id = paste0('card', i), title = paste(mfrs()[i]),
DT::datatable(dt,
width = "100%", rownames = F,
options = list(
columnDefs = list(list(width = '40px', targets = "_all"))
))
)
}
})
)
})
}
shinyApp(ui, server)
Answered by the awesome Paul Campbell... using modules.
library(shinydashboard)
library(tidyverse)
library(highcharter)
library(nycflights13)
# Modules ===============================================
# UI and server module for box with chart
box_chart_UI <- function(id, title) {
ns <- NS(id)
box(
title = title, height = 550,
highcharter::highchartOutput(ns("chart"))
)
}
box_chart <- function(input, output, session, df) {
output$chart <- renderHighchart({
validate(need(nrow(df) > 0, "No data"))
hchart(df, "column", hcaes(year, seats))
})
}
# UI and server module for box with chart and filter
box_chart_filter_UI <- function(id, title, filters, filter_lab = "Model") {
ns <- NS(id)
box(
title = title, height = 550,
selectInput(inputId = ns("selector"), label = filter_lab, choices = filters),
highchartOutput(ns("chart"))
)
}
box_chart_filter <- function(input, output, session, df) {
output$chart <- renderHighchart({
req(input$selector)
df_chart <- df %>% filter(model == input$selector)
validate(need(nrow(df_chart) > 0, "No data"))
hchart(df_chart, "column", hcaes(year, seats))
})
}
# Main App ===============================================
# load app data
data <- planes %>%
select(manufacturer, type, model, year, seats) %>%
unique() %>%
filter(!is.na(year)) %>%
mutate(year = as.character(year))
ui <- dashboardPage(
dashboardHeader(title = "Testing"),
dashboardSidebar(),
dashboardBody(
fluidRow(
column(
width = 12,
selectInput("type", "Type", choices = unique(data$type))
)
),
uiOutput("mytabs")
)
)
server <- function(input, output, session) {
data_filtered <- reactive({
req(input$type)
data %>% filter(type == input$type)
})
mfrs <- reactive({
data_filtered() %>%
distinct(manufacturer) %>%
pull()
})
# first load all the UI module functions
output$mytabs <- renderUI({
fluidRow(
lapply(1:length(mfrs()), function(i) {
models <- data_filtered() %>%
filter(manufacturer == mfrs()[i], !is.na(model)) %>%
distinct(model) %>%
pull() %>%
sort()
# depending on how many models, load the correct UI module
if (length(models) > 1) {
box_chart_filter_UI(id = i, title = mfrs()[i], filters = models)
} else {
box_chart_UI(id = i, title = mfrs()[i])
}
})
)
})
# now separately load the module server functions
# need to do this inside an observe due to reactive objects
observe({
lapply(1:length(mfrs()), function(i) {
dt <- data_filtered() %>%
filter(manufacturer == mfrs()[i]) %>%
arrange(year) %>%
select(model, year, seats)
models <- dt %>%
filter(!is.na(model)) %>%
distinct(model) %>%
pull() %>%
sort()
# depending on how many models, load the correct server module
if (length(models) > 1) {
callModule(box_chart_filter, id = i, df = dt)
} else {
callModule(box_chart, id = i, df = dt)
}
})
})
}
shinyApp(ui, server)
I have a application that has a reative table(based on 2 selectInputs) and a graph. The data for graph is taken from reactive table.
So both graph and table is using the same data. So while constructing a graph, can I observe what the table is having.
Or should I read the same table again in the graph?
I mean should we call head(iris,n = as.numeric(input$rows)) again twice below?
Example,
library(shiny)
library(DT)
library(rAmCharts)
ui <- fluidPage(
selectInput("rows","Rows",c(1:150)),
dataTableOutput("input_table"),
amChartsOutput("barplot",width = 750, height = 500)
)
server <- function(input, output, session) {
output$input_table <- renderDataTable({
new_iris <- head(iris,n = as.numeric(input$rows))
datatable(new_iris)
})
output$barplot <- renderAmCharts({
new_iris1 <- head(iris,n = as.numeric(input$rows)) ## should i call this again???????? Cannot we use from rendertable?
new_iris1 <- new_iris1 %>% group_by(Species) %>% summarise(total = sum(Petal.Length))
pipeR::pipeline(
amBarplot(
x = "Species",
y = "total",
ylab = "X",
xlab = "Y",
data = new_iris1,
labelRotation = 90
),
setChartCursor()
)
})
}
shinyApp(ui, server)
You may want to put your data object in a reactive expression so you can see what is being rendered, like so, this way you can access data() later on in your app
library(shiny)
library(DT)
library(dplyr)
library(rAmCharts)
ui <- fluidPage(
selectInput("rows","Rows",c(1:150)),
dataTableOutput("input_table"),
amChartsOutput("barplot",width = 750, height = 500)
)
server <- function(input, output, session) {
data <- eventReactive(input$rows,{
head(iris,n = as.numeric(input$rows))
})
output$input_table <- renderDataTable({
datatable(data())
})
output$barplot <- renderAmCharts({
new_iris1 <- data()
new_iris1 <- new_iris1 %>% group_by(Species) %>% summarise(total = sum(Petal.Length))
pipeR::pipeline(
amBarplot(
x = "Species",
y = "total",
ylab = "X",
xlab = "Y",
data = new_iris1,
labelRotation = 90
),
setChartCursor()
)
})
}
shinyApp(ui, server)
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)