I'm trying to build a simple roller where one can click a button and populate a series of variables. I'm sure this is an easy solution, but I'm just having a hard time getting it to work.
This is what I've got. I have the interface set up just as I want it, but basically I want to get a new value for the strength row.
library(shiny)
ui = fluidPage(
titlePanel(""),
sidebarLayout(
sidebarPanel(
textInput("char_name","Name"),
textInput("char_sex","Sex"),
actionButton("rollButton", "Roll!", width = "100%"),
hr(),
helpText("Please consult _ if you need assitance.")
),
mainPanel(
htmlOutput("name"),
htmlOutput("sex"),
htmlOutput("natl"),
htmlOutput("strength")
)
)
)
server = function(input, output) {
observe({
if(input$rollButton > 0) {
strength <- sum(sample(1:6,3,replace=TRUE))
}
})
output$name <- renderText({
input$rollButton
isolate(paste0('<b>Name</b>: ', input$char_name))
})
output$sex <- renderText({
input$rollButton
isolate(paste0('<b>Sex</b>: ', input$char_sex))
})
output$strength <- renderText({
input$rollButton
isolate(paste0('<b>Strength</b>: ', strength))
})
}
shinyApp(ui = ui, server = server)
You can't read the strength variable because it was set in another function. You can create a vector of shared reactive values
server = function(input, output) {
val <- reactiveValues(strength=NULL)
observe({
if(input$rollButton > 0) {
val$strength <- sum(sample(1:6,3,replace=TRUE))
}
})
output$name <- renderText({
input$rollButton
isolate(paste0('<b>Name</b>: ', input$char_name))
})
output$sex <- renderText({
input$rollButton
isolate(paste0('<b>Sex</b>: ', input$char_sex))
})
output$strength <- renderText({
input$rollButton
isolate(paste0('<b>Strength</b>: ', val$strength))
})
}
shinyApp(ui = ui, server = server)
Related
I have a simple shiny app which I would like to show a warning if user input is bigger than a threshold.
library(shiny)
library(shinyalert)
ui <- fluidPage(
numericInput("obs", "Observations:", 1),
verbatimTextOutput("value")
)
server <- function(input, output) {
observeEvent(input$obs,{
if(!is.na(input$obs) && input$obs >10){
shinyalert("warning!", "input too big", type = "warning")
}
})
output$value <- renderText({ input$obs })
}
shinyApp(ui, server)
if user is not quick enough to provide input, let say for the input$obs = 110 we have 1 second delay between putting the second and third value the popups warning will appear !
How should I fix this ?
Use shinyCatch from spsComps to make your life easier
library(shiny)
library(spsComps)
ui <- fluidPage(
numericInput("obs", "Observations:", 1),
verbatimTextOutput("value")
)
server <- function(input, output) {
output$value <- renderText({
shinyCatch({
if(!is.na(input$obs) && input$obs >10) warning("input too big")
}, blocking_level = "warning", prefix = "")
input$obs
})
}
shinyApp(ui, server)
when blocking_level = "warning" is specified shinyCatch blocks following code in the renderText expression. So when your number is larger than 10, the new input$obs will not be rendered.
Here's what users see
Here's what developers see in the console
You can use showNotification() from shiny itself:
library(shiny)
ui <- fluidPage(
numericInput("obs", "Observations:", 1),
verbatimTextOutput("value")
)
server <- function(input, output) {
observeEvent(input$obs,{
if(!is.na(input$obs) && input$obs >10){
showNotification(
ui = tags$h4("Input Too Big!"),
type = "warning"
)
}
})
output$value <- renderText({ input$obs })
}
shinyApp(ui, server)
Or {shinytoastr}:
library(shiny)
library(shinytoastr)
ui <- fluidPage(
shinytoastr::useToastr(),
numericInput("obs", "Observations:", 1),
verbatimTextOutput("value")
)
server <- function(input, output) {
observeEvent(input$obs,{
if(!is.na(input$obs) && input$obs >10){
shinytoastr::toastr_warning(
message = "Decrease it.",
title = "Input too big!"
)
}
})
output$value <- renderText({ input$obs })
}
shinyApp(ui, server)
Or {spsComps} as #lz100 mentioned. The choice is yours.
I want to update output data on update button every time.
Here is my code which show the output on update button for the first time I run the code but in runtime if the input is changed, the output is updated automatically.
library(shiny)
ui <- fluidPage(
titlePanel("My Shop App"),
sidebarLayout(
sidebarPanel(
helpText("Controls for my app"),
selectInput("item",
label = "Choose an item",
choices = list("Keyboard",
"Mouse",
"USB",
sliderInput("price",
label = "Set Price:",
min=0, max = 100, value=10),
actionButton ("update","Update Price")
),
mainPanel(
helpText("Selected Item:"),
verbatimTextOutput("item"),
helpText("Price"),
verbatimTextOutput("price")
)
)
)
server <- function(input, output) {
SelectInput <- eventReactive (input$update , {
output$item = renderText(input$item)
output$price = renderText(input$price)
})
output$item <- renderText(SelectInput())
output$price <- renderText(SelectInput())
}
shinyApp(ui = ui, server = server)
Either create a dependency and put them into the reactive and return it:
server <- function(input, output) {
SelectInput <- eventReactive(input$update,{
list(item = input$item, price = input$price)
})
output$item <- renderText(SelectInput()$item)
output$price <- renderText(SelectInput()$price)
}
Or you can isolate, but then you have to add the button reaction to each listener
server <- function(input, output) {
output$item <- renderText({
req(input$update)
input$update
isolate(input$item)
})
output$price <- renderText({
req(input$update)
input$update
isolate(input$price)
})
}
I'd like to run the action button automatically when users open/land on 'tab1'. Therefore, instead of clicking the Refresh button to view the date, I'd like to have the date printed automatically. Is there a way to do this? My real code is more complicated that this simple example. However, it demonstrates what I'd like to do. Thank you!
library(shiny)
ui <- fluidPage(
shiny::tabPanel(value = 'tab1', title = 'Data page',
br(),
shiny::actionButton("btn", "Refresh!"),
br(),
shiny::verbatimTextOutput("out")
)
)
server <- function(input, output, session) {
curr_date <- shiny::eventReactive(input$btn, {
format(Sys.Date(), "%c")
})
output$out <- shiny::renderText({
print(curr_date())
})
}
shinyApp(ui, server)
You can make curr_date reactive to the tabset:
library(shiny)
ui <- fluidPage(
tabsetPanel(
tabPanel(value = 'tab1', title = 'Data page',
br(),
actionButton("btn", "Refresh!"),
br(),
verbatimTextOutput("out")
),
tabPanel(value = 'tab2', title = 'Other tab'),
id = "tabset"
)
)
server <- function(input, output, session) {
curr_date <- eventReactive(list(input$btn, input$tabset), {
req(input$tabset == 'tab1')
format(Sys.time(), "%c")
})
output$out <- renderText({
print(curr_date())
})
}
shinyApp(ui, server)
You should use reactiveValues() and observeEvent() for this. Inside server function:
server <- function(input, output, session) {
text_out <- reactiveValues(date = format(Sys.Date(), "%c"))
observeEvent(input$btn, {
text_out$date <- "something else"
})
output$out <- renderText({
print(text_out$date)
}
I have a simple task of printing the output of a call to table() on a selected variable.
I want to display the output when the button "Print" is clicked.
In the following example, once the button is clicked, the output is always triggered when I change the selected variable.
If I clicked "Print", and then change the selected variable, I want the ouput to be gone, waited to be printed again when clicking "Print".
Thank you!
Here is a reproducible example:
library(shiny)
data = iris
ui = fluidPage(
uiOutput("selectvar"),
actionButton("print", "Print"),
verbatimTextOutput("info")
)
server = function(input, output, session)
{
output$selectvar = renderUI({
selectInput("selectedvar",
"Select variable",
choices = colnames(iris))
})
tab = reactive( table(data[[input$selectedvar]]) )
observeEvent(input$print, {
output$info = renderPrint( tab() )
})
}
shinyApp(ui, server)
That's because output$info is reactive to tab(), even while it is enclosed in an observeEvent. I think this app does what you want:
library(shiny)
data = iris
ui = fluidPage(
uiOutput("selectvar"),
actionButton("print", "Print"),
verbatimTextOutput("info")
)
server = function(input, output, session)
{
output$selectvar = renderUI({
selectInput("selectedvar",
"Select variable",
choices = colnames(iris))
})
tab <- reactiveVal()
observeEvent(input$selectedvar, {
tab(NULL)
})
observeEvent(input$print, {
tab(table(data[[input$selectedvar]]))
})
output$info <- renderPrint({
tab()
})
}
shinyApp(ui, server)
I want to create a UI module, insert it, and obtain an input object from the server module. I then want to observe events on this input object.
Currently, I return an input object as a reactive value from callModule. However, the observer I create only fires once (on initialisation).
Can anyone tell me if what I am trying to do is possible, and where I'm going wrong? Code attached. Thanks in advance.
John
app.R
library(shiny)
source("added.R")
source("addedUI.R")
# Define UI for application that draws a histogram
ui <- fluidPage(
actionButton("add_id", "Add"),
actionButton("print_id", "Print list"),
tags$hr(),
tags$div(id = "div"),
tags$hr()
)
# Define server logic required to draw a histogram
server <- function(input, output) {
id <- 0
rv <- list()
next_id <- function()
{
id <<- id + 1
return (as.character(id))
}
observeEvent(input$print_id,
{
print(rv)
})
observeEvent(input$add_id,
{
x <- next_id()
ui <- addedUI(x)
insertUI(selector = sprintf("#%s", "div"), where = "beforeEnd", ui = ui)
rv[[x]] <<- callModule(added, x)
observeEvent(rv[[x]],
{
print(sprintf("Observed %s: ", x))
})
print(rv)
})
}
# Run the application
shinyApp(ui = ui, server = server)
added.R
added <- function(input, output, session)
{
return (reactive(input$text_id))
}
addedUI.R
addedUI <- function(id)
{
ns <- NS(id)
tags$div(textInput(ns("text_id"), "Text", value = "Abc"))
}
You need to use observeEvent(rv[[x]](), ...) to read the current value from the reactive. Otherwise you recieve the reference to the reactive object, which is not observable. Same for the print_id observer.
library(shiny)
added <- function(input, output, session)
{
return (reactive(input$text_id))
}
addedUI.R
addedUI <- function(id)
{
ns <- NS(id)
tags$div(textInput(ns("text_id"), "Text", value = "Abc"))
}
# Define UI for application that draws a histogram
ui <- fluidPage(
actionButton("add_id", "Add"),
actionButton("print_id", "Print list"),
tags$hr(),
tags$div(id = "div"),
tags$hr()
)
# Define server logic required to draw a histogram
server <- function(input, output) {
id <- 0
rv <- list()
next_id <- function()
{
id <<- id + 1
return (as.character(id))
}
observeEvent(input$print_id,
{
print(lapply(rv, function(x){x()}))
})
observeEvent(input$add_id,
{
x <- next_id()
ui <- addedUI(x)
insertUI(selector = sprintf("#%s", "div"), where = "beforeEnd", ui = ui)
rv[[x]] <<- callModule(added, x)
observeEvent(rv[[x]](),
{
print(sprintf("Observed %s: ", x))
})
print(rv)
})
}
# Run the application
shinyApp(ui = ui, server = server)