function(input, output, session) {
histColor <- reactive({
input$color1
input$color2
sample(colors(), 1)
})
output$distPlot <- renderPlot({
Sys.sleep(2)
x <- faithful[, 2] # Old Faithful Geyser data
bins <- seq(min(x), max(x), length.out = input$bins + 1)
# draw the histogram with the specified number of bins
hist(x, breaks = bins, col = histColor(), border = 'white',
main = input$title)
})
output$slider_info1 <- renderPrint({
cat('The value of the slider input is', input$bins)
})
output$slider_info2 <- renderPrint({
cat('The value of the slider input is', input$bins)
})
output$error_info <- renderPrint({
stop('A bad error occurred!')
})
observe({
updateTextInput(session, 'title', value = paste(input$bins, 'bins'))
})
observeEvent(input$message, {
session$sendCustomMessage('special', list(a = rnorm(10), b = letters))
})
observeEvent(input$busy, {
message('Shiny will be busy for 2 seconds')
Sys.sleep(2)
})
observeEvent(input$swallow_event_button, {
session$sendCustomMessage('swallow_fail', list(msg = "Fail"))
})
observeEvent(input$end, session$close())
}
library(shiny)
library(knitr)
md <- '
# JavaScript event tests
This app exercises Shiny\'s [JavaScript events API](https://shiny.rstudio.com/articles/js-events.html).
1. A dialog box that says "Shiny is busy!" should appear at least twice in succession immediately after page load.
1. The side panel should fade during or after the "Shiny is busy!" dialog box has subsided.
1. The slider input labeled **Number of bins** should have a red dotted border.
1. Modifying the "Title" text input should cause the plot title to update.
1. Pressing the button labeled "Change color" should cause the bars in the plot to change color.
1. Pressing the button labeled "Change color (canceled)" should have no effect.
1. Pressing the button labeled "Send message" should cause the busy dialog to appear very briefly.
1. Pressing the button labeled "Be busy for 2 seconds" should cause the busy dialog to appear for roughly 2 seconds.
1. Pressing the "Swallow event" button should **not** cause an alert box that says "Fail" to appear.
1. The JavaScript console should display the following kinds of messages (input/output names elided):
- `An output ... was bound to Shiny`
- `An input ... was bound to Shiny`
- `Received a message from Shiny`
- `An output is being recalculated...`
1. `My output was modified by the shiny:value event.` should appear under the **slider_info2** heading.
1. `Error: A nice error occurred :)` should appear under the **Error Info** heading.
1. `Warning: Error in renderPrint: A bad error occurred!` should appear in the R console at least twice.
1. Pressing the button labeled "End session" should cause an alert to say "Disconnected!"
'
fluidPage(
title = 'JavaScript events in shiny',
tags$head(singleton(tags$script(src = 'events.js'))),
sidebarLayout(
sidebarPanel(
textInput('title', 'Title', 'Histogram Title'),
sliderInput('bins', 'Number of bins:', min = 1, max = 50, value = 30),
actionButton('color1', 'Change color'),
actionButton('color2', 'Change color (canceled)'),
actionButton('message', 'Send message'),
actionButton('busy', 'Be busy for 2 seconds'),
tags$span(
id = "swallow_wrapper",
actionButton('swallow_event_button', 'Swallow event')
),
actionButton('end', 'End session')
),
mainPanel(
HTML(knit2html(fragment.only = TRUE, text = md)),
plotOutput('distPlot'),
verbatimTextOutput('slider_info1'),
tags$h3("slider_info2"),
verbatimTextOutput('slider_info2'),
tags$h3("Error Info"),
textOutput('error_info')
)
),
div(
id = 'busyModal', class = 'modal', role = 'dialog', 'data-backdrop' = 'static',
div(
class = 'modal-dialog modal-sm',
div(
class = 'modal-content',
div(class = 'modal-header', h4(class = 'modal-title', 'Shiny is busy!')),
div(class = 'modal-body', p(paste(
'This dialog box will disappear',
'automatically after shiny is idle.'
)))
)
)
)
)
$(function() {
$("#swallow_wrapper").on('shiny:inputchanged', function(event) {
event.preventDefault();
});
$(document).on({
'shiny:connected': function(event) {
$('form.well').fadeOut(3000).fadeIn(2000);
},
'shiny:disconnected': function(event) {
alert('Disconnected! The web socket state is ' + event.socket.readyState);
},
'shiny:busy': function(event) {
$('#busyModal').modal('show');
},
'shiny:idle': function(event) {
$('#busyModal').modal('hide');
},
'shiny:inputchanged': function(event) {
switch (event.name) {
// modify the title value during the event
case 'title':
event.value += ' (title modified by the JS event based on input$title)';
break;
// cancel the event so this button does not update the color
case 'color2':
event.preventDefault();
break;
default:
}
},
'shiny:message': function(event) {
console.log('Received a message from Shiny');
var msg = event.message;
if (msg.hasOwnProperty('custom') && msg.custom.hasOwnProperty('special')) {
console.log('This is a special message from Shiny:');
console.log(msg.custom.special);
} else if (msg.hasOwnProperty('custom') && msg.custom.hasOwnProperty('swallow_fail')) {
alert(msg.custom.swallow_fail.msg);
}
},
'shiny:bound': function(event) {
console.log('An ' + event.bindingType + ' (' + event.binding.name + ') was bound to Shiny');
},
'shiny:updateinput': function(event) {
console.log({
'Input message': event.message,
'To be applied to': event.target
});
},
'shiny:value': function(event) {
if (event.name === 'slider_info2') {
event.value = 'My output was modified by the shiny:value event.';
}
},
'shiny:error': function(event) {
if (event.name === 'error_info') {
event.error.message = 'A nice error occurred :)';
}
},
'shiny:recalculating': function(event) {
console.log('An output is being recalculated... ' + new Date());
},
'shiny:recalculated': function(event) {
console.log('An output has been recalculated! ' + new Date());
}
});
// when the slider input is bound, add a red border to it
$('#bins').on('shiny:bound', function(event) {
$(this).parent().css('border', 'dotted 2px red');
});
Shiny.addCustomMessageHandler('special', function(message) {
//
});
});