Develop Reference

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")),

Extract the duration of hosted audio files in R (without downloading the file)

I have a list of hosted audio files for which I would like to get the duration of, without having to download the files themselves.
I can do this by creating a html DOM element <audio> and extracting the duration with the duration attribute. This works nicely in the following shinyapp: When clicking on the button "Click me", the duration is returned in an alert.
shinyApp(
ui = fluidPage(
useShinyjs(),
actionButton("btn", "Click me"),
tags$audio(id = "myaudio",
src = "https://download.samplelib.com/mp3/sample-3s.mp3",
type = "audio/mp3", autoplay = NA, controls = NA)
),
server = function(input, output) {
observeEvent(input$btn, {
runjs("alert(myaudio.duration);")
})
}
)
This is the point where I am stuck: How can I leverage this method to extract the duration of multiple (> 1'000) mp3s?
How can I replace the src= and iterate of a list of mp3s?
How can I write out the duration so that I can further process this in R?

This answer only works for one audio file
To get the duration of the audio and print it, we need to use js, an environment in shinyjs as follows:
Define get_duration as our JS and specify what happens when the input changes via Shiny.onInputChange. Here I have also used reactiveValues to store durations on change.
library(shinyjs)
library(shiny)
get_duration <- 'shinyjs.aud_duration = function(params) {
var duration = myaudio.duration;
Shiny.onInputChange("aud_duration", duration);
}'
ui <- fluidPage(
useShinyjs(),
extendShinyjs(text = get_duration, functions = "aud_duration"),
actionButton("btn", "Click me"),
tags$audio(id = "myaudio",
src = "https://download.samplelib.com/mp3/sample-3s.mp3",
type = "audio/mp3", autoplay = NA, controls = NA),
verbatimTextOutput("aud_duration")
)
server <- function(input, output) {
js$aud_duration()
durations <- reactiveValues(duration = NA)
observeEvent(input$btn,
durations$duration <- input$aud_duration
)
output$aud_duration <- renderText(durations$duration)
}
shinyApp(ui, server)

Thanks to #NelsonGon's answer, which solved part of the problem, I was able to develop a solution to my problem which scales and thus works on multiple urls. It solves the following problems:
it does not wait for a user to click a button but tries to get the duration every second until it succeeds (since it takes a while for the metadata to get downloaded)
the shiny app is wrapped into a function, so that the url of the source can be input
upon success, the duration value is returned
get_duration <- function(src){
library(shinyjs)
library(shiny)
get_duration <- 'shinyjs.aud_duration = function(params) {
var duration = myaudio.duration;
Shiny.onInputChange("aud_duration", duration);
}'
ui <- fluidPage(
useShinyjs(),
extendShinyjs(text = get_duration, functions = "aud_duration"),
tags$audio(id = "myaudio",
src = src),
)
server <- function(input, output) {
js$aud_duration()
durations <- reactiveValues(duration = NA)
observe({
invalidateLater(1000)
if(!is.null(isolate(input$aud_duration))){
stopApp(input$aud_duration)
}
})
}
shiny::runGadget(ui, server)
}
it an be run as follows:
get_duration("https://download.samplelib.com/mp3/sample-3s.mp3")
[1] 3.239184

How the change attributes of UI elements with JavaScript in Shiny?

