How to prevent JS code to run multiple times in R Shiny? - r

I try to use a workaround for the highcharter package to update the chart and not to rerender it which looks much smoother. So far, my functions works fine as long as I run the code in a seperate JS file. But to make it more flexible I want to write with function with R. When I click the input$data button, the code seems to run as many times as the value input$data has got (see the print statement). Why is this happening and what can I do to prevent this issue?
library(highcharter)
library(shiny)
library(shinyjs)
df <- data.frame(
a = floor(runif(10, min = 1, max = 10)),
b = floor(runif(10, min = 1, max = 10))
)
updaterfunction <- function() {
jscode <-
'$("#data").on("click",function() {
console.log("code was run")
Shiny.addCustomMessageHandler("handler1", function(message1){
var chart1 = $("#plot").highcharts()
var newArray1 = new Array(message1.length)
var newArray2 = new Array(message1.length)
for(var i in message1) {
newArray1[i] = message1[i].a
newArray2[i] = message1[i].b
}
chart1.series[0].update({
// type: "line",
data: newArray1
}, false)
chart1.series[1].update({
// type: "line",
data: newArray2
}, false)
chart1.redraw();
})
});'
runjs(jscode)
}
# Define UI for application that draws a histogram
ui <- fluidPage(
# Application title
titlePanel("Old Faithful Geyser Data"),
#includeScript("www/script.js"),
useShinyjs(),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
sliderInput("bins",
"Number of bins:",
min = 1,
max = 50,
value = 30),
actionButton("data2", "Generate Data"),
actionButton("data", "Generate Data")
),
# Show a plot of the generated distribution
mainPanel(
highchartOutput("plot"),
highchartOutput("plot2")
)
)
)
server <- function(input, output, session) {
observeEvent(input$data, {
print(input$data)
df <- data.frame(
a = floor(runif(10, min = 1, max = 10)),
b = floor(runif(10, min = 1, max = 10))
)
message1 = jsonlite::toJSON(df)
session$sendCustomMessage("handler1", message1)
updaterfunction()
})
reactivedata <- eventReactive(input$data2, {
df <- data.frame(
a = floor(runif(10, min = 1, max = 10)),
b = floor(runif(10, min = 1, max = 10))
)
})
output$plot <- renderHighchart({
highchart() %>%
hc_add_series(type = "bar", data = df$a) %>%
hc_add_series(type = "bar", data = df$b)
})
output$plot2 <- renderHighchart({
highchart() %>%
hc_add_series(type = "bar", data = reactivedata()$a) %>%
hc_add_series(type = "bar", data = reactivedata()$b)
})
}
# Run the application
shinyApp(ui = ui, server = server)

That's because each time you run the JS code, it attaches a new click event to the button. You can use off("click") to remove the previous event handler:
jscode <-
'$("#data").off("click").on("click",function() {
But I'm not sure this produces the expected behaviour. Is it ?

Related

how to update a dataset in R shiny

