How to conditionally play an audio clip in R Shiny? - r

Goal
Play an audio clip for navigation whenever the reactive value of position is in a certain range
What I tried
Based on other questions, I found that a button can be used to play an audio clip. For example:
An example with action button
library(shiny)
addResourcePath("Music", "Music")
audio_file1 <- "Music/in 200 m turn left.mp3"
ui <- fluidPage(
basicPage(
actionButton("play", "Play the Audio")
)
)
server <- function(input, output, session) {
observeEvent(input$play, {
insertUI(selector = "#play",
where = "afterEnd",
ui = tags$audio(src = audio_file1, type = "audio/mp3", autoplay = NA, controls = NA, style="display:none;")
)
})
}
shinyApp(ui, server)
My modifications without an action button
I want to autoplay the audio clip whenever the position x is a certain value. For keeping the question short, I am providing x inside server in this example:
server <- function(input, output, session) {
x <- 1
observeEvent(if (x==1){return(x)}, {
insertUI(selector = "#play",
where = "afterEnd",
ui = tags$audio(src = audio_file1, type = "audio/mp3", autoplay = TRUE, controls = NA, style="display:none;")
)
})
}
However, that threw an error:
Warning: Error in eval_tidy: no function to return from, jumping to top level
[No stack trace available]
I have also separately tried using the uiOutput and renderUI as follows (server part):
output$audioo <- renderUI({
if (x > 0.5 & x < 1.5) {
tags$audio(src = audio_file_200_TL, type = "audio/mp3", autoplay = TRUE, controls = NA)
} else {
tags$h1("My header")
}
})
But that plays the audio when the app is just launched and the audio does not play when x is in the provided range. How can I conditionally play an audio clip without using an action button?

So x is not an input nor a reactive. We need this as R process has to know the time to rerun the cycle. There are other hardcore solution which I am not recommending like shiny::invalidateLater().
Try sth like:
x_r <- reactive(x)
observeEvent(x_r(), {
if (x_r() == 1) {
insertUI(selector = "#play",
where = "afterEnd",
ui = tags$audio(src = audio_file1, type = "audio/mp3", autoplay = TRUE, controls = NA, style="display:none;"), immediate = TRUE
)
}
})
Btw be very careful with insertUI, I do not like to use it as we might add the same element many times. More elegant strategy for me is to add the element by default and later only edit in the DOM, hide/show/edit. we could use shinyjs package for such action. insertUI often need immediate = TRUE argument.
EDIT:
This app is working perfectly for me. The question is what is the x in your app. mp3 taken from https://samplelib.com/sample-mp3.html.
library(shiny)
addResourcePath("Music", "Music")
audio_file1 <- "Music/sample-3s.mp3"
ui <- fluidPage(
basicPage(
tags$div(id = "AUDIO_MY"),
selectInput("STH", "STH", 1:10, 1)
)
)
server <- function(input, output, session) {
observeEvent(req(input$STH == "1"), {
insertUI(selector = "#AUDIO_MY",
where = "afterEnd",
ui = tags$audio(src = audio_file1, type = "audio/mp3", autoplay = NA, controls = NA, style="display:none;")
, immediate = TRUE)
})
}

Related

Shinyglide jumping back to previous screen when next_condition is set