I know there is this server side method called renderUI, but it makes updating the UI extremely slow in some cases, so I am now relying on the JavaScript.
My problem is a follows. I would like to update the title attribute of material_card from shinymaterial package. I would like to see the title to change, every time I select an alternative from a separate dropdown menu.
So far my list of UI components contain tags$script() object, which is supposed to observe the changes in the selectInput (goes with id "dropdown").
My code looks as follows:
library(shinymaterial)
library(shiny)
ui <- material_page(
titlePanel("Soon to be working JavaScript example!"),
sidebarLayout(
sidebarPanel(
selectInput(
"dropdown",
"Dropdown menu",
c('Hat','Shoes','Jacket')),
tags$script('
$(document).on("shiny:inputchanged", function(event) {
if (event.name === "dropdown") {
if(input.dropdown === "Jacket") {
//Even this alert is not working, possibly because input.name is not recognized. :(
alert("You chose Jacket, now the material card title will be changed to: Jacket selected");
//What am I supposed to put here to update the material_card title?
} else {
//...and here as well...
}
});'
),
material_card(
depth=5,
title = 'This value needs to be changed according what was chosen in the dropdown menu!')
),
mainPanel(
h5('Nothing here!')
)
)
)
server <- function(input, output) {
#The server is empty, as it should. :)
}
shinyApp(ui = ui, server = server)
I managed to get the alert working without the if(input.dropdown === "Jacket") validation, but this validation is not working: Most likely input.dropdown is not even recognized, although it works nicely with conditional panel.
Furthermore, I am even more lost with the logic: How should I actually use JavaScript to update the material_card title, after the change in selectInput (dropdown) value has been observed?

library(shinymaterial)
library(shiny)
ui <- material_page(
titlePanel("Soon to be working JavaScript example!"),
sidebarLayout(
sidebarPanel(
selectInput(
"dropdown",
"Dropdown menu",
c('Hat','Shoes','Jacket')),
tags$script(HTML('
$(document).on("shiny:inputchanged", function(event) {
if (event.name === "dropdown") {
if(event.value === "Jacket") {
alert("You chose Jacket, now the material card title will be changed to: Jacket selected");
$("#mycard>span.card-title").html("Here is the new card title");
} else {
//...and here as well...
}
}
});')
),
material_card(
depth=5,
title = 'This value needs to be changed according what was chosen in the dropdown menu!',
id = "mycard"
)
),
mainPanel(
h5('Nothing here!')
)
)
)
shinyApp(ui, server = function(input,output){})

A shiny UI-only solution:
library(shinymaterial)
library(shiny)
dropdownChoices <- c('Hat','Shoes','Jacket')
ui <- material_page(
titlePanel("Soon to be working JavaScript example!"),
sidebarLayout(
sidebarPanel(
selectInput(
"dropdown",
"Dropdown menu",
dropdownChoices),
material_card(
depth = 5,
title = lapply(dropdownChoices, function(i){
conditionalPanel(sprintf('input.dropdown == "%s"', i), i)
})
)),
mainPanel(
h5('Nothing here!')
)
)
)
server <- function(input, output) {}
shinyApp(ui = ui, server = server)

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)

Automatically scroll on button click in Shiny

I have a tabbed shiny app that generates quite a bit of content based on user inputs and I'm trying to figure out how to scroll to the bottom of the active tab each time new content is generated. I tried implementing the answer given in this question but it doesn't seem to work. I'm have minimal experience with javaScript so it may just be something needs to be changed for my specific example. Here is a very silly toy example with my attempt at implementing the answer from the linked question:
library(shiny)
ui <- fluidPage(
tags$script(
'
Shiny.addCustomMessageHandler("scrollCallback",
function(color) {
var objDiv = document.getElementById("outDiv");
objDiv.scrollTop = objDiv.scrollHeight;
}
);'
),
tabsetPanel(id = "mainPanels",
tabPanel("FirstPanel",
actionButton("outGen", "GenerateOutput"))),
uiOutput("randomOutput")
)
server <- function(input, output, session) {
output$randomOutput <- renderUI({
req(input$outGen)
lapply(1:50, function(x)p("FooBar"))
})
observeEvent(input$outGen,{
session$sendCustomMessage(type = "scrollCallback", 1)
})
}
runApp(shinyApp(ui,server))
I'm trying to find a way to scroll to the bottom of the tab once the generate output button is pressed.

Here is a fixup that works. The following changes were made:
Changed the initialization so that there is some text rendered to that div before we start. This is necessary otherwise some of the variables will not be initialized properly in the div object.
Modified the text output so it changes every time (for better testing)
Added the necessary CSS overflow:auto style to the randomOutput div so that you would have a scroll bar to scroll.
Fixed up some minor typos (getElementById was querying the wrong div)
added some debugging output to scrollCallback
Here is the code:
library(shiny)
ui <- fluidPage(
tags$style('#randomOutput { height: 450px; overflow: auto;}'),
tags$script(
'
Shiny.addCustomMessageHandler("scrollCallback",
function(msg) {
console.log("aCMH" + msg)
var objDiv = document.getElementById("randomOutput");
objDiv.scrollTop = objDiv.scrollHeight - objDiv.clientHeight;
console.dir(objDiv)
console.log("sT:"+objDiv.scrollTop+" = sH:"+objDiv.scrollHeight+" cH:"+objDiv.clientHeight)
}
);'
),
tabsetPanel(id = "mainPanels",
tabPanel("FirstPanel",
actionButton("outGen", "GenerateOutput"))),
uiOutput("randomOutput")
)
server <- function(input, output, session) {
n <- 0
output$randomOutput <- renderUI({
input$outGen
n <<- n + 50
lapply(1:50, function(x)p(paste0("FooBar-",x+n-50)))
})
observeEvent(input$outGen,{
session$sendCustomMessage(type = "scrollCallback", 1)
})
}
runApp(shinyApp(ui,server))
and here is what it looks like on testing: