Dynamic number of columns in Shiny - r

I'm writing a Shiny app with fluidRows and I want to create a dynamic number of columns in the app. I can make columns appear and disappear correctly, but I don't know how to also make them resize accordingly. The desired outcome is that all columns have width 4 if there are 3 of them and width 6 if there are 2. The number of possible columns is 2, 3, or 4 so I don't need to account for more variability than that.
I know that I can probably do it by passing the entire column set through renderUI. However, that would require me to define the contents of the columns in server.R and I'd rather avoid that.
See below for a minimal code example of my app:
library(shiny)
ui <- fluidPage(
titlePanel("Dynamic Columns"),
sidebarLayout(
sidebarPanel(
selectInput("column_count", "Number of Columns", 2:4, 2),
submitButton("Go")
),
mainPanel(
fluidRow(
column(3, "This is column 1"),
column(3, "This is column 2"),
conditionalPanel(
condition = "input.column_count >= 3",
column(3, "This is column 3")
),
conditionalPanel(
condition = "input.column_count == 4",
column(3, "This is column 4")
)
)
)
)
)
server <- function(input, output) {}
shinyApp(ui = ui, server = server)

One way might be to alter the css classes using javascript. I wrote a short js script that calculates the width using the selected value (i.e., 2, 3, 4) and the maximum bootstrap.js columns (i.e., 12): 12 / value, and then updates the class with the new width: col-sm-*. I explicitly named which columns should be resized by adding the class target-column. (You can use any name you like. Make sure it is updated in the js function.). The event is trigged by the submit button.
Here's your example with the javascript. (I wrapped the app in tagList).
library(shiny)
ui <- tagList(
fluidPage(
titlePanel("Dynamic Columns"),
sidebarLayout(
sidebarPanel(
selectInput("column_count", "Number of Columns", 2:4, 2),
submitButton("Go")
),
mainPanel(
fluidRow(
column(3, "This is column 1", class = "target-column"),
column(3, "This is column 2", class = "target-column"),
conditionalPanel(
condition = "input.column_count >= 3",
column(3, class = "target-column", "This is column 3")
),
conditionalPanel(
condition = "input.column_count == 4",
column(3, class = "target-column", "This is column 4")
)
)
)
),
tags$script(
type = "text/javascript",
"
const btn = document.querySelector('button[type=submit]');
const input = document.getElementById('column_count');
btn.addEventListener('click', function(event) {
// calculate new width
w = 12 / input.options[input.selectedIndex].value;
console.log('new width', w);
// update classes
const columns = document.querySelectorAll('.target-column');
columns.forEach(function(column) {
column.className = 'col-sm-' + w + ' target-column';
});
})
"
)
)
)
server <- function(input, output) {}
shinyApp(ui = ui, server = server)

Related

How to create a sidebar navigation menu inside a single tabPanel in a navbarPage in shiny?