I have a shiny app in which a datatable is displayed and upon a click on a row, a modalDialog opens in which I embedded a glide from shinyglide. This worked fine until I introduced a next_condition to the second screen. Now whenever the first box is selected (or after deselecting everything and selecting again), the glide jumps back to the first screen. If you now change the option on the first screen, then the behaviour gets very strange altogether. I have no idea what causes this or where to start to fix it. Below is a (not so small) mockup example of my app which includes the observed behaviour (if you uncomment the next_condition, everything works fine). The important part to the problem is the server part in the end, the rest is just setup to make the app fully functional.
UPDATE:
I have tried to shorten the example by getting rid of the datatable and the modalDialog, but I could not replicate the behaviour this way. So it seems to me the interaction between modalDialog and glide is at fault. I was however able to shorten it a tiny bit by getting rid of the reactive variables without changing the result.
UPDATE 2:
Also posted it here, but the answer has not (yet) worked for me.
Code:
Library Calls:
library(shiny)
library(shinydashboard)
library(shinyBS)
library(shinyglide)
library(shinyWidgets)
library(shinyjs)
library(DT)
UI:
ui <- dashboardPage(skin = 'purple',
dashboardHeader(title = "Shinyglide Example"),
dashboardSidebar(disable = TRUE),
dashboardBody(
useShinyjs(),
tags$head(tags$style("#modal1 .modal-body {min-height:750px; padding: 10px}
#modal1 .modal-dialog { width: 1280px; height: 1280px;}"
)),
fixedRow(
column(width = 12,
box(title = "I am the table!",width = NULL,status = 'info',solidHeader = TRUE,
DT::dataTableOutput("table")))
)
)
)
Setup Functions:
render_my_table <- function(){
col_a <- c("A","B","C","D","E")
col_b <- c("Human","Cat","Human","Dog","Dog")
col_c <- c(35,7,42,5,11)
col_d <- c("Earth","Earth","Earth","Earth","Mars")
my_data <- data.frame(letter = col_a,species = col_b,age = col_c,planet = col_d)
my_data <- datatable(my_data,colnames = c("ID","Species","Age","Home Planet"),rownames = FALSE,filter = 'top',selection = 'single',
callback = JS("table.on('click.dt','tr',function() {
Shiny.onInputChange('rows',table.rows(this).data().toArray(),{priority:'event'});});"))
return(my_data)
}
pickerinput_choices <- function(my_species){
if(my_species == "Human"){
return(c("Job","Family","Mortgage"))
}else{
return(c("Breed","Owner","Family"))
}
}
advanced_inputs <- function(my_species,my_choiceA){
if(is.null(my_choiceA)){return(0)}
if(my_choiceA == "Job"){
return(checkboxGroupInput("my_checkbox",label = "Type of Jobs",choices = c("Employed","Self-Employed","Apprenticeship")))
}else if(my_choiceA == "Mortgage"){
return(checkboxGroupInput("my_checkbox",label = "Type of Housing",choices = c("Apartment","House")))
}else if(my_choiceA == "Breed"){
return(checkboxGroupInput("my_checkbox",label = "Details",choices = c("Height","Fur","Weight")))
}else if(my_choiceA == "Owner"){
return(checkboxGroupInput("my_checkbox",label = "Details",choices = c("Age","Employed","Children")))
}else{
if(my_species == "Human"){
return(checkboxGroupInput("my_checkbox",label = "Details",choices = c("Partner","Parents","Children","Siblings")))
}else{
return(checkboxGroupInput("my_checkbox",label = "Details",choices = c("Owner","Children","Owners of Children")))
}
}
}
Server:
server <- function(input, output,session) {
glide_modal <- modalDialog(
renderUI({title = tags$span(paste("You have chosen Row",input$rows[1]),style = "font-size: 20px; font-weight: bold")}),
footer = NULL,
easyClose = TRUE,
glide(
id = "my_glide",
controls_position = 'bottom',
height = "800px",
screen(
renderUI({
pickerInput(inputId = "my_pickerinput",h3("Make Choice A"),choices = pickerinput_choices(input$rows[2]),
options = pickerOptions(container = 'body'))
})
),
screen(
renderUI({
tagList(
h3("Make Choice B"),
advanced_inputs(input$rows[2],input$my_pickerinput)
)
}),
next_condition = "(typeof input['my_checkbox'] !== 'undefined' && input['my_checkbox'].length > 0)"
),
screen(
renderText({
paste("You have selected row",input$rows[1],"which is a",input$rows[2],"and have requested information about",
input$my_pickerinput,", especially about",paste(input$my_checkbox,collapse = " and "))
})
)
)
)
output$table <- DT::renderDataTable({
render_my_table()
})
observeEvent(input$rows,{
showModal(tags$div(id="modal1",glide_modal))
})
}
and function call:
shinyApp(ui = ui, server = server)
Fixed by the newest development version thanks to the package author. See the github thread, the code works now as posted in the question.