Can I get help on how to get the below code to work? I am looking to update the numbers in
dataExample <- getDataset(n1 = c(20),n2 = c(20), means1 = c(18), means2 = c(9),stds1 = c(14), stds2 = c(14))
based on input values and then generate the plot whenever I apply changes but not sure how to do it. I read it somewhere it says need to use reactive or observe but I am not sure how to modify the code?
library(shiny)
library(plyr)
library(rmarkdown)
library(rpact)
design <- getDesignGroupSequential(kMax = 2, alpha = 0.05, informationRates = c(0.5, 1), typeOfDesign = "WT", deltaWT = 0.5)
ui <- fluidPage(
titlePanel("Efficacy Monitoring Using Conditional Power"),
sidebarLayout(
sidebarPanel(
numericInput('nn1', 'Number of Subjects at Current stage (Active)', 20, min = 1, max = 100),
numericInput('nn2', 'Number of Subjects at Current stage (Control)', 20, min = 1, max = 100),
textInput('Mean1', 'Mean1',"18"),
textInput('Mean2', 'Mean2',"9"),
textInput('SD1', 'SD1',"14"),
textInput('SD2', 'SD2',"14"),
textInput('nPlanned', 'Additional Numbers Planned',"40"),
submitButton(text = 'Apply Changes')
),
# Main panel for displaying outputs ----
mainPanel(plotOutput("plot2")
)
)
)
server <- function(input,output){
dataExample <- getDataset(
n1 = c(20),
n2 = c(20),
means1 = c(18),
means2 = c(9),
stds1 = c(14),
stds2 = c(14)
)
stageResults <- getStageResults(design, dataExample,thetaH0 = 0)
output$plot2<-renderPlot(
plot(stageResults, nPlanned = c(as.numeric(input$nPlanned)), thetaRange = c(0, 20))
)
}
# Run the app ----
shinyApp(ui, server)
Use a reactive function and put the input values
library(shiny)
library(plyr)
library(rmarkdown)
library(rpact)
design <- getDesignGroupSequential(kMax = 2, alpha = 0.05, informationRates = c(0.5, 1), typeOfDesign = "WT", deltaWT = 0.5)
ui <- fluidPage(
titlePanel("Efficacy Monitoring Using Conditional Power"),
sidebarLayout(
sidebarPanel(
numericInput('nn1', 'Number of Subjects at Current stage (Active)', 20, min = 1, max = 100),
numericInput('nn2', 'Number of Subjects at Current stage (Control)', 20, min = 1, max = 100),
# WHY THE CHOICE OF textInput instead of numericInput ?
textInput('Mean1', 'Mean1',"18"),
textInput('Mean2', 'Mean2',"9"),
textInput('SD1', 'SD1',"14"),
textInput('SD2', 'SD2',"14"),
textInput('nPlanned', 'Additional Numbers Planned',"40"),
submitButton(text = 'Apply Changes')
),
# Main panel for displaying outputs ----
mainPanel(plotOutput("plot2")
)
)
)
server <- function(input,output){
# Use the input values in a reactive function
dataExample <- reactive({
getDataset(
n1 = input$nn1,
n2 = input$nn2,
means1 = as.numeric(input$Mean1),
means2 = as.numeric(input$Mean2),
stds1 = as.numeric(input$SD1),
stds2 = as.numeric(input$SD2)
)
})
output$plot2<-renderPlot({
stageResults <- getStageResults(design, dataExample(), thetaH0 = 0)
plot(stageResults, nPlanned = c(as.numeric(input$nPlanned)), thetaRange = c(0, 20))
})
}
# Run the app ----
shinyApp(ui, server)

edit a reactive database

Trying to edit a reactive database so that updates to the database are reflected in the output.
Have tried numerous variants, but none are working, general idea is shown - where I would like to have the figure update with changes to the database.
library(tidyverse)
library(shiny)
library(DT)
# Define UI for application that draws a histogram
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput("ages", "Max age:", 10, 100, 15),
sliderInput("nsamp",
"Sample size:",
min = 10,
max = 1000,
value = 100)),
mainPanel(dt_output('Sample sizes and weighting', 'x1'),
plotOutput("fig"))
)
)
server <- function(input, output) {
x = reactive({
df = data.frame(age = 1:input$ages,
samples = input$nsamp,
weighting = 1)
})
output$x1 = renderDT(x(),
selection = 'none',
editable = TRUE,
server = TRUE,
rownames = FALSE)
output$fig = renderPlot({
ggplot(x(), aes(age, samples)) +
geom_line() +
geom_point()
})
}
shinyApp(ui = ui, server = server)
We can use input$x1_cell_edit and reactiveValues to modify the data that is passed to the plot.
Note the use of isolate inside renderDT, that is to prevent the table from re-rendering when db$database is modified.
library(tidyverse)
library(shiny)
library(DT)
# Define UI for application that draws a histogram
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput("ages", "Max age:", 10, 100, 15),
sliderInput("nsamp",
"Sample size:",
min = 10,
max = 1000,
value = 100
)
),
mainPanel(
dataTableOutput("x1"),
plotOutput("fig")
)
)
)
server <- function(input, output) {
# all the data will be stored in this two objects
db <- reactiveValues(database = NULL)
# to store the modified values
edited_vals <- reactiveVal(tibble(row = numeric(), col = numeric(), value = numeric()))
# create a new table each time the sliders are changed
observeEvent(c(input$ages, input$nsamp), {
df <- data.frame(
age = 1:input$ages,
samples = input$nsamp,
weighting = 1
)
db$database <- df
})
observeEvent(input$x1_cell_edit, {
db$database[as.numeric(input$x1_cell_edit$row), as.numeric(input$x1_cell_edit$col + 1)] <- as.numeric(input$x1_cell_edit$value)
})
output$x1 <- renderDT(
{
input$ages
input$nsamp
datatable(
isolate(db$database),
selection = "none",
editable = TRUE,
rownames = FALSE,
options = list(stateSave = TRUE)
)
},
server = TRUE
)
output$fig <- renderPlot({
ggplot(db$database, aes(as.numeric(age), as.numeric(samples))) +
geom_point() +
geom_line()
})
}
shinyApp(ui = ui, server = server)