So I have a shiny app that is a navbarPage, and I want to create a sidebar navigation menu inside only one of the pages.
I have two columns, each with text and input/action/download buttons, and what I aiming at is to have two buttons on the sidebar which get as output one of my two columns.
Basically, currently they appear at the same time, side by side, and I want them to appear one at a time, by clicking one of two sidebar tab buttons.
I'm really sorry if I'm being confusing, I'm doing my best
Here is my tabPanel with the two columns:
navbarPage(
tabPanel(title="Download two different tsv files",
######## FIRST COLUMN IN MY tabPanel
fluidRow(
column(6,align="center", tags$strong("Download tsv file number one"),
textInput(inputId="input1",tags$strong("Enter the name of the set of data you want to download"),placeholder="Example: something"),
downloadBttn("downloadData","Download tsv 1")
)),
####### SECOND COLUMN
fluidRow(
column(6,align="center", tags$strong("Download tsv file number two"),
downloadBttn('downloadData2','Download tsv 2')))
)
)
I suspect I might need to use something like tabsetPanel, or on the other hand just move around with sidebarPanel and mainPanel, but I'm pretty lost and wondering if someone has any idea how to do this
Thanks in advance for any answers
Not sure this covers your case completely (a drawing of the desired layout would have been very helpful), but here is an app with a sidebar layout in one tab and dynamic show/hide for contents in two columns. Note that it uses shinyWidgets::checkboxGroupButtons instead of regular actionButton or actionBttn.
library(shiny)
library(shinyWidgets)
ui <-
navbarPage(title = "T I T L E",
tabPanel(title = "Download two different tsv files",
sidebarLayout(
sidebarPanel(
width = 2,
checkboxGroupButtons(inputId = "show",
label = "Show column:",
choices = c("Column 1", "Column 2"))
),
mainPanel(
fluidRow(
column(6,
uiOutput("col1")),
column(6,
uiOutput("col2"))
)
)
)
),
tabPanel(title = "Tab 2")
)
server <- function(input, output, session) {
col1 <- reactive({
if ("Column 1" %in% input$show) {
x <- tagList(
h4("Stuff for first column"),
actionButton('btn1', 'Button for column 1')
)
} else {
x <- div()
}
x
})
output$col1 <- renderUI({
col1()
})
col2 <- reactive({
if ("Column 2" %in% input$show) {
x <- tagList(
h4("Stuff for second column"),
actionButton('btn2', 'Button for column 2')
)
} else {
x <- div()
}
x
})
output$col2 <- renderUI({
col2()
})
}
shinyApp(ui, server)

Text output with a label or non-editable text input

