Run only relevant observe functions for each tab in shinyapp - r

In my shiny app I have several tabs as follows.
I have little complex functions running in this app. I think all the observe functions in the server function run when anything is done in any tab. So I need to run only relevant observe functions for relevant tab. As an example, when I am in Summary tab only the relevant observe function should run and all the other observe functions should not run. I have a code.
server <- function(input, output) {
summary <- observe({....})
occupancy<- observe({....})
Bookings<- observe({....})
Maps<- observe({....})
}
Is there any modification to the above code to run only the relevant observe function related to the tab opened in the app.?

Some approaches come to mind. But first; what do you want to do in your observers? If you are simply creating output to display to the user, don't forget to use reactive elements. They will automatically invalidate only when their output is used to display something to the user. Thus if reactive X uses input Y used to construct output for tab A, and input Y changes while we are looking at tab B, reactive X will not invalidate.
If you are using your observers to only create side-effects, such as updating inputs or showing modalDialogs, you could:
use observeEvent instead of observe to only listen to changes in a certain input or condition.
use isolate to make isolate certain dependencies.
build an if-statement in your observer, that checks which tab is selected. You can do that by giving your sidebarMenu an id (my_sidebarmenu in the example below), and check which tab is selected inside your observer by calling input$my_sidebarmenu.
Some examples given below, how this helps~
#UI.R
#loading shiny library
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
sidebarMenu(id='my_sidebarmenu',
menuItem('Tab 1', tabName='tab1'),
menuItem('Tab 2', tabName='tab2'),
actionButton(inputId = 'btn','Press me!')
)
),
dashboardBody(
tabItems(
tabItem('tab1',
p('Tab 1'),
actionButton('btn_tab1','Show message!')),
tabItem('tab2',
p('Tab 2'),
actionButton('btn_tab2','Show message!'))
)
)
)
server <- function(input, output,session)
{
observeEvent(input$btn,
{
if(input$my_sidebarmenu=='tab1')
{
updateTabItems(session,'my_sidebarmenu',selected='tab2')
}
if(input$my_sidebarmenu=='tab2')
{
updateTabItems(session,'my_sidebarmenu',selected='tab1')
}
})
observeEvent(input$btn_tab1,
{
showModal(modalDialog(
title = "One.",
"You are viewing tab 1!",
easyClose = TRUE,
footer = NULL
))
})
observeEvent(input$btn_tab2,
{
showModal(modalDialog(
title = "Two.",
"You are viewing tab 2!",
easyClose = TRUE,
footer = NULL
))
})
}
shinyApp(ui,server)

Related

if-statement in Shiny UI: evaluate simple numeric condition calculated in server

In my way to learning Shiny rudiments, I do want to build a simple application that presents a ui with boxes with different background colours based on the value of a variable calculated in server.
I'm trying to use a classical if-statement, being n_add_due_all in server:
fluidRow(
if(n_add_due_all > 0)
{box(title = "to add", background = "red")}
else
{box(title = "to add", background = "green")}
)
I've being trying to use renderUI -> uiOutput and renderPrint -> textOutput server/ui pairs, but I'm not able to get a numeric value suitable for the n_add_due_all > 0 evaluation.
Please, is it doable? Is there any way of simply passing a numeric value from server to ui?
I found numerous related question and answers, but all of them seam much complex user-cases where some kind of interaction with user by selecting or entering values is required. In this case, the variable is completely calculated in server and should only be recalculated upon a page reload.
Thanks for your help!
Are you looking for this?
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
header = dashboardHeader(),
sidebar = dashboardSidebar(),
body = dashboardBody(uiOutput("box"))
)
server <- function(input, output, session) {
n_add_due_all <- -1
output$box <- renderUI({
fluidRow(
if (n_add_due_all > 0) {
shinydashboard::box(title = "to add", background = "red")
} else {
shinydashboard::box(title = "to add", background = "green")
}
)
})
}
shinyApp(ui, server)

hideTab doesn't work when tabsetPanel and hideTab are inside an observer in R shiny