R Shiny animation scatterplot speed performance

I want to make an animation in R Shiny where my scatter plot is progressively updated at each iteration, here is my current plot
library(shiny)
library(plotly)
ui <- fluidPage(
titlePanel(""),
sidebarLayout(
sidebarPanel(
actionButton("launch", "Launch Simulation"),
radioButtons("display","Show every iteration", selected = 10,
choices = c(1,5,10,50),inline = FALSE),
numericInput("iter","Maximum number of iterations", value = 2000,
min = 500,max = 5000, step = 500)
),
mainPanel(
plotlyOutput('plot')
)
)
)
server <- function(input, output) {
rv <- reactiveValues(i = 0,
df = data.frame(x = -1,y = -1))
observeEvent(input$launch,{
rv$i = 0
rv$df = data.frame(x = runif(5000, min = -1,max = 1),
y = runif(5000, min = -1,max = 1))
})
observe({
isolate({
rv$i = rv$i + as.numeric(input$display)
})
if ((rv$i < input$iter)&input$launch){
invalidateLater(0)
}
})
output$plot <- renderPlotly({
df = data.frame(x = 0,y = -1)
df = rbind(df,rv$df)
plot_ly(df[1:(rv$i + 1),], x = ~x, y = ~y,
type = 'scatter', mode = 'markers',
marker = list(size = 4), hoverinfo="none") %>%
layout(showlegend = FALSE)
})
}
shinyApp(ui = ui, server = server)
The code is working fine at the beginning but after around 1000 iterations, the animation becomes very slow. I think the main problem is that because in my code, I have to re-make the plot all over again at each iteration, is there a smoother way to do what I want to do?
(Not necessarily with Plotly but it is important to me that I keep track of the number of the iterations outside of the plot (here rv$i))

How to dynamically load shiny outputs as soon as their dependencies are available?

I have a shiny application with one input object which is a dependency for 2 output objects.
First output object takes the input values directly and second output object needs further calculation on input object value.
I want to load first output object as soon as I change input object and load second output object after further calculation is over.
The problem is both the objects are loaded simultaneously even though the dependencies for first output object are available earlier than those of second.
Here is my reproducible code. I want to display plot1 as soon as I change slider1 and keep the spinner on for plot2 until it is available.
library("ggplot2")
library("shiny")
library("shinycssloaders")
ui <- fluidPage(
sliderInput("slider1", label = "Slider 1", min = 0, max = 100, step = 1, value = c(0,100)),
withSpinner(plotOutput("plot1")),
withSpinner(plotOutput("plot2"))
)
server <- function(input, output, session) {
output$plot1 <- renderPlot({
ggplot() + geom_point(aes(
x = runif(n = 100, min = 0, max = 100),
y = runif(
n = 100,
min = input$slider1[1],
max = input$slider1[2]
)
))
})
plot2_min <- reactive({
Sys.sleep(time = 2)
input$slider1[1]
})
plot2_max <- reactive({
Sys.sleep(time = 2)
input$slider1[2]
})
output$plot2 <- renderPlot({
ggplot() + geom_point(aes(
x = runif(n = 100, min = 0, max = 100),
y = runif(
n = 100,
min = plot2_min(),
max = plot2_max()
)
))
})
}
shinyApp(ui, server)
As per my comment All reactive expressions are processed together and will wait for all dependencies before rendering even if you slow the second one down. You can however delay the second reactive using the debounce functionality, for more info refer here: https://shiny.rstudio.com/reference/shiny/1.0.2/debounce.html
Example below does will show you how one might use it, I put 2 sec wait on it:
library(ggplot2)
library(shiny)
library(shinycssloaders)
library(magrittr)
ui <- fluidPage(
sliderInput("slider1", label = "Slider 1", min = 0, max = 100, step = 1, value = c(0,100)),
withSpinner(plotOutput("plot1")),
withSpinner(plotOutput("plot2"))
)
server <- function(input, output, session) {
data1 <- reactive({
data.frame(x = runif(n = 100, min = 0, max = 100),
y = runif(n = 100,min = input$slider1[1],max = input$slider1[2]))
})
output$plot1 <- renderPlot({
ggplot() + geom_point(aes(data1()$x,data1()$y))
})
plot2_min <- eventReactive(data1(),{
input$slider1[1]
})
plot2_max <- eventReactive(data1(),{
input$slider1[2]
})
data2 <- reactive({
data.frame(x = runif(n = 100, min = 0, max = 100),
y = runif(n = 100,min = plot2_min(),max = plot2_max()))
}) %>% debounce(2000)
output$plot2 <- renderPlot({
ggplot() + geom_point(aes(data2()$x,data2()$y))
})
}
shinyApp(ui, server)