I'm a Shiny newbie and I have probably a simple question, but I swear I spent half day reading solutions here and can't find anything close to what I need.
Imaging you have a database with employees ID, name, last name, age.
I need to have in my app a text input that allows the user to enter the ID and to see on the same row the name, last name and age.
The problem I face is that textInput will have a label (say "ID").
All the three other fields, that I need to be on the same row, won't have a label.
So what I would need is either a way to add a label to the three textOutput elements or to display them as textInput with a default value that has to change/behave like an output as soon as a user enters a new ID. But how?
This is my sample code:
library(shiny)
u <- fluidPage(
titlePanel("Simple Selectable Reactive Function"),
sidebarLayout(
sidebarPanel(),
mainPanel(
h2("Results"),
fluidRow(column(2,
textInput("input_ID", label = "Cusip 1",
value = "123")),
column(2,
textOutput(outputId = "output_name")),
column(2,
textOutput(outputId = "output_lastname")),
column(2,
textOutput(outputId = "output_age"))
)
)
)
)
s <- function(input,output){
output$output_name <- renderText(
{ # here is where I will check in a database
paste("Sample Name")
})
output$output_lastname <- renderText(
{ # here is where I will check in a database
paste("Sample Last Name")
})
output$output_age <- renderText(
{ # here is where I will check in a database
paste("Sample Age")
})
}
shinyApp(ui=u,server=s)
Perhaps I have to use different widgets?
Thank you
I updated the code to change the label using an textInput as suggested in the comment. Perhaps it helps to understand exactly what you are looking for.
library(dplyr)
library(shiny)
library(shinyjs)
u <- fluidPage(
titlePanel("Simple Selectable Reactive Function"),
sidebarLayout(
sidebarPanel(),
mainPanel(
h2("Results"),
fluidRow(
column(2, textInput("input_ID", label = "Cusip 1",value = "123")),
column(2, textInput("output_name", label = "Firstname") %>% disabled()),
column(2, textInput("output_lastname", label = "Lastname") %>% disabled()),
column(2, textInput("output_age", label = "Age") %>% disabled())))))
s <- function(input,output, session){
observe({
id <- input$input_ID
set.seed(id)
df <- list(firstname = sample(LETTERS, 1), lastname = sample(LETTERS, 1), age = sample(1:100, 1))
updateTextInput(session, inputId = "output_name", label = df[["firstname"]])
updateTextInput(session, inputId = "output_lastname", label = df[["lastname"]])
updateTextInput(session, inputId = "output_age", label = df[["age"]])
})
}
shinyApp(ui=u,server=s)
How I create label for my UI is simply adding a h3 tag above each textoutput:
library(shiny)
u <- fluidPage(
titlePanel("Simple Selectable Reactive Function"),
sidebarLayout(
sidebarPanel(),
mainPanel(
h2("Results"),
fluidRow(column(2,
textInput("input_ID", label = "Cusip 1",
value = "123")),
column(2,
h3("First Name: "),
textOutput(outputId = "output_name")),
column(2,
h3("Last Name: "),
textOutput(outputId = "output_lastname")),
column(2,
h3("Age: ),
textOutput(outputId = "output_age"))
)
)
)
)

R Shiny - Multiple radioButtons with same id / adding headers to groups of radioButtons

WHAT I AM TRYING TO ACHIEVE:
Add different headers on the different groups of radio buttons. I did it by creating two radioButtons widgets with the same id and different labels.
PROBLEM:
When I run the script, Option D is selected and corresponding output show. WELL AND GOOD
When I select any other option, it is selected and corresponding output show. AGAIN WELL AND GOOD
*When I try to select Option D again, it gets selected BUT the corresponding output does not show in the main panel. *
MWE:
library(shiny)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
width = 3,
radioButtons("aspect","Structure",
choices = list("Option A" = "size",
"Option B" = "coh",
"Option C" = "bound")
),
hr(),
radioButtons("aspect","Composition",
choices = list("Option D" = "div")
)
),
mainPanel(
width = 9,
fluidRow(
h3(textOutput("aboutText"))
)
)
)
)
server <- function (input, output){
aspectDesc <- reactive({
switch(input$aspect,
size = "Alpha",
coh = " Beta",
bound = "Charlie",
div = "Delta")
})
output$aboutText <- renderText({paste("Text about ", aspectDesc())})
}
shinyApp(ui = ui, server = server)
WHAT I HAVE TRIED
I removed the second RadioButtons widget and moved Option D to the first widget. It works fine. But I can not add the different headers.
I have looked up how to group different radioButtons together but could not find anything substantial
I set up the same id on two different radioButtons( which I did by accident) and at least I could select ONLY one option ( the way I wanted it).
I am totally at a loss what I am missing out. Although it seems to be a trivial issue.
Any help would be highly appreciated!
After some labor, I've found this solution.
library(shiny)
library(shinyjs)
ui <- fluidPage(
useShinyjs(),
sidebarLayout(
sidebarPanel(
width = 3,
radioButtons("aspect1","Structure",
choices = list("Option A" = "size",
"Option B" = "coh",
"Option C" = "bound"),
selected = character(0)
),
hr(),
radioButtons("aspect2","Composition",
choices = list("Option D" = "div")
)
),
mainPanel(
width = 9,
fluidRow(
h3(textOutput("aboutText"))
)
)
)
)
server <- function (input, output, session){
aspectDesc <- reactiveVal("Delta")
onclick("aspect1", {
updateRadioButtons(session, "aspect2", choices = list("Option D" = "div"),
selected = character(0))
aspectDesc(switch(input$aspect1,
size = "Alpha",
coh = " Beta",
bound = "Charlie"))
})
onclick("aspect2",{
updateRadioButtons(session, "aspect1",
choices = list("Option A" = "size",
"Option B" = "coh",
"Option C" = "bound"),
selected = character(0))
aspectDesc("Delta")
})
output$aboutText <- renderText({paste("Text about ", aspectDesc())})
}
shinyApp(ui = ui, server = server)

R shiny conditionalPanel displaying both conditions

