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.
Related
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)
I've searched stackoverflow and the complete web, but I can't find to seem a good answer to this, seemingly simple, problem.
The situation is as follows:
I have a Shiny application, connected with a database
I have several user inputs (Pickerinputs), where a user can select multiple arguments
The user inputs are all dependent on each other
The problem that arises is the following:
If a user ticks multiple car brands (for example, Renault, Peugeot and BMW) then the pickerinput that is linked to this selection (specific car models for these brands) gets updated three times. With many pickerinputs that are linked to each other, this creates messy UX.
Solution needed
I think the solution is simple: the pickerinput only needs to send the selected values after the input has been closed; it does not need to send values (and trigger updates) after every pick a user makes. The AirdatePickerInput from Shinywidgets has this specific feature (update_on=c('change', 'close'). What I need is that my pickerInput gets updated only on 'close'. So that the resulting values are send only once back to the server.
Example:
UI
ui <- fluidPage(
# Title panel
fluidRow(
column(2,
wellPanel(
h3("Filters"),
uiOutput("picker_a"),
uiOutput("picker_b"),
)
),
)
)
Server
server <- function(input, output, session) {
# Start values for each filter
all_values_for_a <- tbl(conn, "table") %>%
distinct(a) %>%
collect()
all_values_for_b <- tbl(conn, "table") %>%
distinct(b) %>%
collect()
output$picker_a <- renderUI({
pickerInput(
inputId = "picker_a",
label = "a:",
choices = all_values_for_a,
selected = all_values_for_a,
multiple = TRUE,
options = list("live-search" = TRUE, "actions-box" = TRUE))
})
output$picker_b <- renderUI({
pickerInput(
inputId = "picker_b",
label = "b:",
choices = all_values_for_b,
selected = all_values_for_b,
multiple = TRUE,
options = list("live-search" = TRUE, "actions-box" = TRUE))
})
#I want this code to be executed ONLY when
#picker_a is closed, not everytime when the user
#picks an item in picker_a
observeEvent(
input$picker_a,
{
all_values_for_b <- tbl(conn, "table") %>%
filter(a %in% !!input$picker_a) %>%
distinct(b) %>%
collect()
updatePickerInput(session, "picker_b", choices = all_values_for_b, selected = all_values_for_b)
})
)
)
}
You can probably use an actionButton to delay the execution of the update once all values have been picked by the user.
Or use a debounce function, see this other post.
EDIT
The update_on = c("change", "close") feature was asked for the pickerInput widget to the shinyWidgets developer (Victor Perrier) on GitHub.
Victor's answer was:
there's no similar argument for pickerInput, but there's a special input to know if menu is open or not. So you can use an intermediate reactiveValue to achieve same result.
and he provided the following code:
library(shiny)
library(shinyWidgets)
ui <- fluidPage(
fluidRow(
column(
width = 4,
pickerInput(
inputId = "ID",
label = "Select:",
choices = month.name,
multiple = TRUE
)
),
column(
width = 4,
"Immediate:",
verbatimTextOutput("value1"),
"Updated after close:",
verbatimTextOutput("value2")
),
column(
width = 4,
"Is picker open ?",
verbatimTextOutput("state")
)
)
)
server <- function(input, output) {
output$value1 <- renderPrint(input$ID)
output$value2 <- renderPrint(rv$ID_delayed)
output$state <- renderPrint(input$ID_open)
rv <- reactiveValues()
observeEvent(input$ID_open, {
if (!isTRUE(input$ID_open)) {
rv$ID_delayed <- input$ID
}
})
}
shinyApp(ui, server)
In your case you could try:
observeEvent(
input$picker_a_open,
{
if (!isTRUE(input$picker_a_open)) {
all_values_for_b <- tbl(conn, "table") %>%
filter(a %in% !!input$picker_a) %>%
distinct(b) %>%
collect()
updatePickerInput(session, "picker_b", choices = all_values_for_b, selected = all_values_for_b)
}
})
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)
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.
I am not an expert in html or JavaScript by any means. So, I hope for you assistance with this issue.
I thought I should provide a smaller version of my app in order to be able to explain the problem. Here is the app.R of a simple app that allows the user to write, let's say a word, in the textArea. The first letter of the word will appear automatically as the label of the action button, if the user clicks on the action button, the contents of the textArea will be updated stating whether the word the user wrote starts with a vowel or with a consonant.
library(shiny)
library(shinydashboard)
# Define UI for application
ui <- dashboardPage(
dashboardHeader(
title = "page_title"
),
dashboardSidebar(
),
dashboardBody(
tabBox(title = "app_title",
id = "id", width = "800px",
tabPanel("tab1)",
fluidRow(
column(width = 12,
box(
status = "info", solidHeader = TRUE,
collapsible = FALSE,
width = 12,
title = "textInput",
tags$textarea(id = "text_input1", rows = 2, cols = 50, "", autofocus = "autofocus"),
fluidRow(
column(width = 12,
actionButton("actionbutton1", label = textOutput("actionbutton1_label"))
)))))),
tabPanel("tab2"
))))
# Define server logic
server <- function(input, output, session) {
data1 <- eventReactive(input$actionbutton1, {substr(input$text_input1, 1, 1)})
output$actionbutton1_label <- renderPrint(cat(noquote({substr(input$text_input1, 1, 1)})))
observe({
if (input$actionbutton1 == 0) return()
isolate({
if (data1() %in% c("a", "e", "i", "o", "u")) {
updateTextInput(session, "text_input1",
value = paste(input$text_input1, "starts with a vowel", "", sep = " "))
}
else {
updateTextInput(session, "text_input1",
value = paste(input$text_input1, "starts with a consonant", "", sep = " "))
}
})
})}
# Run the application
shinyApp(ui = ui, server = server)
The problem definition:
When you run the above app for the first time, you will see the cursor in the textArea because the argument autofocus = "autofocus" in the textArea tag definition, so no problem with the focus on loading. When you click on the action button, the cursor is no longer in the textArea. This may seem unnecessary in the case of this simple app, but in the case of the actual app, it's important and I'd hope to have the cursor back in the textArea after the user clicks the action button.
The issue again is that whenever the user of the app clicks on the action button, the cursor disappears from the textArea and the user of the app has to click in the text area to get the cursor back and continue with his/her input. I hope to save the user this extra click by keeping the cursor always alive and focused in the textArea no matter how many times the user uses other elements of the app interface.
Research: there are many posts online relating to how to control the position of the cursor. Among these posts, I think, and please correct me if I'm wrong, that this approach is pretty much the most relevant one to what I hope to accomplish:
http://www.mediacollege.com/internet/javascript/form/focus.html
What is it specifically that I need help with:
If you click on the above link, you will find a very interesting piece of html code that I copy here:
<form name="myform2">
<input type="text" name="mytextfield2">
<input type="button" name="mybutton" value="Set Focus" OnClick="document.myform2.mytextfield2.focus();">
</form>
Here is what I hope you're able to help me with, how and where can I embed this code in my shiny ui.R? Of course, I will have to assign a form for both the textArea and the button and I will change the names of the textArea and the button accordingly. I just need to pretty much make the above html code ui.R friendly (readable and executable). Any help with this is very much appreciated.
What I tried so far and it didn't work:
tags$head(HTML("<form name="myform2">
<input type="text" name="text_input1">
<input type="button" name="addword1" value="Set Focus" OnClick="document.myform2.text_input1.focus();">
</form>"))
As you can see, the syntax is messed up and all sorts of syntax warnings were raised up when I embedded the above code in the ui.R file.
Possibly important: I am using shiny dashboard and both the textArea ad the action button are defined in a tabPanel in a tabBox in the dashboardBody.
Thanks a lot
Here is a working version like you asked:
library(shiny)
library(shinydashboard)
# Define UI for application
ui <- dashboardPage(
dashboardHeader(
title = "page_title"
),
dashboardSidebar(
),
dashboardBody(tags$head(tags$script(
'Shiny.addCustomMessageHandler("refocus",
function(NULL) {
document.getElementById("text_input1").focus();
});'
)),
tabBox(title = "app_title",
id = "id", width = "800px",
tabPanel("tab1",
fluidRow(
column(width = 12,
box(
status = "info", solidHeader = TRUE,
collapsible = FALSE,
width = 12,
title = "textInput",
tags$textarea(id = "text_input1", rows = 2, cols = 50, "", autofocus = "autofocus"),
fluidRow(
column(width = 12,
actionButton("actionbutton1", label = textOutput("actionbutton1_label"))
)))))),
tabPanel("tab2"
))))
# Define server logic
server <- function(input, output, session) {
data1 <- eventReactive(input$actionbutton1, {
substr(input$text_input1, 1, 1)
})
output$actionbutton1_label <- renderPrint(cat(noquote({substr(input$text_input1, 1, 1)})))
observeEvent(input$actionbutton1,{
isolate({
if (data1() %in% c("a", "e", "i", "o", "u")) {
updateTextInput(session, "text_input1",
value = paste(input$text_input1, "starts with a vowel", "", sep = " "))
}
else {
updateTextInput(session, "text_input1",
value = paste(input$text_input1, "starts with a consonant", "", sep = " "))
}
session$sendCustomMessage(type="refocus",message=list(NULL))
})
})}
# Run the application
shinyApp(ui = ui, server = server)
So on the UI side you'll need something like this:
tags$script('
Shiny.addCustomMessageHandler("myCallbackHandler",
function(null) {
document.myform2.text_input1.focus();
});
')
Then in the observeEvent related to the actionButton you call this function:
session$sendCustomMessage("myCallbackHandler",list(NULL))
So anytime in the server when you call that custom handler it'll focus to the input. You may need to change the javascript in the function to make your page work since I don't know the names of the objects in your HTML.
Hope this helps.