I'm traying to create an app that reads some user and password and then create a tabsetPanel inside a renderUI.
The app is supposed to read a code and type number from a data base and if the type is 1 then hides some tabPanel, however all the tabpanels are always shown.
library(shiny)
library(RPostgreSQL)
con=dbConnect(........)
ui <- fluidPage(
textInput("user","User:"),
passwordInput("password", "Password:"),
actionButton("go", "Go",class = "btn-primary"),
uiOutput("panel")
)
server <- function(input, output, session) {
observeEvent({input$go}, {
code<-dbGetQuery(con,"SELECT type FROM table")[[1]]
#code is a number
if(dim(code)[1]==1){
type=reactive(dbGetQuery(con,"SELECT type FROM table2")[[1]])
#type() is a number
output$panel=renderUI(
tabsetPanel(id = "tab",
tabPanel("Tab1"),
tabPanel("Tab2")
)
)
observe({
if(type()==1){
hideTab(inputId = "tab", target = "Tab1")
}
})
}
})
}
shinyApp(ui, server)
The problem is that de observer is executed before the renderUI and doesn't re-execute, I think.
Generally speaking, you've mixed up 3 different processes.
Checking the user has access can be put in a separate function, outside of the scope of server, simply returning TRUE or FALSE (and possibly an error).
Dynamically loading the tabs. If this must only occur after the user has logged in, you can simply opt to not display Tab1. If the tabs has to be loaded regardless (but still dynamically), put it outside of the scope of observeEvent({input$go}, {...}). Consider, just for now, to setup the tabsetpanel with tabs in the ui.
Showing/hiding the tab.
Within a reactive/observe, you do not need to use additional reactives. They already are set to run. So type should be just be type = dbGetQuery(...), and the observe nested within an observe/observeEvent makes no sense.
Lastly, to debug why the tab is not hidden, use the good ol' fashioned print and look at your console. Try updating to
observe({
cat('Testing type: ', type(), '\n')
if(type()==1){
cat('Hiding tab...\n')
hideTab(inputId = "tab", target = "Tab1")
}
})
and watch out for those messages in your console. Are they printed? Then the fault might be on the client-side (perhaps you mispelled something). Are the messages missing? Then you know the code never executed, and you'll have to investigate why.
Update:
Looking further into the matters, try using the browsers Inspect-function. For the viewer in Rstudio (and Chrome), you can right-click and select "Inspect element". A new window appears (or is docked within the window), which allows you to inspect the HTML DOM and view the JavaScript console. Here, we notice an important message:
Uncaught There is no tabsetPanel (or navbarPage or navlistPanel) with id equal to 'tab'
Simply put, the hideTab command is sent before the client has finished loading the tabpanels.
One solution, that did not work, is as follows:
server <- function(input, output, session) {
type <- reactiveVal(0)
type_delayed <- debounce(type, Inf)
observeEvent({input$go}, {
code<-data.frame(code=1)
#code is a number
if(dim(code)[1]==1){
#type(dbGetQuery(con,"SELECT type FROM table2")[[1]])
type(1)
#type() is a number
output$panel=renderUI(
tabsetPanel(id = "tab",
tabPanel("Tab1"),
tabPanel("Tab2")
)
)
}
})
observe({
cat('Testing type: ', type_delayed(), '\n')
if( type_delayed() ==1){
cat('Hiding tab...\n')
hideTab(inputId = "tab", target = "Tab1")
}
})
}
I.e., we delay the execution of hiding the tab. Except it's a bad solution, because you have to choose a timing that is as soon as possible, but not so soon that the client isn't ready.
I suggest the following solution: Instead of hiding the panel, don't add it until you need it:
ui <- fluidPage(
textInput("user","User:"),
passwordInput("password", "Password:"),
actionButton("go", "Go",class = "btn-primary"),
actionButton("add", "Add tab"),
uiOutput("panel")
)
server <- function(input, output, session) {
i <- 1
observeEvent({input$go}, {
code<-data.frame(code=1)
#code is a number
if(dim(code)[1]==1){
#type <- dbGetQuery(con,"SELECT type FROM table2")[[1]]
type <- 1
#type() is a number
output$panel=renderUI({
if (type == 1) {
i <<- 1
tabsetPanel(
id = "tab",
tabPanel("Tab1")
)
} else {
i <<- 2
tabsetPanel(
id = "tab",
tabPanel("Tab1"),tabPanel("Tab2")
)
}
})
}
})
observeEvent(input$add, {
i <<- i + 1
appendTab('tab', tabPanel(paste0('Tab', i)))
})
}

