Develop Reference

How to use JS to count the number of clicks of a selectInput function?

In running the below code, each click of the actionButton() is correctly counted and output to the UI (using reactive value y). I'm trying to do the same with selectInput() (counting each time a selection is made)(using reactive value x), but it doesn't completely correctly count because when first invoking the App, selecting the default choice of "Cyl" is not included in the count (I'd like it to), and clicking the same choice more than once isn't included in the count (I'd like all clicks counted). One workaround is to include "multiple = TRUE" in the selectInput(), but I'd like to see if there's a JS solution instead so I don't have to change the UI the way including "multiple = TRUE" does.
As an aside, using "multiple = TRUE" also corrects the weird subtraction of 1 from (x) in output$clickSelInput...; hopefully a JS solution does the same.
Code:
library(shiny)
ui = fluidPage(hr(),
selectInput("selInput",label=NULL,c("Cyl"="cyl","Trans"="am","Gears"="gear"),selected=NULL),
actionButton("addBtn","Add"), hr(),
textOutput("clickSelInput"),
textOutput("clickAddBtn"),
tableOutput("data")
)
server = function(input, output) {
x = reactiveVal(0)
y = reactiveVal(0)
output$data <- renderTable({mtcars[1:10, c("mpg", input$selInput), drop = FALSE]})
observeEvent(input$selInput,{x(x()+1)})
observeEvent(input$addBtn,{y(y()+1)})
output$clickSelInput <- renderText({paste('Select Input clicks =',x()-1)})
output$clickAddBtn <- renderText({paste('Add Button clicks =',y())})
}
shinyApp(ui, server)

Here is a working solution, taking SamR's suggestion into account and using that example by analogy. I had to make other changes to make it work. I commented changes below from OP.
library(shiny)
library(shinyjs) # added
ui = fluidPage(hr(),
useShinyjs(), # added, this line is easy to forget to add
uiOutput("selInput"), # added, pulls renderUI output from server into UI
actionButton("addBtn","Add"), hr(),
textOutput("clickSelInput"),
textOutput("clickAddBtn"),
tableOutput("data")
)
server = function(input, output) {
x = reactiveVal(0)
y = reactiveVal(0)
output$data <- renderTable({mtcars[1:10, c("mpg", input$selInput), drop = FALSE]})
observeEvent(input$addBtn,{y(y()+1)})
# moved select input into renderUI so it can interact with JS in the observe further down:
output$selInput <- renderUI(
selectInput("selInput",label=NULL,c("Cyl"="cyl","Trans"="am","Gears"="gear"),selected=NULL)
)
output$clickSelInput <- renderText({paste('Select Input clicks =',input$rnd)}) # changed
output$clickAddBtn <- renderText({paste('Add Button clicks =',y())})
# added js:
observe({
if(is.null(input$rnd)){
runjs("
var click = 0;
Shiny.onInputChange('rnd', click)
var selInput = document.getElementById('selInput')
selInput.onclick = function() {click += 1; Shiny.onInputChange('rnd', click)};
")
}
})
}
shinyApp(ui, server)

shiny doesn't work after, containing javascript

I have a problem with this application, containing a javascript file for the user-interface part, which enables more tabs. However, the server part doesn't work when we have included the javascript file. I have a simple reactivity regarding the mtcars dataset here to showcase the problem. when I disable the "includeScript("script.js")", by merely put the # in front of it, the app works, so the problem is connected to this part. So my question would be, How can I fix this issue and also keep the javascript part in the shiny app.
Grateful for all your help.
Edit:
Now I have replaced includeScript("script.js") with tags$head(tags$script(src="./script.js")), and it appears to work, but with an extremely slow reactivity, I have to wait almost 1-2 min before seeing something. Any suggestion, or do you also experience this ?
library(shiny)
library(shinythemes)
library(shinymanager)
library(dplyr)
script.js
$(document).ready(function(){
$('.dropdown').on('click', function(e){
$(this).toggleClass('open');
e.stopPropagation();
e.preventDefault();
});
$('[data-toggle=tab]').on('click', function(e){
let dv = ($(this).attr('data-value'));
//Set active element in tabcontents
$('.tab-pane').removeClass('active');
$('.tab-pane[data-value="' + dv + '"]').addClass('active');
//Set active element in navbar
$('a[data-toggle=tab]').parent().removeClass('active');
$('a[data-value="' + dv + '"]').parent().addClass("active");
//Close the dropdowns
$('.dropdown').removeClass('open');
e.stopPropagation();
e.preventDefault();
});
});
Credentials
credentials <- data.frame(
user = c("Jhon", "Erik"), # mandatory
password = c("1", "1"), # mandatory
start = c("2022-02-14"), # optinal (all others)
expire = c(NA, "2022-12-31"),
admin = c(TRUE, TRUE),
comment = "Model Performance application",
stringsAsFactors = FALSE
)
Ui
ui <- fluidPage(
includeScript("script.js"),
navbarPage("Shiny",
collapsible = TRUE,
theme = shinytheme('yeti'),
tabPanel("Information" ,icon = icon("info"),
tags$h2("Information about the current user"),
verbatimTextOutput("auth_output")
),
tabPanel("Simulation 1",
tags$h2("Simulation"),
tags$hr(),
selectInput("vars", "Variables", names(mtcars), multiple = T),
tableOutput("data")
),
tabPanel("Upload",icon = icon("upload"),
tags$h2("Upload datasets"),
tags$hr(),
),
tabPanel("Simulation 2",
tags$h2("Simulation"),
tags$hr()
),
navbarMenu("Statistical outputs",
tabPanel("One"
),
tabPanel("Two"
),
tabPanel("Three"
),
tabPanel("Four"
),
tabPanel("Report"
),
navbarMenu("More",
tabPanel("Statistical", icon = icon("info")
),
tabPanel("Info",
icon = icon("info-circle")
),
tabPanel("Subpart 4", "Subpart 4"),
tabPanel("Subpart 5", "Subpart 5")
)
)
)
)
Wrap your UI with secure_app
ui <- secure_app(ui)
Server
server <- function(input, output, session) {
# call the server part
# check_credentials returns a function to authenticate users
res_auth <- secure_server(
check_credentials = check_credentials(credentials)
)
output$auth_output <- renderPrint({
reactiveValuesToList(res_auth)
})
output$data <-renderTable({
req(input$vars)
mtcars %>% select(all_of(input$vars))
})
}
shiny::shinyApp(ui, server)

Update:
Most important in addition to 1. and 2. from the first answer. The app works as desired only if split in ui and server part!
It seems that the server part is not working but after clicking on Statistical outputs the table appears!
First answer:
Put your script.js into a www folder. This should be in the same folder where your app is.
Change includeScript("script.js"), in ui part with tags$head(tags$script(src="script.js")),

Use shinyjs to trigger an event based on the current active bsplus carousel slide

I'm trying to trigger an event in my shiny application, based on the slide that is active in a bsplus carousel that's housed within a modalDialog, i feel that using shinyjs is the way forward, given that the class changes to "active" on the data-target in the console, but my js isn't good enough to get started.
The event i wish to trigger is displaying an absolute panel that has been hidden on initialization.
min example:
library(shiny)
library(shinyjs)
library(bsplus)
ui <- fluidPage(
useShinyjs(),
hidden(
absolutePanel(
id = "button1", top = "20%", right = "20%", fixed = TRUE,
actionButton(inputId = "bttn_addmarker", label = "button")
)
)
)
server <- function(input, output, session) {
showModal(
modalDialog(
bs_carousel(id = "examples_carousel", use_indicators = TRUE) %>%
bs_set_data(interval = FALSE) %>%
bs_append("slide where absolute panel should be hidden") %>%
bs_append("slide where absolute panel should revealed")
)
)
}
shinyApp(ui, server)
Console view - when data-slide-to="0", i want the absolute panel to be hidden
when data-slide-to="1", i want the absolute panel to be shown

You are right, you can use the active value of the data-slide-to attribute to show the button but it does take a fair bit of logic in javascript to do so. We can start with how to unhide that button. When I inspect the hidden button it has class "shinyjs-hide", which has the following css rules:
.shinyjs-hide {
display: none !important;
}
So simply removing the class when the second li is active will show the button, then adding it back when the second li is not active will hide it again. Doing this is fairly straight forward. We can create a function that checks if the li tag that has a data-slide-to attribute equal to 1 has class active. If it's active, change the class of the hidden button to "shinyjs-show", which unhides the button. If it's not then change the class to "shinyjs-hide", which will hide the button.
function checkStatus(){
setTimeout(function(){
if($( `li[data-slide-to='1']` ).attr('class')=='active'){
$('.shinyjs-hide').removeClass().addClass('shinyjs-show');
} else {
$('.shinyjs-show').removeClass().addClass('shinyjs-hide');
}
}, 60);
}
Now this function needs to be checked each time either of the left or right arrows are clicked. These have class "carousel-control". We can use jQuery to add the onclick attribute, which will be set to "checkStatus();" i.e. run the checkStatus() function each time the buttons are clicked.
$('.carousel-control').attr('onclick', 'checkStatus();');
This needs to be run after the page loads, which can be done using shinyjs::runjs() inside the server like this:
session$onFlushed(function() {
shinyjs::runjs("$('.carousel-control').attr('onclick', 'checkStatus();');
")
}, once=TRUE)
The checkStatus() function has a setTimeout() to make the function wait 60ms before running the check, that's because the check needs to be on the slide that has been switched to.
Putting it all together in a shiny app like this:
library(shiny)
library(shinyjs)
library(bsplus)
js <- HTML("
function checkStatus(){
setTimeout(function(){
if($( `li[data-slide-to='1']` ).attr('class')=='active'){
$('.shinyjs-hide').removeClass().addClass('shinyjs-show');
} else {
$('.shinyjs-show').removeClass().addClass('shinyjs-hide');
}
}, 60);
}
")
ui <- fluidPage(
useShinyjs(),
tags$head(tags$script(js)),
hidden(
absolutePanel(
id = "button1", top = "20%", right = "20%", fixed = TRUE,
actionButton(inputId = "bttn_addmarker", label = "button")
)
)
)
server <- function(input, output, session) {
showModal(
modalDialog(
bs_carousel(id = "examples_carousel", use_indicators = TRUE) %>%
bs_set_data(interval = FALSE) %>%
bs_append("slide where absolute panel should be hidden") %>%
bs_append("slide where absolute panel should revealed")
)
)
session$onFlushed(function() {
shinyjs::runjs("$('.carousel-control').attr('onclick', 'checkStatus();');
")
}, once=TRUE)
}
shinyApp(ui, server)
gives:

Trigger a reaction after change of textOutput() in shiny

I am trying to use JohnCoene/marker package to highlight sections of text in a shiny app. My intend is to first generate the text using some server logic and display it with textOutput. However, I am struggeling with how to trigger the marker after the text appeared on the website. Putting it in the same observeEvent() does not work.
Here is my reprex
# remotes::install_github("johncoene/marker")
library(shiny)
library(marker)
ui <- fluidPage(
use_marker(),
actionButton("click", "click"),
textOutput("text_to_mark")
)
server <- function(input, output) {
observeEvent(input$click,
{
output$text <- renderText("My house is yellow")
})
# observeEvent() below does not work. This is just for illustration
observeEvent(input$text_to_mark,
{
marker <- marker$new("#text_to_mark.shiny-text-output.shiny-bound-output")
marker$
unmark()$ # unmark all before we mark
mark("My house")
})
}
# Run the application
shinyApp(ui = ui, server = server)
Created on 2019-10-10 by the reprex package (v0.3.0)
For illustration: I can get the marker to work, by adding a second button as in the code below, but I am look for a solution where it gets triggered when the text appears.
# remotes::install_github("johncoene/marker")
library(shiny)
library(marker)
ui <- fluidPage(
use_marker(),
actionButton("click", "click"),
textOutput("text_to_mark"),
actionButton("mark", "Mark!")
)
server <- function(input, output) {
observeEvent(input$click,
{
output$text_to_mark <- renderText("My house is yellow")
})
observeEvent(input$mark,
{
marker <- marker$new("#text_to_mark.shiny-text-output.shiny-bound-output")
marker$
unmark()$ # unmark all before we mark
mark("My house")
})
}
# Run the application
shinyApp(ui = ui, server = server)
Created on 2019-10-10 by the reprex package (v0.3.0)

You could listen on DOM changes with javascript: Is there a JavaScript / jQuery DOM change listener?.
When a change happens you can check if your target element has text:
hasText = document.getElementById("text_to_mark").innerHTML != ""
Note that i assume that your element has the id "text_to_mark".
The result you can "send to R" with
Shiny.onInputChange("hasText", hasText);
On the R side you will know if the element has text via listening on input$hasText.
So you can add:
observeEvent(input$hasText,{
...
})
The javascript you can add to your app with tags$script(jsCode) or use shinyjs.
A reproducible example:
library(shiny)
library(marker)
jsCode <- '
MutationObserver = window.MutationObserver || window.WebKitMutationObserver;
var observer = new MutationObserver(function(mutations, observer) {
console.log(mutations, observer);
hasText = document.getElementById("text_to_mark").innerHTML != ""
Shiny.onInputChange("hasText", hasText);
});
observer.observe(document, {
subtree: true,
attributes: true
});
'
ui <- fluidPage(
use_marker(),
tags$script(jsCode),
actionButton("click", "click"),
textOutput("text_to_mark"),
actionButton("mark", "Mark!")
)
server <- function(input, output) {
observeEvent(input$click, {
output$text_to_mark <- renderText("My house is yellow")
})
observeEvent(input$hasText,{
marker <- marker$new("#text_to_mark.shiny-text-output.shiny-bound-output")
marker$
unmark()$ # unmark all before we mark
mark("My house")
})
}
# Run the application
shinyApp(ui = ui, server = server)
Note that this only works on the first appearance of the text. If you also want to listen for changes of the text, one could send the text to R instead and check on the R side if the text was updated. Not sure if it is needed here.

Listening on DOM changes is one option, but your approach already shows that there is a pure shiny (non-custom-JS) solution, it only takes one click more, so the question is how to do it with only one click. I suggest using invalidateLater and wrap it in an if statement to prevent it from running over and over again like seen here.
The trick is to run your marker calls in an observe statement. Include the invalidateLater here and wrap it in an if condition with a counter which counts how many times the statement has been executed. Play around with the number of milliseconds and counts, in my case it works fine with if(isolate(val$cnt) < 1) and invalidateLater(1000). Don't forget to wrap your counter in an isolate otherwise it will get stuck in a loop.
Note also that input$click not only writes the text into a reactiveValue but also resets the counter val$cnt to 0 so that you can use the invalidateLater again on a new text. The same procedure will help you if you want to update your text using an observeEvent or the like. Just make sure to also reset the counter to 0 and the highlighting works on your new text part.
# remotes::install_github("johncoene/marker")
library(shiny)
library(marker)
ui <- fluidPage(
use_marker(),
actionButton("click", "click"),
textOutput("text_to_mark")
)
server <- function(input, output) {
val <- reactiveValues(cnt = 0,
text = NULL)
observeEvent(input$click, {
val$text <- "My house is yellow"
val$cnt <- 0
})
observe({
if(isolate(val$cnt) < 1) {
invalidateLater(1000)
}
marker <- marker$new("#text_to_mark.shiny-text-output.shiny-bound-output")
marker$
unmark()$ # unmark all before we mark
mark("My house")
val$cnt = isolate(val$cnt) + 1
})
output$text_to_mark <-renderText({
val$text
})
}
# Run the application
shinyApp(ui = ui, server = server)

Autoclose date range input shiny

I want the date picker to autoclose after a date is selected. I know how to do it when the daterangeinput is rendered directly in the ui but not when it is created in the server.
Here is my code.
library('shiny')
js_string <- "$('#dates input').bsDatepicker({autoclose: true});"
shinyApp(
ui = fluidPage(
tags$head(tags$script(HTML('Shiny.addCustomMessageHandler("jsCode", function(message) { eval(message.value); });'))),
includeScript("code.js"),
fluidRow(
column(4,
uiOutput(outputId = 'dateui'),
verbatimTextOutput("datesOut")
)
)
),
server = function(input, output, session) {
output$dateui <- renderUI({
dateRangeInput("dates", label = h3("Date range"))
})
session$onFlushed(function() {
session$sendCustomMessage(type = 'jsCode', list(value = js_string))
})
output$datesOut <- renderPrint({ names(session) })
}
)
$('#dates input').bsDatepicker({autoclose: true}); works well if the daterange is created in the ui directly as shown in following code. Besides this code also works well if I want to disable keyboard input with $('#dates').attr('onkeydown', 'return false');.
library('shiny')
shinyApp(
ui = fluidPage(
includeScript("code.js"),
fluidRow(
column(4,
dateRangeInput("dates", label = h3("Date range")),
verbatimTextOutput("datesOut")
)
)
),
server = function(input, output, session) {
output$datesOut <- renderPrint({ input$dates })
}
)
With the js code
$(document).ready(function(){
$('#dates input').bsDatepicker({autoclose: true});
});
My question is related to another question I posted.
I also tried $('#dates input').datepicker({autoclose: true}); but it does not work. I know that $(document).ready(function() ... cannot work as the code will be launched once the document is ready hence before the daterange is rendered.
Edit:
I also tried using shinyjs but it does not work either.
library('shiny')
library('shinyjs')
jsCode <- "shinyjs.changeDate = function(){
$('#dates input').bsDatepicker({autoclose: true});
$('#dates').attr('onkeydown', 'return false');
}"
shinyApp(
ui = fluidPage(
useShinyjs(),
extendShinyjs(text = jsCode),
fluidRow(
column(4,
uiOutput(outputId = 'dateui'),
verbatimTextOutput("datesOut")
)
)
),
server = function(input, output, session) {
output$dateui <- renderUI({
dateRangeInput("dates", label = h3("Date range"))
})
session$onFlushed(function() {
js$changeDate()
})
}
)
I am stuck here, any help is greatly appreciated.
Cheers
Edit2: Adding my session info
R version 3.4.4 (2018-03-15)
Platform: x86_64-apple-darwin15.6.0 (64-bit)
Running under: macOS High Sierra 10.13.3
Matrix products: default
BLAS: /System/Library/Frameworks/Accelerate.framework/Versions/A/Frameworks/vecLib.framework/Versions/A/libBLAS.dylib
LAPACK: /Library/Frameworks/R.framework/Versions/3.4/Resources/lib/libRlapack.dylib
locale:
[1] en_US.UTF-8/en_US.UTF-8/en_US.UTF-8/C/en_US.UTF-8/en_US.UTF-8
attached base packages:
[1] stats graphics grDevices utils datasets methods base
other attached packages:
[1] shinyjs_1.0 shiny_1.0.5 V8_1.5
loaded via a namespace (and not attached):
[1] compiler_3.4.4 R6_2.2.2 htmltools_0.3.6 tools_3.4.4 curl_3.1
[6] yaml_2.1.18 Rcpp_0.12.16 digest_0.6.15 jsonlite_1.5 xtable_1.8-2
[11] httpuv_1.3.6.2 mime_0.5

This is a bit hacky but it works using JQuery:
tags$head(
tags$script(HTML("setInterval(
function checkContainer () {
if($('.datepicker-days').is(':visible')){ //if the container is visible on the page
$(function () {
$('td.day').click(function () {
$('.dropdown-menu').hide()
});
});
} else {
setTimeout(checkContainer, 50); //wait 50 ms, then try again
}
},
50 /* 10000 ms = 10 sec */
);"))
)
All you need to do is add this to the tags$head function within fluidpage of your ui.
This works if the last user input is selecting the day.
If your dateRangeInput is limited to choosing the month, then all you have to do is edit '.datepicker-days' to '.datepicker-months' and change '.td.day' to '.td.month'. If you're limiting to a year; change days to years and change day to year.
The reason as to why it's hacky is because the JQuery script is being redeployed every 50ms so as to check if the datepicker-days class is visible...but it works.