I am trying to build an app in shiny that hide / shows "pages" when a specific key is pressed to simulate an implicit association test. Participants at the beginning get instructed and then (from IAT1 on) have to press either "e" or "i" when a specific word appears and then the next word should be presented. This means that the first word should disappear and the new word appear when "e" or "i" is pressed. As I did not get very far right now after IAT 1 (word 1) not the second word is presented but the welcome page again to test the key input.
Instead of e.keyCode I also tried e.which but the key input seems not to change anything or to let elements appear / disappear and I don't know what I am doing wrong or where the problem might be.
ui <- fluidPage(
useShinyjs(),
div(
id = "welcome",
mainPanel(
fluidRow(
h3("Welcome"),
p("Welcome to the test."),
br(),
actionButton("continue1", label = "weiter")
)
)
),
hidden(
div(
id = "instruction",
mainPanel(
fluidRow(
h3("Instruction"),
p("Please ...")),
br(),
actionButton("continue2", label = "weiter"))
)
),
hidden(
div(
id = "IAT1",
mainPanel(
fluidRow(
h3("IAT"),
p("IAT word 1")),
br(),
tags$script('$(document).on("keypress", function(e) {
shiny.onInputChange("keyid1", e.keyCode);
});'))
))
)
#####server#
useShinyjs()
server <- function(input, output) {
observeEvent(input$continue1, {
show("instruction")
hide("welcome")
})
observeEvent(input$continue2, {
show("IAT1")
hide("instruction")
})
observeEvent(input$keyid1,{
if(e.keyCode == 69) {
hide("IAT1")
show("welcome")
}
else {}
})
}
shinyApp(ui = ui, server = server)
Try this, I added the keys (e,i, SHIFT+e, SHIFT+i)
library(shiny)
library(ggplot2)
ui <- fluidPage(
useShinyjs(),
div(
id = "welcome",
mainPanel(
fluidRow(
h3("Welcome"),
p("Welcome to the test."),
br(),
actionButton("continue1", label = "weiter")
)
)
),
hidden(
div(
id = "instruction",
mainPanel(
fluidRow(
h3("Instruction"),
p("Please ...")),
br(),
actionButton("continue2", label = "weiter"))
)
),
hidden(
div(
id = "IAT1",
mainPanel(
fluidRow(
h3("IAT"),
p("IAT word 1")),
br(),
tags$script('$(document).on("keypress", function(e) {
Shiny.onInputChange("keyid1", e.keyCode);
});'))
))
)
server <- function(input, output,session) {
observeEvent(input$continue1, {
show("instruction")
hide("welcome")
})
observeEvent(input$continue2, {
show("IAT1")
hide("instruction")
})
observeEvent(input$keyid1,{
print(input$keyid1)
if(input$keyid1 %in% c(101,105,69,73)) {
hide("IAT1")
show("welcome")
}
else {}
})
}
shinyApp(ui = ui, server = server)
Related
The toy app in the example below contains an R/Shiny actionGroupButtons element. I am looking for guidance please on how to start the actionGroupButtons with button ‘btn_edit’ disabled, which can then become enabled on a click of the button ‘btn_enable’.
Button ‘btn_duplicate’ should remain enabled at all times.
#DeanAttali mentions the use of the ‘disabled’ attribute here (Shiny: how to start application with action button disabled?), though I think that it is one of the inputs that it doesn’t work with.
Any ideas please? TIA
library(shiny)
library(shinyWidgets)
library(shinyjs)
ui <- fluidPage(
useShinyjs(),
fluidRow(
actionGroupButtons(
inputIds = c("btn_edit", "btn_duplicate"),
labels = list("Edit", "Duplicate")
)
),
br(),
fluidRow(
actionButton('btn_enable', 'enable edit')
),
br(),
fluidRow(
verbatimTextOutput('btns')
),
br(),
fluidRow(
verbatimTextOutput('btn_enable')
)
)
server <- function(input, output) {
observeEvent((input$btn_edit|input$btn_duplicate),{
output$btns <- renderPrint({paste(input$btn_edit, 'and', input$btn_duplicate)})
})
observeEvent(input$btn_enable,{
output$btn_enable <- renderPrint({input$btn_enable})
if(input$btn_enable > 0) {
shinyjs::enable("btn_edit")
} else {
shinyjs::disable("btn_edit")
}
}, ignoreInit = TRUE)
}
shinyApp(ui = ui, server = server)
You need to set ignoreNULL = FALSE in your observeEvent call, otherwise it will run only after btn_enable was pressed:
library(shiny)
library(shinyWidgets)
library(shinyjs)
ui <- fluidPage(
useShinyjs(),
fluidRow(
actionGroupButtons(
inputIds = c("btn_edit", "btn_duplicate"),
labels = list("Edit", "Duplicate")
)
),
br(),
fluidRow(
actionButton('btn_enable', 'enable edit')
),
br(),
fluidRow(
verbatimTextOutput('btns')
),
br(),
fluidRow(
verbatimTextOutput('btn_enable')
)
)
server <- function(input, output, session) {
observeEvent((input$btn_edit|input$btn_duplicate),{
output$btns <- renderPrint({paste(input$btn_edit, 'and', input$btn_duplicate)})
})
observeEvent(input$btn_enable, {
output$btn_enable <- renderPrint({input$btn_enable})
if(input$btn_enable > 0) {
shinyjs::enable("btn_edit")
} else {
shinyjs::disable("btn_edit")
}
}, ignoreInit = FALSE, ignoreNULL = FALSE)
}
shinyApp(ui = ui, server = server)
Another approach would be to disable the button outside of the observer:
library(shiny)
library(shinyWidgets)
library(shinyjs)
ui <- fluidPage(
useShinyjs(),
fluidRow(
actionGroupButtons(
inputIds = c("btn_edit", "btn_duplicate"),
labels = list("Edit", "Duplicate")
)
),
br(),
fluidRow(
actionButton('btn_enable', 'enable edit')
),
br(),
fluidRow(
verbatimTextOutput('btns')
),
br(),
fluidRow(
verbatimTextOutput('btn_enable')
)
)
server <- function(input, output, session) {
shinyjs::disable("btn_edit")
observeEvent((input$btn_edit|input$btn_duplicate),{
output$btns <- renderPrint({paste(input$btn_edit, 'and', input$btn_duplicate)})
})
observeEvent(input$btn_enable, {
output$btn_enable <- renderPrint({input$btn_enable})
shinyjs::enable("btn_edit")
})
}
shinyApp(ui = ui, server = server)
In the below example code, I'd like each click of the "Add" button to add 1 to the value presented in the little "data" table underneath. Instead of the "Add" button, the code below has the "Test add" button working this way for demo purpose. I'd like to have "Add" do what "Test add" currently does, and then remove "Test add".
The "Show table" button works as it should: each click renders a larger table (unrelated, this is all a simple example) underneath. And the "Add" button works correctly in hiding the rendered larger table each time it is clicked; but I'd also like a click of "Add" to add 1 as described above.
In the below code I commented out observeEvent("input.show == 'Add'",{x(x()+1)}), which was my attempt to have a click of "Add" cause the addition of 1. How do I correct this, so the observeEvent() is essentially triggered by input.show == 'Add'?
This image helps explain:
Code:
library(shiny)
library(shinyWidgets)
ui <- fluidPage(
br(),actionButton("add","Test add"), br(),br(),
radioGroupButtons(
inputId = "show",
label = NULL,
choices = c("Add","Show table"),
status = "primary",
selected = "Add"
),
br(),
fluidRow(tableOutput("data")),
fluidRow(
conditionalPanel(
"input.show == 'Show table'",
column(10,
column(4, h5(textOutput("text"))),
column(6, tableOutput("table")),
style = "border: 2px solid grey; margin-left: 15px;"
),
style = "display: none;"
)
)
)
server <- function(input, output, session) {
x = reactiveVal(0)
output$data <- renderTable(x())
output$table <- renderTable(iris[1:5, 1:3])
output$text <- renderText("Test show/hide in JS")
observeEvent(input$add,{x(x()+1)})
# observeEvent("input.show == 'Add'",{x(x()+1)})
}
shinyApp(ui, server)
One can easily watch show to create make the value increase by 1 every other time the "add" in show is clicked.
observeEvent(input$show, {
req(input$show == "Add")
x(x()+1)
})
The problem is that you have to click Show table once and then click Add, then the value will increase. If you continuously click Add, the value will only increase one time. To solve the problem, we can bind a new JS event to the Add button and send the value to R.
library(shiny)
library(shinyWidgets)
ui <- fluidPage(
br(), br(), br(), br(),
radioGroupButtons(
inputId = "show",
label = NULL,
choices = c("Add","Show table"),
status = "primary",
selected = "Add"
),
tags$script(HTML(
"
$(()=>{
var clicks = 0;
$('#show button').first().on('click', ()=> {
clicks ++;
Shiny.setInputValue('add_button', clicks);
});
})
"
)),
br(),
fluidRow(tableOutput("data")),
fluidRow(
conditionalPanel(
"input.show == 'Show table'",
column(10,
column(4, h5(textOutput("text"))),
column(6, tableOutput("table")),
style = "border: 2px solid grey; margin-left: 15px;"
),
style = "display: none;"
)
)
)
server <- function(input, output, session) {
x <- reactiveVal(0)
output$data <- renderTable(x())
output$table <- renderTable(iris[1:5, 1:3])
output$text <- renderText("Test show/hide in JS")
observeEvent(input$add_button, {
x(input$add_button)
})
}
shinyApp(ui, server)
Alternative
If this value is only used to display how many times the button is clicked, or if you care about the performance, we can handle this job purely in JS, meaning no server interaction is required. If you have a great number of users, the following will help to decrease your server burden.
library(shiny)
library(shinyWidgets)
ui <- fluidPage(
br(), br(), br(), br(),
radioGroupButtons(
inputId = "show",
label = NULL,
choices = c("Add","Show table"),
status = "primary",
selected = "Add"
),
tags$script(HTML(
"
$(()=>{
var clicks = 0;
$('#show button').first().on('click', ()=> {
clicks ++;
$('#data td').text(` ${clicks} `);
});
})
"
)),
br(),
fluidRow(tableOutput("data")),
fluidRow(
conditionalPanel(
"input.show == 'Show table'",
column(10,
column(4, h5(textOutput("text"))),
column(6, tableOutput("table")),
style = "border: 2px solid grey; margin-left: 15px;"
),
style = "display: none;"
)
)
)
server <- function(input, output, session) {
output$data <- renderTable(0)
output$table <- renderTable(iris[1:5, 1:3])
output$text <- renderText("Test show/hide in JS")
}
shinyApp(ui, server)
I have a shiny application in which a dataTable is displayed when the user selects Sector A from the radioButtons menu in the sidebar. The problem is that it is displayed twice. I checked it in browser mode too. Why does this happen I display the whole app here since it may be caused by the if logic of the app. renderTable() works fine so I guess there is an issue with DT
#ui.r
library(shiny)
library(shinythemes)
library(DT)
ui <- fluidPage(
theme=shinytheme("slate") ,
# App title ----
titlePanel("Tabsets"),
# Sidebar layout with input and output definitions ----
sidebarLayout(
# Sidebar panel for inputs ----
sidebarPanel(
uiOutput("rad")
),
# Main panel for displaying outputs ----
mainPanel(
uiOutput("tabers"),
DT::dataTableOutput("table")
)
)
)
#server.r
library(shiny)
library(DT)
server = function(input, output) {
output$rad<-renderUI({
radioButtons("radio", label = "",
choices = list("Home"=1,"About" = 2, "Sector A" = 3, "Sector B" = 4,"Sector C" = 5),
selected = 1)
#selected = character(0))
})
output$tabers<-renderUI({
if(is.null(input$radio)) {
tabsetPanel(
id="tabF",
type = "tabs",
tabPanel("Global"),
tabPanel("Performance")
)
}
else if(input$radio==3){
tabsetPanel(
id="tabC",
type = "tabs",
tabPanel("Constituents",
output$table <- renderDataTable({
mtcars
})
),
tabPanel("Clusters" ),
tabPanel("Index")
)
}
else if(input$radio==4){
tabsetPanel(
id="tabD",
type = "tabs",
tabPanel("Constituents"
),
tabPanel("Clusters" ),
tabPanel("Index")
)
}
else if(input$radio==5){
tabsetPanel(
id="tabE",
type = "tabs",
tabPanel("Constituents"
),
tabPanel("Clusters" ),
tabPanel("Index")
)
}
else if(input$radio==2){
}
# Left last else in here but should not get called as is
else if(input$radio==1){
tabsetPanel(
id="tabA",
type = "tabs",
tabPanel("Global"),
tabPanel("Performance" )
)
}
})
}
It looks like renderTable does the same thing. For some reason, the output of renderDataTable({mtcars}) gets displayed twice, first through uiOutput, second through dataTableOutput() (both are in mainPanel). Commenting the line dataTableOutput("table") fixes the behavior in that it shows the table only once. Interestingly, removing the assignment like so:
else if(input$radio==3){
tabsetPanel(
id="tabC",
type = "tabs",
tabPanel("Constituents",
renderDataTable({
mtcars
})
),
tabPanel("Clusters" ),
tabPanel("Index")
)
}
also renders the table once. So it looks like when inside renderUI, renderDataTable just creates the output without requiring a dataTableOutput in the UI.
This seems to allow (for better or worse) to easily render different tables in different tabs without corresponding output entries in the UI.
else if(input$radio==3){
tabsetPanel(
id="tabC",
type = "tabs",
tabPanel("Constituents",
renderDataTable({
mtcars
})
),
tabPanel("Clusters" ),
tabPanel("Index")
)
}
else if(input$radio==4){
tabsetPanel(
id="tabD",
type = "tabs",
tabPanel("Constituents",
renderDataTable({
iris
})
),
tabPanel("Clusters" ),
tabPanel("Index")
)
}
I am trying to build an app where the user is able to switch tabs when clicking on a specific object. However, I have developed the app using modules and would like to continue to do so. I am running into a problem with the scoping when trying to call the updateNavbarPage() function from inside of the modules. I have created a MWE example to illustrate the problem.
#==================================================
# MRE for updateNavBar scoping issue within modules
#==================================================
modOneUI <- function(id){
ns <- NS(id)
tagList(
h4(
"Click this button to change tabs!"
),
actionButton(
ns("submit"),
label = "Go to next Tab"
)
)
}
modOne <- function(input, output, session){
observeEvent(input$submit, {
updateNavbarPage(session, "nav-page", "tab2")
})
}
ui <- shinyUI(
navbarPage(
id = "nav-page",
title = "Example Navbar Page Issue",
tabPanel(
id = "tab1",
value = "tab1",
div(
"Tab 1"
),
div(
modOneUI("tab1_mod")
)
),
tabPanel(
id = "tab2",
value = "tab2",
div(
"Tab 2"
),
div(
h4("This is the second tab")
)
)
)
)
server <- shinyServer(function(input, output, session){
callModule(modOne, "tab1_mod")
})
shinyApp(ui = ui, server = server)
When this app is run, and the action button is clicked on the first tab, nothing happens. However if you remove the module and place the ui and server module code directly into the ui and server portions then clicking the button works. Here is the code with the modules removed.
ui <- shinyUI(
navbarPage(
id = "nav-page",
title = "Example Navbar Page Issue",
tabPanel(
id = "tab1",
value = "tab1",
div(
"Tab 1"
),
div(
h4(
"Click this button to change tabs!"
),
actionButton(
"submit",
label = "Go to next Tab"
)
)
),
tabPanel(
id = "tab2",
value = "tab2",
div(
"Tab 2"
),
div(
h4("This is the second tab")
)
)
)
)
server <- shinyServer(function(input, output, session){
observeEvent(input$submit, {
updateNavbarPage(session, "nav-page", "tab2")
})
})
shinyApp(ui = ui, server = server)
Is there any way to use updateNavbarPage() from within a module to switch to a tab that is in not in the module?
Do not ask me why :-) but it works like this:
modOne <- function(input, output, session, x){
observeEvent(input$submit, {
updateNavbarPage(x, "nav-page", "tab2")
})
}
callModule(modOne, "tab1_mod", x=session)
I need to change the value of an input every time that the user changes the page of a dataset pagination.
I've tried to use the observeEvent, but it doesn't work.
UI
fluidRow(
column(10,
""
),
column(2,
textInput("inText", "Input text 2", value = "Default text")
),
column(12,
dataTableOutput('table')
)
)
Server
observeEvent(input$table, {
updateTextInput(session, "inText", value = paste("New text",0))
})
Hope you can help me.
Assuming your table id is table as given in your example, you can use:
input$table_state$start / input$table_state$length + 1.
In the following a complete example:
library(DT)
library(shiny)
app <- shinyApp(
ui = fluidPage(
tags$head(
# hides the default search functionality
tags$style(
HTML(".dataTables_filter, .dataTables_info { display: none; }")
)
),
fluidRow(
column(10,
""
),
column(2,
# adding new page filter
uiOutput("pageFilter")
),
column(12,
dataTableOutput('table')
)
)
),
server = function(input, output) {
output$pageFilter <- renderUI({
val <- input$table_state$start / input$table_state$length + 1
numericInput("page", "Page", val, min = 1)
})
output$table <- DT::renderDataTable({
iris
}, options = list(pageLength = 5, stateSave = TRUE))
# using new page filter
observeEvent(input$page, {
dataTableProxy("table") %>% selectPage(input$page)
})
}
)
runApp(app, launch.browser = TRUE)