I have a functional shiny app that uses the shinydashboard package.
A new feature requires user-specific behavior (e.g. use different data sets for different usernames). Therefore I intend to
Display a login form
Validate credentials and set a reactive value LoggedIn to true if successful
Display the actual dashboardPage as soon as LoggedIn is set to TRUE
My approach is based on this app, which decides which element to display in renderUI based on the reactive value.
The following simplified examples are supposed to change the displayed UI element after clicking an actionButton. The only difference between the source is that example 1 (working as intended) uses a fixedPage, whereas example 2 (not working - clicking the button does not switch to ui2) uses a dashboardPage.
Working example
library(shiny)
ui1 <- fixedPage(actionButton("btn_login", "Login"))
ui2 <- fixedPage(sliderInput("slider", "slider", 3, 2, 2))
ui <- uiOutput("ui")
server <- function(input, output, session) {
state <- reactiveValues(LoggedIn = FALSE)
output$ui <- renderUI({if (!state$LoggedIn) ui1 else ui2})
observeEvent(input$btn_login, {
state$LoggedIn = TRUE
})
}
shinyApp(ui, server)
Malfunctioning example
library(shiny)
library(shinydashboard)
ui1 <- fixedPage(actionButton("btn_login", "Login"))
ui2 <- dashboardPage(dashboardHeader(), dashboardSidebar(), dashboardBody())
ui <- uiOutput("ui")
server <- function(input, output, session) {
state <- reactiveValues(LoggedIn = FALSE)
output$ui <- renderUI({if (!state$LoggedIn) ui1 else ui2})
observeEvent(input$btn_login, {
state$LoggedIn = TRUE
})
}
shinyApp(ui, server)
Is this due to peculiarities of the shinydashboard package?
Has anybody had a similar problem (besides this user) and found a solution?
Thanks in advance for any help!
EDIT
#SeGa This rather useless app renders the dashboardPage after the reactiveTimer has triggered twice - Maybe there is a possibility to get it working without the timer?
library(shiny)
library(shinydashboard)
ui1 <- fixedPage(actionButton("btn_login", "Login"))
ui2 <- dashboardPage(dashboardHeader(), dashboardSidebar(), dashboardBody())
ui <- uiOutput("ui")
server <- function(input, output, session) {
state <- reactiveValues(LoggedIn = FALSE)
timer <- reactiveTimer(1000, session)
output$ui <- renderUI({if (!state$LoggedIn) ui1 else ui2})
observeEvent(timer(), {
state$LoggedIn = !state$LoggedIn
})
}
shinyApp(ui, server)
EDIT May 29
#Bertil Baron
Is it something like that you mean?
loginUI <- fixedPage(actionButton("btn_login", "Login"))
mainUI <- # See below
ui <- loginUI
server <- function(input, output, session) {
observeEvent(input$btn_login, {
removeUI(selector = "body")
insertUI(selector = "head", where = "afterEnd", mainUI)
})
}
shinyApp(ui, server)
Now this works if mainUI is one of basicPage, bootstrapPage, fillPage, fixedPage, fluidPage, navbarPage - a new body tag is inserted and visible in the DOM, but there is no effect for a bootstrapPage.
In case you meant to initially display the login form in the dashboardBody and replacing it with the actual content after a successful login - that is what I wanted to avoid.
It also works with invalidateLater(), but also only temporary.
library(shiny)
library(shinydashboard)
ui <- uiOutput("ui")
server <- function(input, output, session) {
state <- reactiveValues(LoggedIn = FALSE)
observeEvent(input$btn_login, {
state$LoggedIn = !state$LoggedIn
})
ui1 <- reactive({
fixedPage(actionButton("btn_login", "Login"))
})
ui2 <- reactive({
ui2 <- dashboardPage(dashboardHeader(), dashboardSidebar(), dashboardBody(
sliderInput("slider", "slider", min = 1, max = 10, value = 2)
))
invalidateLater(100, session)
ui2
})
output$ui <- renderUI({if (!state$LoggedIn) ui1() else ui2()})
}
shinyApp(ui, server)
Not sure this is the kind of solution you are after, but here's my attempt using shinyjs and some CSS. It seems hard to switch from a fixedPage to a dashboardPage, so if you really want to use shinydashboard, I would stick with shinydashboard and disable the dashboard look on the login page.
library(shiny)
library(shinyjs)
library(shinydashboard)
ui1 <- div(
id = "login-page",
actionButton("btn_login", "Login")
)
ui2 <- hidden(
div(
id = "main-page",
sliderInput("slider", "slider", 3, 2, 2)
)
)
ui <- dashboardPage(dashboardHeader(),
dashboardSidebar(collapsed = TRUE),
dashboardBody(useShinyjs(),
tags$head(
tags$style(
HTML('.main-header {
display: none;
}
.header-visible {
display: inherit;
}')
)
),
fluidPage(ui1, ui2)
)
)
server <- function(input, output, session) {
state <- reactiveValues(LoggedIn = FALSE)
observeEvent(input$btn_login, {
state$LoggedIn = TRUE
shinyjs::addClass(selector = "header", class = "header-visible")
shinyjs::removeClass(selector = "body", class = "sidebar-collapse")
shinyjs::hide(id = "login-page")
shinyjs::show(id = "main-page")
})
}
shinyApp(ui, server)
If you want to be able to come back to the login page, you can always add a login button that shows the login page, and hides the appropriate elements (sidebar/header/current page).
Related
I am using below code and try to do below action.
Click on action button to go to next table. How can I do this?
library(shiny)
library(shinydashboard)
library(ggplot2)
ui <- fluidPage(
fluidRow(box(
actionButton("btn1", "Go to Next Table"),
tableOutput("tbl1")
)),
fluidRow(box(
tableOutput("tbl2")
))
)
server <- function(input, output, session) {
output$tbl1 <- renderTable(mtcars)
output$tbl2 <- renderTable(mpg)
}
shinyApp(ui, server)
Here's one solution:
library(shiny)
library(shinydashboard)
library(ggplot2)
ui <- fluidPage(
fluidRow(box(
actionButton("btn1", "Go to Next Table",
onclick = "location.href='#table2';"),
tableOutput("tbl1")
)),
fluidRow(id = "table2", box(
tableOutput("tbl2")
))
)
server <- function(input, output, session) {
output$tbl1 <- renderTable(mtcars)
output$tbl2 <- renderTable(mpg)
}
shinyApp(ui, server)
I've added a unique ID to the location in the UI - here the 2nd fluidRow, then added an onclick javascript function to the actionButton also in the UI. No server function means all the work is done by the user's browser which is handy sometimes.
You can add infinite complexity to the Javascript here to customise it to fit your needs.
I'd like to have an actionButton that cycles its class between "btn-success", "btn-warning", "btn-danger" based on the button click. Unfortunately I can't seem to figure out how to get that value into the class argument of the actionButton.
library(shiny)
v <- reactiveValues(btn_status = "btn-secondary")
ui <- fluidPage(
# Application title
titlePanel("Change Button Color on click"),
# Create an action button that cycles through 3 bootstrap colors and can be reset
mainPanel(
actionButton("run","L", class = isolate(v$btn_status)),
actionButton("reset", "Clear"),
textOutput("status"),
)
)
server <- function(input, output) {
observeEvent(input$run, {
v$btn_status <- "btn-success"
})
observeEvent(input$reset, {
v$btn_status <- "NULL"
})
output$status <- renderText({
v$btn_status
})
}
shinyApp(ui = ui, server = server)
It's not entirely clear to me what you're trying to do (see my comment above); but I think you're after something like this:
library(shiny)
valid_status <- c("btn-success", "btn-warning", "btn-danger")
ui <- fluidPage(
titlePanel("Change Button Color on click"),
mainPanel(
uiOutput("statusButton"),
actionButton("reset", "Clear"),
textOutput("status"),
)
)
server <- function(input, output, session) {
v <- reactiveValues(button_idx = 1)
get_button_idx <- reactive(v$button_idx)
output$statusButton <- renderUI({
idx <- get_button_idx()
actionButton("run", "L", class = valid_status[idx])
})
observeEvent(input$run, {
v$button_idx <- ifelse(v$button_idx < 3, v$button_idx + 1, 1)
})
observeEvent(input$reset, {
v$button_idx <- 1
})
output$status <- renderText({
valid_status[v$button_idx]
})
}
shinyApp(ui = ui, server = server)
producing
The key is to use a reactive value within renderUI to update the class of the actionButton. To align the buttons you could use fluidRow if necessary.
I am trying to render a few outputs in a shiny application that are contained within a shinyjs::hidden section upon the application running rather than once the section is visible.
EDIT: I had the app set up incorrectly in the original example so have changed it.
I want to be able to run the reactive statement before running the final observe to change the UI from the Alpha text to the Beta text and plot. Ideally this would mean in the console would see "Done plotting" before "Observe run".
library(shiny)
library(shinyjs)
ui <- fluidPage(
useShinyjs(),
div(id = "before-content", h3("Aux Text Alpha")),
shinyjs::hidden(
div(
id = "after-content",
h1("Aux Text Beta"),
plotOutput("text")
)
)
)
server <- function( session,input, output) {
in_plot <- reactive({
Sys.sleep(3)
print("Done plotting")
plot(iris)
})
output$text <- renderPlot({
in_plot()
})
observe({
print("Observe run")
hide("before-content")
show("after-content")
})
}
shinyApp(ui, server)
An alternative would be to have a layer over what is classed as the hidden section but am not too sure on how that is accomplished.
You can hide it in the reactive, like so:
library(shiny)
library(shinyjs)
ui <- fluidPage(
useShinyjs(),
actionButton("button", "Click me"),
plotOutput("text")
)
server <- function( session,input, output) {
in_plot <- reactive({
hide("text")
Sys.sleep(3)
print("Done plotting")
plot(iris)
})
output$text <- renderPlot({
in_plot()
})
observeEvent(input$button, {
show("text")
})
}
shinyApp(ui, server)
I'm developing an app in which I use modules to display different tab's ui content. However it seems like the module does not communicate with the main (or parent) app. It displays the proper ui but is not able to execute the observeEvent function when an actionButton is clicked, it should update the current tab and display the second one.
In my code I have created a namespace function and wrapped the actionButton's id in ns(), however it still does not work. Does anyone knows what's wrong?
library(shiny)
moduleUI <- function(id){
ns <- NS(id)
sidebarPanel(
actionButton(ns("action1"), label = "click")
)
}
module <- function(input, output, session){
observeEvent(input$action1, {
updateTabItems(session, "tabsPanel", "two")
})
}
ui <- fluidPage(
navlistPanel(id = "tabsPanel",
tabPanel("one",moduleUI("first")),
tabPanel("two",moduleUI("second"))
))
server <- function(input, output, session){
callModule(module,"first")
callModule(module,"second")
}
shinyApp(ui = ui, server = server)
The observeEvent works, but since modules only see and know the variables given to them as input parameters, it does not know the tabsetPanel specified and thus cannot update it. This problem can be solved using a reactive Value, which is passed as parameter and which is changed inside the module. Once it's changed, it is known to the main app and can update the tabsetPanel:
library(shiny)
library(shinydashboard)
moduleUI <- function(id){
ns <- NS(id)
sidebarPanel(
actionButton(ns("action1"), label = "click")
)
}
module <- function(input, output, session, tabsPanel, openTab){
observeEvent(input$action1, {
if(tabsPanel() == "one"){ # input$tabsPanel == "one"
openTab("two")
}else{ # input$tabsPanel == "two"
openTab("one")
}
})
return(openTab)
}
ui <- fluidPage(
h2("Currently open Tab:"),
verbatimTextOutput("opentab"),
navlistPanel(id = "tabsPanel",
tabPanel("one", moduleUI("first")),
tabPanel("two", moduleUI("second"))
))
server <- function(input, output, session){
openTab <- reactiveVal()
observe({ openTab(input$tabsPanel) }) # always write the currently open tab into openTab()
# print the currently open tab
output$opentab <- renderPrint({
openTab()
})
openTab <- callModule(module,"first", reactive({ input$tabsPanel }), openTab)
openTab <- callModule(module,"second", reactive({ input$tabsPanel }), openTab)
observeEvent(openTab(), {
updateTabItems(session, "tabsPanel", openTab())
})
}
shinyApp(ui = ui, server = server)
I want to use a rating Input in conjunction with the shinyjs::reset()function. Everthing works fine except the reset functionality. Any hints?
Here is my minimal example:
library(shiny)
devtools::install_github("stefanwilhelm/ShinyRatingInput")
library(ShinyRatingInput)
library(shinyjs)
ui <- shinyUI(bootstrapPage(
useShinyjs(),
ratingInput("movieRating", label="Rate this movie...", dataStop=5),
htmlOutput("movieRatingout"),
actionButton("resetbtn", "reset")
))
#the corresponding server.R
server <- shinyServer(function(input, output, session) {
output$movieRatingout <- renderText({
paste("The movie was rated ",input$movieRating)
})
observeEvent(input$resetbtn, {
reset("movieRating")
})
})
shinyApp(ui, server)
You can create reset action manualy
1) Add js to reset icons ( set width of foreground ==0)
jsCode <-"shinyjs.reset_1 = function(params){$('.rating-symbol-foreground').css('width', params);}"
2) add this js to app using extendShinyjs
3) add session$sendInputMessage to reset input ( set value == NULL)
Working example
jsCode <-"shinyjs.reset_1 = function(params){$('.rating-symbol-foreground').css('width', params);}"
ui <- shinyUI(bootstrapPage(
useShinyjs(),
extendShinyjs(text = jsCode),
ratingInput("movieRating", label="Rate this movie...", dataStop=5),
htmlOutput("movieRatingout"),
actionButton("resetbtn", "reset")
))
#the corresponding server.R
server <- shinyServer(function(input, output, session) {
output$movieRatingout <- renderText({
paste("The movie was rated ",input$movieRating)
})
observeEvent(input$resetbtn, {
session$sendInputMessage("movieRating", list(value = NULL))
js$reset_1(0)
})
})