Why is removeUI leaving behind the UI label?

I am trying to increase and decrease the number of UI elements based on user input. This MRE code kind of works but it is leaving behind the UI label when I use removeUI, which I did not expect. Any ideas on how to make the label go away along with the input box?
## Only run this example in interactive R sessions
if (interactive()) {
# Define UI
ui <- fluidPage(
numericInput(inputId = "assessors",label = "Number of Assessors",value = 1,min = 1,step = 1),
textInput(inputId = "assessor1",label = "Assessor 1 Columns")
)
# Server logic
server <- function(input, output, session) {
tot_app<-0
observeEvent(input$assessors, {
num<-input$assessors
if(num>tot_app){#add
adds<-seq(tot_app+1,num)
for(i in adds){
here<-paste0("#assessor",i-1)
insertUI(
selector = here,
where = "afterEnd",
ui = textInput(paste0("assessor", i),
paste0("Assessor ",i," columns"))
)
}
tot_app<<-num
} else if(num<tot_app){#subtract
subs<-seq(num+1,tot_app)
for(i in subs){
removeUI(selector = paste0("#assessor",i))
}
tot_app<<-num
}
})
}
# Complete app with UI and server components
shinyApp(ui, server)
}
As in the help example, it works if you use use this syntax:
removeUI(selector = paste0("div:has(> #assessor",i,")"))

Adjust size of Shiny progress bar and center it

I'm working with a Shiny app where I need to calculate processes and while the calc progress is executing, I'm using a progressBar to show the process.
The problem is that the progress bar is too small, and I don't like the way is shown.
So, I was thinking that maybe there's a way to implement a progress bar using a Shiny modal (there's a function called modalDialog).
My idea is that when the user runs the calc, a modal will be opened showing a progressBar.
This is the progress code:
withProgress(message = 'Runing GSVA', value = 0, {
incProgress(1, detail = "This may take a while...")
functionToGenerate()
})
Any idea?
I would suggest customizing the CSS class of the notification:
If you inspect the element of the notifier you see that it has the class "shiny-notification". So you can overwrite some properties of that class with tags$style(). In the example below (for the template: see ?withProgress) i decided to adjust height+width to make it bigger and top+left to center it.
ui <- fluidPage(
tags$head(
tags$style(
HTML(".shiny-notification {
height: 100px;
width: 800px;
position:fixed;
top: calc(50% - 50px);;
left: calc(50% - 400px);;
}
"
)
)
),
plotOutput("plot")
)
server <- function(input, output) {
output$plot <- renderPlot({
withProgress(message = 'Calculation in progress',
detail = 'This may take a while...', value = 0, {
for (i in 1:15) {
incProgress(1/15)
Sys.sleep(0.25)
}
})
plot(cars)
})
}
runApp(shinyApp(ui, server), launch.browser = TRUE)
I wrote a progress bar function in the package shinyWidgets, you can put it in a modal, but it's tricky to use with shiny::showModal, so you can create your own modal manually like the below. It's more code to write but it works fine.
library("shiny")
library("shinyWidgets")
ui <- fluidPage(
actionButton(inputId = "go", label = "Launch long calculation"), #, onclick = "$('#my-modal').modal().focus();"
# You can open the modal server-side, you have to put this in the ui :
tags$script("Shiny.addCustomMessageHandler('launch-modal', function(d) {$('#' + d).modal().focus();})"),
tags$script("Shiny.addCustomMessageHandler('remove-modal', function(d) {$('#' + d).modal('hide');})"),
# Code for creating a modal
tags$div(
id = "my-modal",
class="modal fade", tabindex="-1", `data-backdrop`="static", `data-keyboard`="false",
tags$div(
class="modal-dialog",
tags$div(
class = "modal-content",
tags$div(class="modal-header", tags$h4(class="modal-title", "Calculation in progress")),
tags$div(
class="modal-body",
shinyWidgets::progressBar(id = "pb", value = 0, display_pct = TRUE)
),
tags$div(class="modal-footer", tags$button(type="button", class="btn btn-default", `data-dismiss`="modal", "Dismiss"))
)
)
)
)
server <- function(input, output, session) {
value <- reactiveVal(0)
observeEvent(input$go, {
shinyWidgets::updateProgressBar(session = session, id = "pb", value = 0) # reinitialize to 0 if you run the calculation several times
session$sendCustomMessage(type = 'launch-modal', "my-modal") # launch the modal
# run calculation
for (i in 1:10) {
Sys.sleep(0.5)
newValue <- value() + 1
value(newValue)
shinyWidgets::updateProgressBar(session = session, id = "pb", value = 100/10*i)
}
Sys.sleep(0.5)
# session$sendCustomMessage(type = 'remove-modal', "my-modal") # hide the modal programmatically
})
}
shinyApp(ui = ui, server = server)