Shiny initial textAreaInput value and reactive after each button press

Description
I have a textAreaInput box that I want to start with a default value. The user can click 2 actionButtons (Submit & Random Comment). Submit updates the comment from the textAreaInput for further processing (plot, etc.) while Random Comment sends a new random value to textAreaInput (the user may type in the textAreaInput box as well). I almost have it but can't get the app to update textAreaInput's value until the Submit button is pressed.
Question
I want it to be updated when Random Comment is pressed but still allow the user to erase the text box and type their own text. How can I make the app do this?
MWE
library(shiny)
library(shinyjs)
library(stringi)
shinyApp(
ui = fluidPage(
column(2,
uiOutput("randcomment"),
br(),
div(
actionButton("randtext", "Random Comment", icon = icon("quote-right")),
div(actionButton("submit", "Submit", icon = icon("refresh")), style="float:right")
)
),
column(4, div(verbatimTextOutput("commenttext"), style = 'margin-top: 2cm;'))
),
server = function(input, output) {
output$randcomment <- renderUI({
commentUi()
})
comment_value <- reactiveValues(default = 0)
observeEvent(input$submit,{
comment_value$default <- input$randtext
})
renderText(input$randtext)
commentUi <- reactive({
if (comment_value$default == 0) {
com <- stri_rand_lipsum(1)
} else {
com <- stri_rand_lipsum(1)
}
textAreaInput("comment", label = h3("Enter Course Comment"),
value = com, height = '300px', width = '300px')
})
output$commenttext <- renderText({ input$comment })
}
)
I'd approach this a little bit differently. I would use reactiveValues to populate both of the fields, and then use two observeEvents to control the contents of the reactiveValues.
I don't think you need a reactive at all in this situation. reactive is good when you want immediate processing. If you want to maintain control over when the value is processed, use reactiveValues.
library(shiny)
library(shinyjs)
library(stringi)
shinyApp(
ui = fluidPage(
column(2,
uiOutput("randcomment"),
br(),
div(
actionButton("randtext", "Random Comment", icon = icon("quote-right")),
div(actionButton("submit", "Submit", icon = icon("refresh")), style="float:right")
)
),
column(4, div(verbatimTextOutput("commenttext"), style = 'margin-top: 2cm;'))
),
server = function(input, output) {
# Reactive lists -------------------------------------------------------
# setting the initial value of each to the same value.
initial_string <- stri_rand_lipsum(1)
comment_value <- reactiveValues(comment = initial_string,
submit = initial_string)
# Event observers ----------------------------------------------------
observeEvent(input$randtext,
{
comment_value$comment <- stri_rand_lipsum(1)
}
)
# This prevents the comment_value$submit from changing until the
# Submit button is clicked. It changes to the value of the input
# box, which is updated to a random value when the Random Comment
# button is clicked.
observeEvent(input$submit,
{
comment_value$submit <- input$comment
}
)
# Output Components -------------------------------------------------
# Generate the textAreaInput
output$randcomment <- renderUI({
textAreaInput("comment",
label = h3("Enter Course Comment"),
value = comment_value$comment,
height = '300px',
width = '300px')
})
# Generate the submitted text display
output$commenttext <-
renderText({
comment_value$submit
})
}
)
Some comments on your code
I struggled a little with determining what your code was doing. Part of the reason was that your server function was organized a bit chaotically. Your components are
output
reactive list
observer
output (but not assigned to a slot...superfluous)
reactive object
output
I'd recommend grouping your reactives together, your observers together, and your outputs together. If you have truly separate systems, you can break the systems into different sections of code, but have them follow a similar pattern (I would claim that these two boxes are part of the same system)
Your commentUi reactive has a strange if-else construction. It always sets com to a random string. What's more, the if-else construction isn't really necessary because no where in your code do you ever update comment_value$default--it is always 0. It looks like you may have been trying to base this off of an action button at some point, and then concluded (rightly) that that wasn't a great option.
Also, I would advise against building UI components in your reactive objects. You'll find your reactives are much more flexible and useful if they return values and then build any UI components within the render family of functions.

