I have the following Shiny Application:
library(shiny)
library(shinyjs)
library(shinydashboard)
UI <- fluidPage(
actionButton("get_tweets", "Fetch tweets"),
numericInput("tweet_amount", "Set the amount of Tweets", 10, min = 10, max = 1000),
selectInput("tweet_name", "Select the tweeter", selected = NULL, choices = c("#RealDonaldTrump")),
#Set hidden buttons
hidden(
div(id="status_update",
verbatimTextOutput("status")
)
),
hidden(
div(id="tweet_fetcher",
verbatimTextOutput("status2")
)
)
)
Server <- function(input, output){
list = c(1,2,3)
get_connected <- reactive({
for(i in 1:length(list)){
Sys.sleep(2)
}
})
observeEvent(input$get_tweets, {
get_connected()
toggle("status_update")
output$status <- renderText({"You're now connected to the API"})
toggle("tweet_fetcher")
output$status2 <- renderText("Test")
})
}
shinyApp(ui = UI, server = Server)
Thing is that now I works. However, ideally I would like to make sure a button appears. Therefore I want to change:
output$status2 <- renderText("Test")
and this
verbatimTextOutput("status2") #actionButton("status2", "a_button")
This does not work. Any tips on what I should use if I want JS to let a button appear?
If i understand the question correctly you want to interchange
verbatimTextOutput("status2") with actionButton("status2", "a_button").
Then you should use renderUI():
Server side: output$status2 <- renderUI(actionButton("status2",
"a_button"))
UI side: uiOutput("status2")
Full app would read:
library(shiny)
library(shinyjs)
library(shinydashboard)
UI <- fluidPage(
actionButton("get_tweets", "Fetch tweets"),
numericInput("tweet_amount", "Set the amount of Tweets", 10, min = 10, max = 1000),
selectInput("tweet_name", "Select the tweeter", selected = NULL, choices = c("#RealDonaldTrump")),
#Set hidden buttons
hidden(
div(id="status_update",
verbatimTextOutput("status")
)
),
hidden(
div(id="tweet_fetcher",
uiOutput("status2")
)
)
)
Server <- function(input, output){
list = c(1,2,3)
get_connected <- reactive({
for(i in 1:length(list)){
Sys.sleep(2)
}
})
observeEvent(input$get_tweets, {
get_connected()
toggle("status_update")
output$status <- renderText({"You're now connected to the API"})
toggle("tweet_fetcher")
output$status2 <- renderUI(actionButton("status2", "a_button"))
})
}
shinyApp(ui = UI, server = Server)
Related
Here is an example. The progress bar just jumps from 0% to 100% due a single function getres(). How to indicate the progress smoothly?
library("shiny")
library("shinyWidgets")
library("DESeq2")
library("airway")
data(airway)
getres <- function(eset){
dds<-DESeqDataSet(eset, design = ~cell + dex)
keep <- rowSums(counts(dds)) >= 10
dds <- dds[keep,]
dds <- DESeq(dds)
res <- results(dds)
return(res)
}
ui <- fluidPage(
tags$h1("Progress bar in Sweet Alert"),
useSweetAlert(), # /!\ needed with 'progressSweetAlert'
actionButton(
inputId = "go",
label = "Launch long calculation !"
)
)
server <- function(input, output, session) {
observeEvent(input$go, {
progressSweetAlert(
session = session, id = "myprogress",
title = "Work in progress",
display_pct = TRUE, value = 0
)
for (i in seq_len(1)) {
Sys.sleep(0.1)
updateProgressBar(
session = session,
id = "myprogress",
res<-getres(airway),
value = i
)
}
closeSweetAlert(session = session)
sendSweetAlert(
session = session,
title =" Calculation completed !",
type = "success"
)
})
}
shinyApp(ui = ui, server = server)
I was unable to run your example as airway and DESeq2 are not available for R 3.6+. BUT there is an interesting package that I have been meaning to try out called waiter.
Within waiter there is waitress which will "let you display loading bars on the entire screen or specific elements only."
There is a great demo app where you play with the different functions.
Here is an example from the docs!
library(shiny)
library(waiter)
ui <- navbarPage(
"Waitress on nav",
tabPanel(
"home",
use_waitress(),
plotOutput("plot")
)
)
server <- function(input, output){
# now waitress ranges from 0 to 100
waitress <- Waitress$new("nav", theme = "overlay", min = 0, max = 10)
output$plot <- renderPlot({
for(i in 1:10){
waitress$inc(1) # increase by 10%
Sys.sleep(.5)
}
hist(runif(100))
waitress$close() # hide when done
})
}
shinyApp(ui, server)
Hope this helps or gives you other ideas!
I am trying to understand the reactive part in R shiny. In that process I am trying to update an output table based on the input change while selecting values from the age drop down. It seems to do it by the first value but when I change any value from the age drop down it won't update my table. The input I am using is chooseage. Below is the code which I am using.
library(shiny)
library(shinydashboard)
library(shinyBS)
library(knitr)
library(kableExtra)
library(shiny)
library(shinythemes)
ui <- dashboardPage(
dashboardHeader(disable = F, title = "PATH Study"),
dashboardSidebar(sidebarMenu(
menuItem(
"Population Filter",
uiOutput("choose_age")
)
)),
dashboardBody(box(
width = 12,
tabBox(
width = 12,
id = "tabBox_next_previous",
tabPanel("Initiation",
fluidRow(
box(
width = 5,
solidHeader = TRUE,
status = "primary",
tableOutput("smoke"),
collapsible = F
)
))
),
uiOutput("Next_Previous")
))
)
server <- function(input, output, session) {
# Drop-down selection box for which Age bracket to be selected
age_levels <- c("18 to 24 years old","25 to 34 years old","35 to 44 years old")
output$choose_age <- renderUI({
selectInput("selected_age", "Age", as.list(age_levels))
})
myData <- reactive({
with_demo_vars %>%
filter(age == input$choose_age) %>%
pct_ever_user(type = "SM")
})
output$smoke <-
renderTable({
head(myData())
})
}
shinyApp(ui = ui, server = server)
Here is a quick prototype for your task
library(shiny)
library(tidyverse)
library(DT)
# 1. Dataset
df_demo <- data.frame(
age = c(16, 17, 18, 19, 20),
name = c("Peter", "Mary", "Mike", "Nick", "Phillipe"))
# 2. Server
server <- function(input, output, session) {
# 1. UI element 'Age'
output$ui_select_age <- renderUI({
selectInput("si_age", "Age", df_demo$age)
})
# 2. Reactive data set
df_data <- reactive({
# 1. Read UI element
age_selected <- input$si_age
# 2. Filter data
df <- df_demo %>%
filter(age == age_selected)
# 3. Return result
df
})
# 3. Datatable
output$dt_table <- renderDataTable({
datatable(df_data())
})
}
# 3. UI
ui <- fluidPage(
fluidRow(uiOutput("ui_select_age")),
fluidRow(dataTableOutput("dt_table"))
)
# 4. Run app
shinyApp(ui = ui, server = server)
I think youre shinyApp is over-reactive, as all functions in the server are executed straight away, without waiting for any selected input. So either it will break down or behave weird. So you have to delay the reactivity with req(), validate() / need() or with any observeEvent or eventReactive() function.
Maybe this snippet might help you, although there would be several ways to achieve the desired behaviour.
library(shiny)
library(shinydashboard)
library(dplyr)
data(mtcars)
mtcars$age <- sample(x = c(10,20,30,40,50), size = nrow(mtcars), replace = T)
with_demo_vars <- mtcars
ui <- dashboardPage(
dashboardHeader(disable = F, title = "PATH Study"),
dashboardSidebar(sidebarMenu(
menuItem(text = "Population Filter",
uiOutput("choose_age")
)
)
),
dashboardBody(
tableOutput("smoke")
)
)
server <- function(input, output, session) {
output$choose_age <- renderUI({
selectInput("selected_age", "Age", with_demo_vars$age)
})
myData <- reactive({
with_demo_vars %>%
dplyr::filter(age == input$selected_age)
})
output$smoke <- renderTable({
req(input$selected_age)
head(myData())
})
}
shinyApp(ui = ui, server = server)
I have tried to nest some "observe events" in Shiny to create a conditional rule.
It should go like this :
if one box is clicked display the corresponding single output when the button is clicked.
if both boxes are clicked display both outputs when the button is clicked.
but it always displays both outputs.
Any suggestion?
shinyApp(
ui = basicPage(
checkboxInput("box1", label = "Checkbox1", value = FALSE),
checkboxInput("box2", label = "Checkbox2", value = FALSE),
actionButton('buttn', 'Validate'),
verbatimTextOutput("out1"),
verbatimTextOutput("out2")
),
server = function(input, output) {
observeEvent(input$buttn, {
observeEvent(input$box1, {
output$out1 <- renderText({"Foo"})});
observeEvent(input$box2, {
output$out2 <- renderText({"bar"})})
})
}
)
Please note that it is bad practice to put observeEvents or reactives inside other observeEvents. See this slide and the two after it from a presentation by Joe Cheng.
One possible solution is to simply show or hide elements with the shinyjs package. A working example is given below.
Another solution is to use reactiveVal to hold the text to be displayed, and update that from your observer.
Hope this helps!
Solution 1
library(shiny)
library(shinyjs)
ui <- basicPage(
checkboxInput("box1", label = "Checkbox1", value = FALSE),
checkboxInput("box2", label = "Checkbox2", value = FALSE),
actionButton('buttn', 'Validate'),
shinyjs::hidden(div(id='div1', verbatimTextOutput("out1"))),
shinyjs::hidden(div(id='div2', verbatimTextOutput("out2"))),
useShinyjs()
)
server <- function(input, output) {
observeEvent(input$buttn, {
if(input$box1)
shinyjs::show('div1')
else
shinyjs::hide('div1')
if(input$box2)
shinyjs::show('div2')
else
shinyjs::hide('div2')
})
output$out1 <- renderText({"Foo"})
output$out2 <- renderText({"bar"})
}
shinyApp(ui,server)
Solution 2
library(shiny)
library(shinyjs)
ui <- basicPage(
checkboxInput("box1", label = "Checkbox1", value = FALSE),
checkboxInput("box2", label = "Checkbox2", value = FALSE),
actionButton('buttn', 'Validate'),
verbatimTextOutput("out1"),
verbatimTextOutput("out2")
)
server <- function(input, output) {
text1 <- reactiveVal(NULL)
text2 <- reactiveVal(NULL)
observeEvent(input$buttn, {
ifelse(input$box1,text1('Foo'),text1(NULL))
ifelse(input$box2,text2('Bar'),text2(NULL))
})
output$out1 <- renderText({text1()})
output$out2 <- renderText({text2()})
}
shinyApp(ui,server)
You don't need the extra event observers. Just observe the button click and use standard R conditional logic to adjust the output based on the checkboxes.
shinyApp(
ui = basicPage(
checkboxInput("box1", label = "Checkbox1", value = FALSE),
checkboxInput("box2", label = "Checkbox2", value = FALSE),
actionButton('buttn', 'Validate'),
verbatimTextOutput("out1"),
verbatimTextOutput("out2")
),
server = function(input, output) {
observeEvent(input$buttn, {
if (input$box1) {
output$out1 <- renderText({"Foo"})
}
if (!input$box1) {
output$out1 <- renderText({NULL})
}
if (input$box2) {
output$out2 <- renderText({"Bar"})
}
if (!input$box2) {
output$out2 <- renderText({NULL})
}
})
}
)
EDITED
I would like to ask you how to do that simple thigs.
I want to make Shiny Web application that get from interface ammount of something (inputId=num), and show the table with countries that
data$both>num
I made some code, but it doesnt work.
library(shiny)
ui <- fluidPage(
sliderInput(inputId = 'num',label = 'Countries that...',min = '1',max =189',value = '20',step = '1')
tableOutput(outputId = 'liczba')
)
server <- function(input, output) {
output$liczba <- renderTable({
data[data$both>input$num,]
})
}
shinyApp(ui=ui, server=server)
Here's a possible solution based on your code. There are several small errors in your implementation. Please take a look here for a set of very good examples.
library(shiny)
library(DT)
data <- data.frame(
country = c("Germany", "Netherlands", "Canada"),
male = c(15, 30, 45)
)
ui <- fluidPage(
fluidRow(
sliderInput(
inputId = 'num',
label = 'Countries that...',
min = 1,
max = 189,
value = 20,
step = 1
)
),
fluidRow(
DT::dataTableOutput("liczba")
)
)
server <- function(input, output) {
output$liczba <- DT::renderDataTable(DT::datatable({
result <- subset(
data,
data$male > input$num
)
result
}))
}
shinyApp(ui = ui, server = server)
Is it possible to capture the label of an actionButton once it is clicked?
Imagine I have 3 buttons on my ui.R and depending on which one I click I want to perform a different action on the server.R.
One caveat is that the buttons are created dynamically on the server.R with dynamic labels (thus the necessity of capturing the label on click)
Thanks
Something like that ?
library(shiny)
server <- function(input, session, output) {
output$printLabel <- renderPrint({input$btnLabel})
}
ui <- fluidPage(
actionButton("btn1", "Label1",
onclick = "Shiny.setInputValue('btnLabel', this.innerText);"),
actionButton("btn2", "Label2",
onclick = "Shiny.setInputValue('btnLabel', this.innerText);"),
verbatimTextOutput("printLabel")
)
shinyApp(ui = ui, server = server)
1) What button was clicked last by the user?
To answer this you can user observeEvent function and by setting up a a variable using reactiveValues function. Make sure you update your libraries and work in the latest version of R (version 3.1.3) as shiny is dependant on this version. Working on windows you can follow example on how to update here
rm(list = ls())
library(shiny)
ui =fluidPage(
sidebarPanel(
textInput("sample1", "Name1", value = "A"),
textInput("sample2", "Name2", value = "B"),
textInput("sample3", "Name3", value = "C"),
div(style="display:inline-block",uiOutput("my_button1")),
div(style="display:inline-block",uiOutput("my_button2")),
div(style="display:inline-block",uiOutput("my_button3"))),
mainPanel(textOutput("text1"))
)
server = function(input, output, session){
output$my_button1 <- renderUI({actionButton("action1", label = input$sample1)})
output$my_button2 <- renderUI({actionButton("action2", label = input$sample2)})
output$my_button3 <- renderUI({actionButton("action3", label = input$sample3)})
my_clicks <- reactiveValues(data = NULL)
observeEvent(input$action1, {
my_clicks$data <- input$sample1
})
observeEvent(input$action2, {
my_clicks$data <- input$sample2
})
observeEvent(input$action3, {
my_clicks$data <- input$sample3
})
output$text1 <- renderText({
if (is.null(my_clicks$data)) return()
my_clicks$data
})
}
runApp(list(ui = ui, server = server))
2) Save the clicks for further manipulation is below
Here's small example based on the work of jdharrison from Shiny UI: Save the Changes in the Inputs and the shinyStorage package.
rm(list = ls())
#devtools::install_github("johndharrison/shinyStorage")
library(shinyStorage)
library(shiny)
my_clicks <- NULL
ui =fluidPage(
#
addSS(),
sidebarPanel(
textInput("sample_text", "test", value = "0"),
uiOutput("my_button")),
mainPanel(uiOutput("text1"))
)
server = function(input, output, session){
ss <- shinyStore(session = session)
output$my_button <- renderUI({
actionButton("action", label = input$sample_text)
})
observe({
if(!is.null(input$sample_text)){
if(input$sample_text != ""){
ss$set("myVar", input$sample_text)
}
}
})
output$text1 <- renderUI({
input$action
myVar <- ss$get("myVar")
if(is.null(myVar)){
textInput("text1", "You button Name")
}else{
textInput("text1", "You button Name", myVar)
}
})
}
runApp(list(ui = ui, server = server))