shinyBS Modal within checkbox group

I use shinyBS::bsModal() to place explanations of the UI elements there. It works great when I place a bsButton() behind the title of the checkbox.
Now I want to place it behind the checkbox options.
A first hint could be this answer where the same for a tooltip is done (but my modification do not work).
Minimal Example:
library(shiny)
library(shinyBS)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
checkboxGroupInput("qualdim",
tags$span("Chekboxoptions",
bsButton("modalbt", "?", style = "inverse", size = "extra-small")),
c("Option_1" = "Option_1",
"Option_2" = "Option_2"))
),
mainPanel(
bsModal("modalExample", "Modal", "modalbt", size = "large",
verbatimTextOutput("helptext")))
)
)
server <- function(input, output) {
output$helptext <- renderText({"I can trigger a shinyBS::bsModal() from here, but I want to place two buttons behind `Option_1` and `Option_2`" })
}
shinyApp(ui = ui, server = server)
The bsModal works anywhere and just takes the button id as a trigger. So the only thing you need to do is to get a suitable button inside the checkboxGroup. From the previous Question/Answer you linked, you already have the function to get a bsButton inside the group input. (Just erase the line where the tooltip has been assigned. This is not needed here.)
The code below basically is copy paste now. I just added some extra bsButton settings like size, style and id (this one is important! was not important in the linked question with the tooltips!), such that you can use the function more like you would use bsButton.
library(shiny)
library(shinyBS)
makeCheckboxButton <- function(checkboxValue, buttonId, buttonLabel, size = "default", style = "default"){
size <- switch(size, `extra-small` = "btn-xs", small = "btn-sm",
large = "btn-lg", "default")
style <- paste0("btn-", style)
tags$script(HTML(paste0("
$(document).ready(function() {
var inputElements = document.getElementsByTagName('input');
for(var i = 0; i < inputElements.length; i++){
var input = inputElements[i];
if(input.getAttribute('value') == '", checkboxValue, "'){
var button = document.createElement('button');
button.setAttribute('id', '", buttonId, "');
button.setAttribute('type', 'button');
button.setAttribute('class', '", paste("btn action-button", style , size), "');
button.appendChild(document.createTextNode('", buttonLabel, "'));
input.parentElement.parentElement.appendChild(button);
};
}
});
")))
}
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
checkboxGroupInput("qualdim", label = "Chekboxoptions", choices = c("Option_1", "Option_2")),
makeCheckboxButton("Option_1", "modalbt", "?", size = "extra-small", style = "inverse")
),
mainPanel(
bsModal("modalExample", "Modal", "modalbt", size = "large",
verbatimTextOutput("helptext")))
)
)
server <- function(input, output) {
output$helptext <- renderText({"I can trigger a shinyBS::bsModal() from here, but I want to place two buttons behind `Option_1` and `Option_2`" })
}
shinyApp(ui = ui, server = server)