R shiny - observeEvent - make the commands execute in order and in real time

My shiny app has to perform some slightly slower server-side calculations so I want the user to be able to keep track of what is happening while they are waiting. Here is a minimal example of the structure of my app:
https://gist.github.com/0bb9efb98b0a5e431a8f
runGist("0bb9efb98b0a5e431a8f")
What I would like to happen is:
Click submit
The app moves to the 'Output' tab panel
It displays the messages and outputs in the order they are listed in observeEvent
What actually happens is:
Click submit
Everything is executed server side at once
The UI is updated at the end
Is it possible to get what I want here?
I could not come up with a solution using your approach. Shiny seems to wait until everything in server = function(input, output) is computed, and displays the results just afterwards, when all components for output$... are available. I don't know if there is a way around that.
There is however a solution implemented, which you could try: Progress indicators
Implementation using your code:
library(shiny)
shinyApp(
ui = navbarPage(title="test", id="mainNavbarPage",
tabPanel("Input", value="tabinput",
numericInput('n', 'Number of obs', 100),
actionButton(inputId="submit_button", label="Submit")
),
tabPanel("Output", value="taboutput",
plotOutput('plot')
)
),
server = function(input, output, session) {
observeEvent(input$submit_button, {
# Move to results page
updateNavbarPage(session, "mainNavbarPage", selected="taboutput")
withProgress(message = "Computing results", detail = "fetching data", value = 0, {
Sys.sleep(3)
incProgress(0.25, detail = "computing results")
# Perform lots of calculations that may take some time
Sys.sleep(4)
incProgress(0.25, detail = "part two")
Sys.sleep(2)
incProgress(0.25, detail = "generating plot")
Sys.sleep(2)
})
output$plot <- renderPlot({hist(runif(input$n)) })
})
})

Stop functions starting in shiny until button pressed

I have begun to create a web app using shiny where a user enters a search term and tweets containing that term are returned.
When I load this app the searchTwitter function begins automatically and on the main panel there is the error: Error: You must enter a query.
The search term is entered in the textInput box and there is a submitButton. You can enter a term and it works fine but I don't want the error to be the first thing the user sees.
ui.R:
library(shiny)
shinyUI(pageWithSidebar(
headerPanel("Twitter Generator"),
sidebarPanel(
textInput("search", "Search Twitter For:", value = ""),
submitButton("Search")
),
mainPanel(
h3(textOutput("search")),
tableOutput("view"),
)
))
server.R:
library(shiny)
library(twitteR)
shinyServer(function(input, output) {
datasetInput <- reactive(function(){
rawTweets <- twListToDF(searchTwitter(paste(input$search)))
rawTweets$cleanText <- as.vector(sapply(rawTweets$text, CleanTweet))
rawTweets[, colnames(rawTweets) != "created"]
})
output$search <- reactiveText(function() {
input$search
})
output$view <- reactiveTable(function() {
head(datasetInput())
})
})
Thanks for your help
This is a logical request for and from your application design, and you should think through how to do it.
One easy way would be to add a tickbutton providing a true/false and to skip the actual twitter search if the value is FALSE. You may need to cache the previous value of rawTweets, or set it to NULL, or ...
mainPanel(
h3(textOutput("search")),
tableOutput("view")
)
try it without the second ","

Resources