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)
Related
I've written code that runs a long calculation in which, as part of it, several UI elements are updated showing part of the progress and results of the calculations. I would like to make possible for the user to run more than one calculation at the same time and keep been able of checking the progress and results.
This is an example app code:
#EXAMPLE APP----
#Libraries----
library(shiny)
library(shinyjs)
#UI code----
ui <- fluidPage(
useShinyjs(),
sidebarLayout(
sidebarPanel(
actionButton(
'pressme',
'Press me'
)
),
mainPanel(
div(
id='inmainP'
)
)
)
)
#Server code----
server <- function(input, output, session) {
clicks <- reactiveValues()
clicks$count <- 0
##Adding the UI elements necesary when pressing the button----
observeEvent(input$pressme,{
clicks$count <- clicks$count + 1
insertUI(
'#inmainP',
'beforeEnd',
div(id=paste0('Pcontainer',clicks$count),
p(tags$b(paste0(clicks$count,'-Process'))),
style = 'border:solid thin black;text-align: center;')
)
insertUI(
paste0('#Pcontainer',clicks$count),
'beforeEnd',
textOutput(paste0('process',clicks$count,'1'))
)
insertUI(
paste0('#Pcontainer',clicks$count),
'beforeEnd',
textOutput(paste0('process',clicks$count,'2'))
)
insertUI(
paste0('#Pcontainer',clicks$count),
'beforeEnd',
textOutput(paste0('process',clicks$count,'3'))
)
###Creating input to observe to do long calculation----
#This is done because it is the only way that I've accomplished, in the real app,
#that new elements render before starting calculation
runjs(
paste0('
Shiny.setInputValue("start",',clicks$count,')
')
)
})
##Runing long calculation----
observeEvent(input$start,{
odd <- 1
even <- 1
for (i in 1:10) {
Sys.sleep(1)
html(paste0('process',clicks$count,'1'), i)
if((i%%2)==0){
html(paste0('process',clicks$count,'2'), even)
even <- even + 1
}else{
html(paste0('process',clicks$count,'3'), odd)
odd <- odd + 1
}
}
})
}
shinyApp(ui, server)
As you will notice this app runs perfectly but new processes only run once the ones before have finished. I would like to solve this using callr package, that I've managed to use in other long jobs in the app, but don't know how to use it properly here. Any other suggestions based on the use of other packages as promises or future are also welcome.
As I mention I've tried to solve this using callr but I've failed at traying to create eventReact(s) programmatically, necessary to run each background job (to my understanding). And I don't understand how to make UI update from background process. How do the background processes work in R?
Link to this question in RStudioCommunity.
I'm trying to use an action button in R Shiny to start a slow-running JAGS model. I would like some text to appear when the user first hits the button that displays what time they pressed the button so that they know something is happening.
So far, the action button is working but it waits until the slow-running model is done to display both the model output and the text.
I have looked at the following questions but they don't seem to answer my question, at least not in a way I understand:
R Shiny execute order
Pattern for triggering a series of Shiny actions
I am new to Shiny so I'm hoping this is a simple problem.
Run.me <- function(a){
# some fake slow function
# This actually takes about 8 hours in real life
for (i in 2:a) {
Foo[i] <<- Foo[i-1] + sample(1:20,1)
}}
library(shiny)
Define server logic ----
server <- function(input, output) {
observeEvent(input$runmodel, {
output$model.running <- renderText({paste("Model started at", Sys.time())})
})
observeEvent(input$runmodel, {
Foo <<- rep(1, 1e6)
Run.me(1e6)
output$model.ran <- renderTable({head(Foo)})
})
}
Define UI ----
ui <- fluidPage(
fluidRow(
column(5, align = "center",
actionButton("runmodel", "Run the Model")),
textOutput("model.running")
),
fluidRow(
column(5, align = "center", tableOutput("model.ran"))
)
)
Run the app ----
shinyApp(ui = ui, server = server)
A possibility, if I correctly understand the question:
server <- function(input, output) {
observeEvent(input$runmodel, {
Foo <<- rep(1, 1e6)
Run.me(1e6)
output$modelran <- renderTable({head(Foo)})
})
}
js <- "
$(document).ready(function() {
$('#runmodel').on('click', function(){
var date = new Date().toLocaleString();
$('#busy').html('Model started: ' + date);
});
$('#modelran').on('shiny:value', function(event) {
$('#busy').html('');
});
});
"
ui <- fluidPage(
tags$head(
tags$script(HTML(js))
),
fluidRow(
column(5, align = "center",
actionButton("runmodel", "Run the Model")),
tags$p(id = "busy")
),
fluidRow(
column(5, align = "center", tableOutput("modelran"))
)
)
In my app which is also building a model slowly I use a progress bar in the server. I know this is not exactly what you are asking for but you might find it an acceptable solution.
modeloutput= reactive(withProgress(message = 'Generating JAGs model', value = 0, {
incProgress(50); generate_jags(params)
}))
output$jags = renderPlot(modeloutput())
I will also follow answers to this question as I would also prefer a solution that has a message or loading bar in the actual plotting window where the output will appear.
I've also found another solution that works by blocking out the action button after it has been clicked and has a small loading bar and completion message. It is available here:
https://github.com/daattali/advanced-shiny/tree/master/busy-indicator
I'm trying to create a shiny app that checks if an email provided in the sidebar is valid (in my case I authenticate directly to an API but in the code below I just create a toy example). I know that I can generate warnings and errors for inputs using validate and need (already read the shiny site on the topic here) but on most examples the errors and warnings are shown in the mainPanel() when generating a plot or something a like.
In my case, the main layout is only static text. What I'm trying to achieve is simple: the user inputs an email I check it, if it doesn't comply I generate some warning/error but it is shown somewhere else other than the mainPanel() because in my case there's no dynamic mainPanel.
Below is an example of what I'm trying to achieve.
library(shiny)
ui <- fluidPage(
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
textInput("email", "Email")
),
mainPanel()
)
)
# Define server logic required to draw a histogram
server <- function(input, output) {
output$email <-
renderUI({
validate(need(input$email == "",
"Introduce your email"))
validate(need(grep("gmail", input$email, value = TRUE)),
"Your email is not valid")
})
}
# Run the application
shinyApp(ui = ui, server = server)
Any idea how to achieve this? The error could be shown any where but on the mainPanel.
I am not 100% sure if I understand your question correctly, does the below do what you want? It displays a text message in the sidebar if one of your specified conditions is not met.
Hope this helps!
library(shiny)
ui <- fluidPage(
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
textInput("email", "Email"),
uiOutput('email_text')
),
mainPanel()
)
)
# Define server logic required to draw a histogram
server <- function(input, output) {
output$email_text <-
renderUI({
if(input$email == ""){
return(p("Please add your gmail e-mail address."))
}
if(!grepl("gmail", input$email)){
return(p("Your email is not a gmail e-mail address!"))
}
})
}
# Run the application
shinyApp(ui = ui, server = server)
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)
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.