I am trying to a multi tab app, I want the the second tab's page layout to be conditional on an input from the first panel. Basically if the value in the first panel is 1 I want the second panel to display 1 set of file inputs if the user puts in the value 2 in the first panel then I want the second panel to display 2 file inputs. Currently my code displays both conditions, and I am unsure why. See the reproducible code below.
ui =
navbarPage("Page Title",
tabPanel("Panel 1",
sidebarPanel(
## Add Name,
## Number of surveys analysising
numericInput("n_values", "Number of columns in next panel:", 1, min = 1, max = 2)
),
mainPanel(
tags$div(
h2("Home Page")
)
)
),
tabPanel("Panel 2",
conditionalPanel(condition = "input.n_values == 1",
fixedPage(theme = "flatly",
fixedRow(
column(2,"First Column",
fileInput("File1", "Choose a CSV files",accept = c("text/csv","text/comma-separated-values",".csv"), multiple = F),
p("Click the button to check the data was read in correctly")
),
fixedRow(
column(12,
verbatimTextOutput("errorText")
)
)
)
)
),
conditionalPanel(condition = "input.n_values == 2",
fixedPage(theme = "flatly",
fixedRow(
column(2,"First Column",
fileInput("File1", "Choose a CSV files",accept = c("text/csv","text/comma-separated-values",".csv"), multiple = F),
p("Click the button to check the data was read in correctly")
),
column(2,"Second Column",
fileInput("File2", "Choose a CSV files",accept = c("text/csv","text/comma-separated-values",".csv"), multiple = F),
p("Click the button to check the data was read in correctly")
),
fixedRow(
column(12,
verbatimTextOutput("errorText")
)
)
)
)
)
)
)
server = function(input, output,session) {
## Call the error message function and print
output$errorText <- renderText({
validate(
need(!is.null(input$File1)
, 'You need to input the files before we can validate the data. Please select all the necessary files.')
)
})
}
shinyApp(ui, server)
That's because you have verbatimTextOutput("errorText") twice in your UI. You can't do that in Shiny. An output must be included at one place only.

Shiny reactiveUI hangs with multiple uiOutput calls on same condition variable

I am trying to make a reactive UI with sliders that drop in and out via a dropdown in shiny. I have a server with reactiveUI sliders (server.R):
library(shiny)
shinyServer(function(input, output) {
output$slider1 <- reactiveUI(function() {
sliderInput("s1", "slide 1", min = 1, max = 100, value = 1)
})
output$slider2 <- reactiveUI(function() {
sliderInput("s2", "slide 2", min = 1, max = 100, value = 1)
})
})
I can run the server fine with the following code (ui.R):
library(shiny)
shinyUI(pageWithSidebar(
headerPanel("Hello Shiny!"),
sidebarPanel(
selectInput("dataset", "number of buckets:",
choices = c(1,2,3)),
conditionalPanel(
condition = "input.dataset==2",
uiOutput("slider1"),uiOutput("slider2")),
conditionalPanel(
condition = "input.dataset==1",
sliderInput("s1", "slide 1", min = 1, max = 100, value = 1)
)
),
mainPanel(
)
))
but if I try to make both conditionalPanels call uiOutput, the server freezes:
library(shiny)
shinyUI(pageWithSidebar(
headerPanel("Hello Shiny!"),
sidebarPanel(
selectInput("dataset", "number of buckets:",
choices = c(1,2,3)),
conditionalPanel(
condition = "input.dataset==2",
uiOutput("slider1"),uiOutput("slider2")),
conditionalPanel(
condition = "input.dataset==1",
uiOutput("slider1")
)
),
mainPanel(
)
))
I have played around with this, and found that it happens anytime that use the same condition variable and multiple uiOutput calls. Any suggestions? Thanks.
See the comment from #Joe for the answer.
Basically, outputIDs and inputIDs have to be unique; two UI elements with the same IDs on the same page emits and error. This is a limitation of the reactivity in shiny.
The work around from #Jim is to create multiple elements for each output or input used by the client, e.g.
output$slider2_1 <- ...
output$slider2_2 <- ...

Resources