I am trying to change an inputs on Shiny using JS with an input from the server (so the value can be conditional).
In this example I've fixed the value to 'NJ' but at the end id like this value to be dynamic. The end result I am trying to achieve is to get the dropdown menu to change to a value (here 'NJ') when the button is clicked. Working example below.
My JS knowledge is pretty light and most of it has come from reading the R documentation, such as the doc below.
https://shiny.rstudio.com/articles/communicating-with-js.html
library("shiny")
ui <- fluidPage(
tags$script("Shiny.addCustomMessageHandler('change_sel', function(x){
Shiny.setInputValue('state', x,{priority: 'event'});
});")
,
column(6,
selectInput("state", "Choose a state:",
c("NY", "NJ", "CT")
),
column(6,
actionButton("but1", "Change to NJ"
)
)))
server <- function(input, output, session) {
observeEvent(input$but1, {
session$sendCustomMessage("change_sel", "NJ")
})
observe(print(input$state))
}
shinyApp(ui, server)
If you are using shiny input components and would like to update the value of an input element by some other means (e.g., button click), then use one of the update- functions (available in the shiny package). However, it is unlikely that these update functions will work (or are even available) for non-Shiny widgets.
One alternative is to create a custom input binding where data is sent between Shiny and the client. This approach is best for custom input components or for creating wrappers around existing component libraries (non-R/Shiny packages). (For more information, checkout the following RStudio guides Building Custom Input Objects and How to create custom input bindings. I won't go into detail here about input bindings as it would make for a long answer).
Messages can be sent from Shiny to the client using session$sendInputMessage(). In the input binding (written using jQuery; vanilla JS won't work), use the receiveInputMessage method to retrieve and respond to the data. Using the example provided in your question, I provided a demo on how to update a custom select input widget in response to a button click.
Let me know if you have any questions!
library(shiny)
ui <- tagList(
tags$main(
tags$h1("Receive Message Input"),
tags$label(
`for` = "state",
"Select a State"
),
tags$select(
id = "state",
class = "select__input",
tags$option(value = "NONE", "--- Select ---"),
tags$option(value = "NY", "New York"),
tags$option(value = "NJ", "New Jersey"),
tags$option(value = "CT", "Connecticut")
),
tags$button(
id = "state_ny",
class = "shiny-bound-input action-button",
"Select New York"
),
tags$button(
id = "state_nj",
class = "shiny-bound-input action-button",
"Select New Jersey"
),
tags$button(
id = "state_reset",
class = "shiny-bound-input action-button",
"Reset"
)
),
tags$script(
type = "text/javascript",
HTML(
"const myCustomBinding = new Shiny.InputBinding();",
"$.extend(myCustomBinding, {
find = function(scope) {
return $(scope).find('.select__input');
},
getValue = function(el) {
return $(scope).value;
},
subscribe = function(el, callback) {
$(el).on('change', function(e) {
callback();
});
},
receiveInputMessage = function(el, message) {
if (message.type === 'update') {
$(el).value = data.value
}
},
unsubscribe = function(el) {
$(el).off('myCustomBinding');
}
});",
"Shiny.inputBindings.register(myCustomBinding);"
)
)
)
server <- function(input, output, session) {
# server-side function for sending data for use in `receiveInputMessage`
setSelectValue <- function(inputId, value) {
session$sendInputMessage(
inputId = inputId,
message = list(
type = "update",
value = value
)
)
}
# onClick Events
observeEvent(input$state_ny, setSelectValue("state", "NY"))
observeEvent(input$state_nj, setSelectValue("state", "NJ"))
observeEvent(input$state_reset, setSelectValue("state", "NONE"))
observe(print(input$state))
}
shinyApp(ui, server)
Related
I am using the fullPage package to create a Shiny App and I am facing the following issue : I would like to update from the server side the labels of the menu that are first defined in the pagePiling function of the ui part.
I have seen in the HTML code that the field that I should update is the one here below, but I don't know how to change it/access it in the server part of my app.
<ul id="tocMenu">
<li data-menuanchor="test_page">
temp_title
</li>
</ul>
I have the impression that this sould be achievable with javascript, but I don't know a lot about js ; among others, I have tried so far the following stuff :
library(fullPage)
library(shiny)
library(shinyjs)
library(shinyWidgets)
shinyApp(
ui = pagePiling(
shinyjs::useShinyjs(),
center = TRUE,
sections.color = c(
"#CFE2F3"
),
menu = c(
"temp_title" = "test_page"
),
pageSection(
menu="test_page",
pickerInput("title", multiple = F, selected=NULL,
choices = c("Title 1", "Title 2")),
)
),
server = function(input, output) {
observeEvent(input$title, {
# runjs("$('#fullpage').fullpage({
# anchors: ['test'],
# menu: '#tocMenu'});")
runjs(paste0('document.getElementById("test_page").innerHTML = "', input$title, '";'))
} )
}
)
If anyone could help, I would be very grateful !
Thanks
The problem is that you use getElementById() but the menu title doesn't have an id, it has an href tag:
Therefore, you should use querySelectorAll() instead and specify the characteristics of the element you want to select (here, it's an element a that has href="#test_page"). Finally, this function returns a list of elements (this list only contains 1 element here), so you need to use [0] to select it.
Here's your example fixed:
library(fullPage)
library(shiny)
library(shinyjs)
library(shinyWidgets)
shinyApp(
ui = pagePiling(
shinyjs::useShinyjs(),
center = TRUE,
sections.color = c(
"#CFE2F3"
),
menu = c(
"temp_title" = "test_page"
),
pageSection(
menu="test_page",
pickerInput("title", multiple = F, selected=NULL,
choices = c("Title 1", "Title 2")),
)
),
server = function(input, output) {
observeEvent(input$title, {
# runjs("$('#fullpage').fullpage({
# anchors: ['test'],
# menu: '#tocMenu'});")
runjs(paste0('document.querySelectorAll("a[href=\'#test_page\']")[0].innerHTML = "', input$title, '";'))
} )
}
)
Is there a way to find out in shiny whether the focus is on a text-field (or maybe select field)?
My website has a lot of elements like plots, tables, numerical inputs and buttons.
Currently I have something like this:
library(shiny)
ui <- fluidPage(
tags$script('$(document).ready(function(){ $("*").focus( function(e){ Shiny.setInputValue("focusedElement", e.target.id);}); }); '),
textOutput("output1"),
textInput(inputId = "text1", label = 'Text1', value = ""),
numericInput(inputId = 'num1',label = 'Num1', value=5),
selectInput(inputId = 'select1', label='Select1',choices = c(1,2,3)),
plotOutput('plot'),
actionButton('btn','Btn'),
DT::dataTableOutput('table'),
)
server <- function(input, output, session) {
output$output1 <- renderText({
print(input$focusedElement)
input$focusedElement })
output$table<- DT::renderDataTable(iris)
output$plot<-renderPlot(plot(iris[,c(3,4)]))
}
shinyApp(ui, server)
Although I focussed every single input and the empty background, the only thing that works is Text-Input, Numerical-Input and Buttons. Why is that? (Take a look at the console output, select1 was definitely focussed at some point but never printed, also the search-bar and the plot and the background.)
Please feel free to propose completely different approaches or correct my style.
What I want to know in the end is actually just whether I am in a text-field (like text1 or num1 or the search-bar of the table) or a button at the moment.
That's probably because the element which is focused is an option element, not the select element itself.
You can use selectizeInput to trigger something on focus, with the help of the onFocus option.
library(shiny)
js <- "function() {
Shiny.setInputValue('focus', true, {priority: 'event'});
}"
ui <- fluidPage(
selectizeInput(
"ID", "LABEL",
choices = list("A", "B", "C"),
options = list(
onFocus = I(js)
)
)
)
server <- function(input, output, session) {
observeEvent(input[["focus"]], {
showNotification("FOCUS!!!")
})
}
shinyApp(ui, server)
EDIT
There's also the onBlur option, a function which is executed when the focus is lost. So you can do something like that:
onFocus <- "function() {
Shiny.setInputValue('focus', 'SELECT');
}"
onBlur <- "function() {
Shiny.setInputValue('focus', null);
}"
ui <- fluidPage(
selectizeInput(
"ID", "LABEL",
choices = list("A", "B", "C"),
options = list(
onFocus = I(onFocus), onBlur = I(onBlur)
)
)
)
Do something similar with the other widgets you are interested in, and in this way the Shiny variable input$focus will always be set to the currently focused element among the widgets you are interested in, and to NULL if none is focused.
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")),
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)
The idea
I have a box() in a shiny app. The box() includes a title argument (which in turn includes an icon) and a selectInput()element. On hoover over the icon I wanted to have a tooltip (using tipify()) or a popover (using popify()) which title or content argument (or both) would be generated depending on selectInput() input.
The problem
Neither tipify() nor popify() correcctly implement textOutput() as their title or content argument. They need a character string so I tried to use a reactiveValues() element as a function argument but it also failed.
The question
Can tooltip or popover content be made dynamic by just using r? How could this be done?
I suspect it can be done with JavaScript but I have little knowledge of it.
The code
Attempt 1 - failed - displays code not actual text
library("shiny")
library("shinydashboard")
library("shinyBS")
ui <- fluidPage(
box(
title = span("My box",
tipify(el = icon(name = "info-circle", lib = "font-awesome"), title = textOutput("TIP"))),
selectInput(
inputId = "SELECT",
label = NULL,
choices = c("Option1" = "Option1",
"Option2" = "Option2"
),
multiple = FALSE
)
)
)
server <- function(input, output, session){
output$TIP <- renderText({"Helo world!"})
}
shinyApp(ui, server)
Attempt 2 - failed - cannot create UI as TIP (reactiveValues()) is not yet defined
library("shiny")
library("shinydashboard")
library("shinyBS")
ui <- fluidPage(
box(
title = span("My box",
tipify(el = icon(name = "info-circle", lib = "font-awesome"), title = TIP$a)),
selectInput(
inputId = "SELECT",
label = NULL,
choices = c("Option1" = "Option1",
"Option2" = "Option2"
),
multiple = FALSE
)
)
)
server <- function(input, output, session){
TIP <- reactiveValues(a = "Hello world!")
}
shinyApp(ui, server)
Here is a similar question but it does not solve the problem described here.
What could be done is creating the title entirely in the server side. This way you have no problem making it dynamic. This could give you this kind of app:
library("shiny")
library("shinydashboard")
library("shinyBS")
ui <- fluidPage(
box(
title = uiOutput("title"),
selectInput(
inputId = "SELECT",
label = NULL,
choices = c("Option1" = "Option1",
"Option2" = "Option2"
),
multiple = FALSE
)
)
)
server <- function(input, output, session){
TIP <- reactiveValues()
observe({
TIP$a <- ifelse(input$SELECT =="Option1","Hello World","Hello Mars")
})
output$title <- renderUI({span("My box",
tipify(el = icon(name = "info-circle", lib = "font-awesome"), title = TIP$a))})
}
shinyApp(ui, server)
Hope it helps.