Change google maps heatmap options in shiny

I am using googleway library in Shiny R.
The heatmap displays correctly, but I cannot change the heatmap options. If I uncomment the block code where I try to change options, the app crashes.
Here is the part of the code that works, with the offending lines commented out.
library(googleway)
library(magrittr)
library(shiny)
library(shinydashboard)
# Define UI for app
header1 <- dashboardHeader(
title = "My Dashboard"
)
sidebar1 <- dashboardSidebar(
sidebarMenu(
fileInput("file0", "Choose CSV File",
multiple = TRUE,
accept = c("text/csv",
"text/comma-separated-values,text/plain",".csv")),
sliderInput("opacity", "Opacity:",
min = 0, max = 1,
value = 0.5, step = 0.05),
sliderInput("radius", "Radius:",
min = 0, max = 50,
value = 25),
sliderInput("blur", "Blur:",
min = 0, max = 1,
value = 0.75, step = 0.05),
sliderInput("maxvalue", "MaxValue:",
min = 0, max = 1,
value = 1, step = 0.05)
) #sidebarMenu
) #dashboardSidebar
body1 <- dashboardBody(
fluidRow(
tabBox(
title = "TabBox Title 1",
id = "tabset1", height = "400px", width = 11,
selected = "Tab1",
tabPanel("Tab1",
google_mapOutput("Map1")
),
tabPanel("Tab2", "Tab content 2")
) #box
) #fluidRow
) #dashboardBody
ui <- dashboardPage(header1, sidebar1, body1)
# Define data
df <- data.frame(lat = c(14.61),
lon = c(-90.54),
weight = c(100))
# Define SERVER logic
server <- function(input, output, session) {
map_key <- "my_key"
## https://developers.google.com/maps/documentation/javascript/get-api-key
## plot the map
output$Map1 <- renderGoogle_map({
google_map(key = map_key, data = df, zoom = 2, search_box = F) %>%
add_heatmap(weight = "weight") #%>%
#add_traffic()
}) #renderGoogle_map
observeEvent(input$opacity, {
# THIS PART IS COMMENTED OUT BECAUSE THE APP CRASHES
# google_map_update(map_id = "Map1") %>%
# update_heatmap(data = df, option_opacity = input$opacity)
}) #observeEvent
} #server
# Run app
shinyApp(ui, server)
Your help with this will be greatly appreciated! :)
You can use a reactive({}) to carry the input$opacity value and pass it directly to add_heatmap() to achieve the opacity responsiveness.
This can still be done inside the google_map_update(), but you'd have to clear the heatmap layer first, otherwise you'd just be adding layers on top of each other.
server <- function(input, output, session) {
map_key <- "your_key"
## https://developers.google.com/maps/documentation/javascript/get-api-key
opacity <- reactive({
return(input$opacity)
})
## plot the map
output$Map1 <- renderGoogle_map({
google_map(key = map_key, data = df, zoom = 2, search_box = F) %>%
add_heatmap(weight = "weight") #%>%
#add_traffic()
}) #renderGoogle_map
observeEvent(input$opacity, {
google_map_update(map_id = "Map1") %>%
clear_heatmap() %>%
add_heatmap(data = df, option_opacity = opacity())
})
}
} #server

Resources