In a shiny app I wanted to include an animated tabBox, similar to animated sliderInput - after specified time the tab would automatically switch to the next one. This doesn't seem to be an option in tabBox. I tried two solutions, neither worked. First I tried to simply link animation from sliderInput to tabBox:
library("shiny")
library("shinydashboard")
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
sliderInput(inputId = "slider", label = "Player", min = 1, max = 4, value = 1,
animate = animationOptions(interval = 1000, loop = TRUE)),
textOutput(outputId = "text")
),
dashboardBody(
tabBox(
id="tabbox",
tabPanel(title = 1),
tabPanel(title = 2),
tabPanel(title = 3),
tabPanel(title = 4)
)
)
)
)
server <- function(input, output, session){
output$text <- renderText({paste0("tabbox: ", input$tabbox, " slider: ",input$slider, " reactive: ", A$a)})
A <- reactiveValues(a = 1)
observeEvent(
input$slider,
A$a <- input$slider
updateTabItems(session = session, inputId = "tabbox", selected = A$a)
)
}
shinyApp(ui=ui, server=server)
However, this code only changes the reactive value A$a, but doesn't change input$tabbox (A$a is there only so I could see which step fails).
The second solution I tried was to run this function on button click, but it also failed:
for(i in 1:4){
Sys.sleep(2)
updateTabItems(session = session, inputId = "tabbox", selected = i)
}
Questions:
Is it possible by just using R? How could it be done?
Related
I have the following code:
library(shiny)
library(shinydashboard)
library(rhandsontable)
header <- dashboardHeader(title = "Sample", titleWidth = 375)
sidebar <- dashboardSidebar(width = 270,
sidebarMenu(id="mymenu",
menuItem(text = "Home", tabName = "tabCars", icon = icon("home", class="home"))
))
body <- dashboardBody (
tabItems(
tabItem(tabName = "tabCars",
fluidRow(
column(width = 2,
selectInput(
inputId = "selected_CarCylinders",
label = "Car Cylinders",
choices = mtcars$cyl,
selectize = TRUE,
width = "250px",
multiple = FALSE
)),
column(width = 2, style = "margin-top: 25px",
actionButton("deleteBtn", "Delete Selected Cylinders")),
column(width = 1, style = "margin-top: 25px",
actionButton("refreshBtn", "Refresh Filter/Chart")),
rHandsontableOutput("carDT")
)
)
)
)
ui <- dashboardPage(header, sidebar, body)
server <- function(input, output, session) {
output$carDT <- renderRHandsontable({
df <- mtcars
rhandsontable(df, stretchH = "all")
})
observeEvent(input$deleteBtn, {
# need help here
})
observeEvent(input$refreshBtn, {
# need help here
})
}
shinyApp(ui, server)
I need help writing what would go into the input$deleteBtn and input$refreshBtn sections of the server side. If you run the code as is, the idea is to select the number of cylinders from mtcars, then click the Delete button to remove all those entries from the table and filter; however, the filter and table would only update after clicking the refresh button.
While permanently delete screams a SQLite database to me, you could achieve this by using a reactiveVal to store the dataframe and call req to only refresh the table when you click the refreshBtn (in this case, you also have to click it to display the table at the start of the app).
server <- function(input, output, session) {
# Create a `reactiveVal` and set a value to it
df <- reactiveVal()
df(mtcars)
output$carDT <- renderRHandsontable({
req(input$refreshBtn)
rhandsontable(df(), stretchH = "all")
})
observeEvent(input$deleteBtn, {
data <- dplyr::filter(df(), cyl != input$selected_CarCylinders)
# Update `selectInput` to filter out the choices too (for good measure)
updateSelectInput(session, "selected_CarCylinders", choices = data$cyl)
# Update the `reactiveVal` value
df(data)
})
}
I would like to have two instances of an input controller in my Shiny app, but I think that what I have to do instead is to have two inputs and update the value of each whenever the other changes. This way, they will appear to the user to be the same controls despite the fact that they have different IDs.
I anticipate being told to not do what I am trying to do, but the use case is that I have many tabs in a dashboardPage(), and only two of them share controls. Thus, putting the controls for those two pages in the sidebar would be confusing to the user.
I made a simple, working example of how to do this (using a dashboard to make it more clear why I want to do this) based on a closely-related question that was answered by convincing the asker to do something else (which worked in their case but not in mine). The app works fine except that as it gets more and more complex, the calculations take long enough sometimes that I can change one input and then change the other before the Shiny server has had time to update the values. This results in infinite feedback (input 1 updates to match input 2 while input 2 is updating to match input 1, and then this repeats for as long as I care to watch).
library(shiny)
library(shinydashboard)
ui = dashboardPage(
dashboardHeader(title = "Example"),
dashboardSidebar(
sidebarMenu(
menuItem("Tab 1", tabName = "tab1", icon = icon("chart-line")),
menuItem("Tab 2", tabName = "tab2", icon = icon("chart-line")),
menuItem("Other Tab", tabName = "tab3", icon = icon("project-diagram"))
)
),
dashboardBody(
tabItems(
# First tab content
tabItem(tabName = "tab1",
# Input first number
numericInput("input1", label = "Input 1", value = 1, min=1, step=1)
),
# Second tab content
tabItem(tabName = "tab2",
# Input second number
numericInput("input2", label = "Input 2", value = 1, min=1, step=1)
),
# Third tab content
tabItem(tabName = "tab3", "Unrelated content")
)
)
)
server = function(input, output, session) {
# Update inputs to match each other
observeEvent(input$input1, {
updateSelectInput(session = session,
inputId = "input2",
selected = input$input1)})
observeEvent(input$input2, {
updateSelectInput(session = session,
inputId = "input1",
selected = input$input2)})
}
shinyApp(ui = ui, server = server)
The question: what other ways are there to have separate pages with matching controls that control both pages but without having to put those controls on every page? Sub-question: is any of these methods going to avoid the infinite loop problem? Corollary: I saw an article that I think was rendering UI pages from auxiliary scripts and passing the input arguments to the URLs for those scripts, and that seemed like a great strategy, but I cannot find the article now and am struggling to figure it out on my own.
It is much simpler in fact. Instead of observing the numeric inputs, you can observe what tab is selected, and update a particular numericInput when the user arrives at that tab. So all we need is to provide an id for the sidebarMenu (id = "tabs", ...) and to observe the contents of this input variable:
observe({
if (req(input$tabs) == "tab2") {
updateSelectInput(...)
}
})
Changing input values with keyboard:
Changing input values with mouse clicking on up arrow:
Changing to tab2 while tab1 is rendering though the list of clicks:
Updated code:
library(shiny)
library(shinydashboard)
ui = dashboardPage(
dashboardHeader(title = "Example"),
dashboardSidebar(
sidebarMenu(id = "tabs",
menuItem("Tab 1", tabName = "tab1", icon = icon("chart-line")),
menuItem("Tab 2", tabName = "tab2", icon = icon("chart-line")),
menuItem("Other Tab", tabName = "tab3", icon = icon("project-diagram"))
)
),
dashboardBody(
tabItems(
# First tab content
tabItem(tabName = "tab1",
# Input first number
numericInput("input1", label = "Input 1", value = 1000, min=1, step=1),
plotOutput("plot1")
),
# Second tab content
tabItem(tabName = "tab2",
# Input second number
numericInput("input2", label = "Input 2", value = 1000, min=1, step=1),
plotOutput("plot2")
),
# Third tab content
tabItem(tabName = "tab3", "Unrelated content")
)
)
)
server = function(input, output, session) {
# some (not so) long computation
long_comp1 <- reactive({
x <- sample(input$input1, size=10000000, replace = TRUE)
y <- sample(input$input1, size=10000000, replace = TRUE)
m <- matrix(x, nrow = 500, ncol=200)
n <- matrix(y, nrow = 200, ncol=500)
p <- n %*% m
p
})
output$plot1 <- renderPlot({
hist(long_comp1(), main = paste("input1 is", input$input1))
})
# some (not so) long computation
long_comp2 <- reactive({
x <- sample(input$input2, size=10000000, replace = TRUE)
y <- sample(input$input2, size=10000000, replace = TRUE)
m <- matrix(x, nrow = 500, ncol=200)
n <- matrix(y, nrow = 200, ncol=500)
p <- n %*% m
p
})
output$plot2 <- renderPlot({
hist(long_comp2(), main = paste("input2 is", input$input2))
})
# Update inputs to match each other
observe({
if (req(input$tabs) == "tab2") {
updateSelectInput(session = session,
inputId = "input2",
selected = input$input1)
}
})
observe({
if (req(input$tabs) == "tab1") {
updateSelectInput(session = session,
inputId = "input1",
selected = input$input2)
}
})
}
shinyApp(ui = ui, server = server)
I've been trying to align dateRangeInput control in R Shiny for a while now(more than 2hours) but still not able to do so. I've also searched Stackoverflow and found solutions that conveniently does the job for other controls, such as textInput or numericInput. But, when it comes to dateRangeInput what I've seen so far fail. Please if someone could help me with this, I'd appreciate. Following is a stand-alone code(also picked up from Stackoverflow):
library("shiny")
ui <- fluidPage(
fluidRow(
column(width = 4,
tags$form(
class="form-horizontal",
tags$div(
class="form-group",
tags$label(class = "col-sm-4 control-label", `for` = "Area1000", "Area"),
column(width = 4, dateRangeInput("date_range", label="", start="1900-01-01",
end ="2099-12-31",
min = "1900-01-01",
max = "2099-12-31"))
)
)
)
)
)
server <- function(input, output) {
}
shinyApp(ui = ui, server = server)
There is already an empty label being created by the dateRangeInput (as documented at: https://shiny.rstudio.com/reference/shiny/1.1.0/dateRangeInput.html)
label: Display label for the control, or NULL for no label.
So if you used dateRangeInput("date_range", label = NULL ... your current code should work.
library("shiny")
ui <- fluidPage(
fluidRow(
column(width = 4,
tags$form(
class="form-horizontal",
tags$div(
class="form-group",
tags$label(class = "col-sm-4 control-label", `for` = "date_range", "Area"),
column(width = 4, dateRangeInput("date_range", label = NULL, start="1900-01-01",
end ="2099-12-31",
min = "1900-01-01",
max = "2099-12-31"))
)
)
)
)
)
server <- function(input, output) {
}
shinyApp(ui = ui, server = server)
I would also change the for declaration to date_range to match the id on the date range input element.
I have a shinydashboard app with two different tab panels. Each tab has different input values and both of them generate a graph when an action button is clicked.
Whenever I switch between these tabs, their respective graphs disappear and input values are reset to default.
I want to keep the tabs in their user modified states (i.e keep both graphs and inputs) even when the user decides to switch between the panels.
Code
library(shiny)
library(shinydashboard)
ui <- fluidPage(
dashboardPage(
dashboardHeader(title = "DASHBOARD"),
dashboardSidebar(
uiOutput("mysidebar"),
),
dashboardBody(
tabsetPanel(type = "tabs", id = "tab",
tabPanel("Tab1", fluid = TRUE, value = 1,plotOutput("A")),
tabPanel("Tab2", fluid = TRUE, value = 2, plotOutput("B"))
)
)
)
)
server <- function(input, output, session){
output$mysidebar <- renderUI({
if(input$tab == 1){
tagList(
sliderInput(inputId = "Sample",
label = "Enter Number of Samples:",
min = 1000, max = 100000,
value = 10000),
fluidRow(
column(6,
actionButton(inputId = "b1", label = "Generate"))
)}
if(input$tab == 2){
tagList(
sliderInput(inputId = "Weight",
label = "Enter Weight:",
value = 100),
fluidRow(
column(6,
actionButton(inputId = "b2", label = "Generate"))
)}
p1<- eventReactive(input$b1, {
#creating a dataframe using input "Sample" in tab1 - Rough example
df <- input$Sample
})
output$SA <- renderPlot({
plot(df)
})
p2 <- eventReactive(input$b2, {
#creating a dataframe using input "Weight" in tab2-- Rough example
df2 <- input$Weight
})
output$A <- renderPlot({
plot(p1())
})
output$B <- renderPlot({
plot(p2())
})
}
I'd much rather you use show and hide functionality within shinyjs package like example below, this way the values will be preserved when you switch between the Tabs
library(shiny)
library(shinyjs)
library(shinydashboard)
ui <- fluidPage(
dashboardPage(
dashboardHeader(title = "DASHBOARD"),
dashboardSidebar(
useShinyjs(),
sliderInput("Sample","Enter Number of Samples:",min = 1000, max = 100000,value = 10000),
sliderInput("Weight","Enter Weight:",min = 1, max = 1000,value = 100),
fluidRow(column(6,actionButton("b1","Generate"),actionButton("b2","Generate")))
),
dashboardBody(
tabsetPanel(type = "tabs", id = "tab",
tabPanel("Tab1", fluid = TRUE, value = 1,plotOutput("A")),
tabPanel("Tab2", fluid = TRUE, value = 2, plotOutput("B"))
)
)
)
)
server <- function(input, output, session){
observe({
if(input$tab == 1){
show("Sample")
show("b1")
hide("Weight")
hide("b2")
}
if(input$tab == 2){
hide("Sample")
hide("b1")
show("Weight")
show("b2")
}
})
p1<- eventReactive(input$b1,{
df <- rnorm(input$Sample)
})
output$SA <- renderPlot({
plot(df)
})
p2 <- eventReactive(input$b2,{
df2 <- rnorm(input$Weight)
})
output$A <- renderPlot({plot(p1())})
output$B <- renderPlot({plot(p2())})
}
shinyApp(ui, server)
The following code keeps the plots and inputs, by using reactiveValues.
library(shiny)
library(shinydashboard)
ui <- dashboardPage(dashboardHeader(title = "DASHBOARD"),
dashboardSidebar(
uiOutput("mysidebar")
),
dashboardBody(
tabsetPanel(type = "tabs", id = "tab",
tabPanel("Tab1", value = 1,plotOutput("SA")),
tabPanel("Tab2", value = 2, plotOutput("SA1"))
)
)
)
server <- function(input, output, session){
slider_react <- reactiveValues(b1=10000, b2 = 100)
observe({
if (input$tab == 1){
output$mysidebar <- renderUI({
tagList(
sliderInput(inputId = "Sample",
label = "Enter Number of Samples:",
min = 1000, max = 100000,
# value = 10000),
value = slider_react$b1),
actionButton(inputId = "b1", label = "Generate"))
})
}
if(input$tab == 2){
output$mysidebar <- renderUI({
tagList(
sliderInput(inputId = "Weight",
label = "Enter Weight:",
min=0, max=1000,
# value = 100),
value = slider_react$b2),
actionButton(inputId = "b2", label = "Generate"))
})
}
})
df_react <- reactiveValues(a1=NULL, a2=NULL)
p1<- observeEvent(input$b1, {
#creating a dataframe using input "Sample" in tab1 - Rough example
df <- runif(input$Sample, 0, 100)
slider_react$b1 = input$Sample
df_react$a1 = df
})
p2 <- observeEvent(input$b2, {
#creating a dataframe using input "Weight" in tab2-- Rough example
df2 <- runif(input$Weight, 0, 100)
slider_react$b2 = input$Weight
df_react$a2 = df2
})
output$SA <- renderPlot({
req(df_react$a1)
plot(df_react$a1)
})
output$SA1 <- renderPlot({
req(df_react$a2)
plot(df_react$a2)
})
}
shinyApp(ui, server)
I want to retrieve the list of inputs in the current shiny session.
We can retrieve the list of inputs using names(input).
I have a uiOutput and based on different conditions I am rendering different types inputs. The current problem I am facing is that when the condition changes the inputs from previous renderUI is also present in the list. Is there a way to get only the inputs in the current session?
To explain my query better I have the following sample code:
library(shiny)
ui <- fluidPage(
sliderInput(inputId = "slider",label = "", min = 1, max = 3, value = 1),
uiOutput("UI"),
actionButton(inputId = "btn", label = "Show Inputs"),
verbatimTextOutput(outputId = "textOp")
)
server <- function(input, output){
observeEvent(input$slider,{
if(input$slider == 1){
output$UI <- renderUI(
textInput("txt1",label = "Slider in position 1")
)
}else if(input$slider == 2){
output$UI <- renderUI(
textInput("txt2",label = "Slider in position 2")
)
}else{
output$UI <- renderUI(
textInput("txt3",label = "Slider in position 3")
)
}
})
observeEvent(input$btn,{
output$textOp <- renderText(
paste0(names(input), ",")
)
})
}
shinyApp(ui = ui, server = server)
In the above code when I first click on action button labelled "Show Input" I get the following text as the output:
btn, slider, txt1,
Now when I move the slider to 2 my output is as follows:
btn, slider, txt1, txt2,
Here txt1 was generated when the slider was at position 1, and this renderUI was overridden by output$UI <- renderUI(textInput("txt2",label = "Slider in position 2")). I want an input list where txt1 is not there. Is there a way to do that?
I came up with kind of a workaround, assuming you dont have any inputs that should take a value of NULL. You could set the values of the inputs, that you wish to remove, to NULL and filter for non - NULLs when you display the names.
library(shiny)
ui <- fluidPage(
tags$script("
Shiny.addCustomMessageHandler('resetValue', function(variableName) {
Shiny.onInputChange(variableName, null);
});
"
),
sliderInput(inputId = "slider",label = "", min = 1, max = 3, value = 1),
uiOutput("UI"),
actionButton(inputId = "btn", label = "Show Inputs"),
verbatimTextOutput(outputId = "textOp")
)
server <- function(input, output, session){
observeEvent(input$slider,{
for(nr in 1:3){
if(nr != input$slider) session$sendCustomMessage(type = "resetValue", message = paste0("txt", nr))
}
})
output$UI <- renderUI(
textInput(paste0("txt", input$slider), label = paste0("Slider in position ", input$slider))
)
global <- reactiveValues()
observe({
inp = c()
for(name in names(input)){
if(!is.null(input[[name]])){
inp <- c(inp, name)
}
}
isolate(global$inputs <- inp)
})
output$textOp <- renderText({
global$inputs
})
}
shinyApp(ui = ui, server = server)