Use bsModal in the shinyBS package with plotly R plotly_click to generate new plot in pop up

Here is my code for a basic shiny app using plotly_click event to optionally show another plot. I would like that side box plot to render in a modal pop up instead of on the side within the page.
library(shiny)
library(plotly)
df1 <- data.frame(x = 1:10, y = 1:10)
df2 <- data.frame(x = c(rep('a', 10), rep('b', 10)),
y = c(rnorm(10), rnorm(10, 3, 1)))
ui <- fluidPage(
column(6, plotlyOutput('scatter')),
column(6, plotlyOutput('box'))
)
server <- function(input, output) {
output$scatter <- renderPlotly({
plot_ly(df1, x = x, y = y, mode = 'markers', source = 'scatter')
})
output$box <- renderPlotly({
eventdata <- event_data('plotly_click', source = 'scatter')
validate(need(!is.null(eventdata),
'Hover over the scatter plot to populate this boxplot'))
plot_ly(df2, x = x, y = y, type = 'box')
})
}
shinyApp(ui = ui, server = server)
I was able to follow this question (Shiny: plot results in popup window) and response, and tried to use it with the trigger of plotly_click without success. Any idea how to pull the same thing off with a plotly hover click event?
UPDATE: I can clearly see that a plotly plot can be rendered in a shinyBS modal pop up window as demonstrated by this code.
df1 <- data.frame(x = 1:10, y = 1:10)
ui <- fluidPage(
actionButton('go', 'Click Go'),
bsModal('plotlyPlot', 'Here is a Plot', 'go', plotlyOutput('scatter1'))
)
server <- function(input, output) {
output$scatter1 <- renderPlotly({
plot_ly(df2, x = x, y = y, mode = 'markers', source = 'scatter1')
})
}
shinyApp(ui = ui, server = server)
Instead of an actionButton as the trigger, I want the plotly_click or plotly_hover as there trigger (in the original example).
You can use toggleModal, just add this to your server:
observeEvent(event_data("plotly_click", source = "scatter"), {
toggleModal(session, "boxPopUp", toggle = "toggle")
})
and put the box Plot in an bsModal (Title and trigger is empty):
ui <- fluidPage(
column(6, plotlyOutput('scatter')),
bsModal('boxPopUp', '', '', plotlyOutput('box'))
)
UPDATE: with shiny-build-in Modal functionality (since Shiny 0.14), only the server addition is needed:
observeEvent(event_data("plotly_click", source = "scatter"), {
showModal(modalDialog(
renderPlotly({
plot_ly(df2, x = ~x, y = ~y, type = 'box')
})
))
})
Using CSS
You can use HTML builder to contain the plots and use stylesheet to add dynamic effects.
ui <- fluidPage(
includeCSS(path_to_css_file),
div( class='mainchart',
column(6, plotlyOutput('scatter')),
div( class='popup',
column(6, plotlyOutput('box'))
)
)
)
CSS
div.popup {
display : none;
position: absolute;
}
div.mainchart : focus > div.popup {
display : block;
}
div.mainchart {
position: relative;
}
Using Javascript
You can use the plotly embeded-API to set the visibility of your side box.
shinyBS
Since you want to stick to shinyBS, you can use the bsPopover function with a little trick. I assume you already know how to use bsModel which is similar to the example below.
Pass the following argument to fluidPage
bsTooltip(id, title, placement = "bottom", trigger = "click", content=column(6, plotlyOutput('box')) )
This will create the plot with a Popover wraper. I didn't test it yet. In case of error, you can also try
options = list()
options$content = column(6, plotlyOutput('box'))
options$html = T # otherwise the conent will be converted to text
bsTooltip(id, title, placement = "bottom", trigger = "click", options=options )
Visit this source file of shinyBS and the popover(options) function of bootstrap for more info.

Resources