Related
I stuck in printing dynamic slider values. In the following code I tried to print the dynamic slider values but it's not possible.
library(shinydashboard)
library(DT)
ui <- dashboardPage(
dashboardHeader(title = "Dynamic slider"),
dashboardSidebar(
tags$head(
tags$style(HTML('.skin-blue .main-sidebar {
background-color: #666666;
}'))
),
sidebarMenu(
menuItem("Input data", tabName = 'input_data')
),
fileInput(
"file",
"Choose CSV File",
accept = c("text/csv",
"text/comma-separated-values,text/plain",
".csv")
),
checkboxInput("header",
"Header",
value = TRUE),
radioButtons(
"disp",
"Display",
choices = c(Head = "head",
All = "all"),
selected = "head"
),
sliderInput(
inputId = 'slr',
label = 'Slider range',
min = 0,
max = 3,
value = c(0.5,3),
step = 0.5
),
selectInput(
inputId = 'var',
label = 'Variables',
'Names',
multiple = TRUE
),
uiOutput('sliders')
),
dashboardBody(tabItems(
tabItem(tabName = 'input_data',
fluidRow(
box(width = 12,
dataTableOutput('table'),
title = 'Raw data'),
box(width = 6,
verbatimTextOutput('slider1'),
title = 'slider range'),
box(width = 6,
verbatimTextOutput('slider2'),
title = 'dynamic slider value')
)
)
))
)
server <- function(input, output) {
dataset <- reactive({
req(input$file)
read.csv(input$file$datapath,header = input$header)
})
observe(
output$table <- DT::renderDataTable({
if (input$disp == 'head') {
head(dataset())
}
else{
dataset()
}
})
)
observe({
updateSelectInput(inputId = 'var',choices = c(' ',names(dataset())))
})
variables <- reactive({
input$var
})
sli <- reactive({
lapply(1:length(variables()), function(i){
inputName <- variables()[i]
sliderInput(inputName, inputName,
min = 0, max = 1, value = c(0.3,0.7))
})
})
output$sliders <- renderUI({
do.call(tagList,sli())
})
output$slider1 <- renderPrint({
input$slr
})
output$slider2 <- renderPrint({
sli()
})
}
shinyApp(ui = ui, server = server)
Any suggestions will be appreciated, Is there any other method to get dynamic sliders based on selected variables or How can we get the values of the dynamic slider here??
There may be better ways to structure your app, but here is a solution that follows your general approach. There are 4 modifications to what you already have:
There is no need to define the reactive variables when you can just use input$var directly. The proposed solution eliminates this reactive.
Using req(input$var) will prevent components dependent on that selectInput from trying to render when a selection has not been made.
Since input$var defines the id of the dynamic slider, you can use this to retrieve the slider's values (i.e., input[[input$var]]).
Since you have specified "multiple = TRUE", a few nested paste statements are used to create a single string representing the values of all (potentially multiple) dynamic sliders.
The below app includes these modifications, and I believe, achieves what you are trying to accomplish.
library(shinydashboard)
library(DT)
ui <- dashboardPage(
dashboardHeader(title = "Dynamic slider"),
dashboardSidebar(
tags$head(
tags$style(HTML('.skin-blue .main-sidebar {
background-color: #666666;
}'))
),
sidebarMenu(
menuItem("Input data", tabName = 'input_data')
),
fileInput(
"file",
"Choose CSV File",
accept = c("text/csv",
"text/comma-separated-values,text/plain",
".csv")
),
checkboxInput("header",
"Header",
value = TRUE),
radioButtons(
"disp",
"Display",
choices = c(Head = "head",
All = "all"),
selected = "head"
),
sliderInput(
inputId = 'slr',
label = 'Slider range',
min = 0,
max = 3,
value = c(0.5,3),
step = 0.5
),
selectInput(
inputId = 'var',
label = 'Variables',
'Names',
multiple = TRUE
),
uiOutput('sliders')
),
dashboardBody(tabItems(
tabItem(tabName = 'input_data',
fluidRow(
box(width = 12,
dataTableOutput('table'),
title = 'Raw data'),
box(width = 6,
verbatimTextOutput('slider1'),
title = 'slider range'),
box(width = 6,
verbatimTextOutput('slider2'),
title = 'dynamic slider value')
)
)
))
)
server <- function(input, output) {
dataset <- reactive({
req(input$file)
read.csv(input$file$datapath,header = input$header)
})
observe(
output$table <- DT::renderDataTable({
if (input$disp == 'head') {
head(dataset())
}
else{
dataset()
}
})
)
observe({
updateSelectInput(inputId = 'var',choices = c(' ',names(dataset())))
})
sli <- reactive({
lapply(1:length(input$var), function(i){
inputName <- input$var[i]
sliderInput(inputName, inputName,
min = 0, max = 1, value = c(0.3,0.7))
})
})
output$sliders <- renderUI({
req(input$var)
do.call(tagList,sli())
})
output$slider1 <- renderPrint({
input$slr
})
output$slider2 <- renderPrint({
req(input$var)
paste(
sapply(
input$var,
function(x) {
paste(x, paste(input[[x]], collapse = ', '), sep = ': ')
}
),
collapse = '; '
)
})
}
shinyApp(ui = ui, server = server)
I have shiny app example as below. I need to have two selectInput controls and each selectInput only responds when I click on action button.
What I found is the first action Button applyNameFilter does not respond at all. It's not highlighted when hovered over. The second action button applyTimeFilter seems to be OK.
Does anyone know why? It's so weird... I have no clue how to fix that and looking for help here. Thanks a lot.
library(shinydashboard)
library(shiny)
library(shinyWidgets)
library(shinyjs)
library(dplyr)
df = data.frame(Name = c('A', 'B', 'C', 'A', 'B', 'C'),
Year = c('2020', '2020', '2020', '2019', '2019', '2019'),
Value = c(12, 33, 44, 55, 22, 11))
ui <- dashboardPage(
dashboardHeader(title = "Example" ),
dashboardSidebar(
sidebarMenu(
menuItem("tab", tabName = "tab", icon = icon("globe"))
)
),
dashboardBody(
useShinyjs(),
tabItems(
tabItem(tabName = "tab",
div(id = 'timeAllFilters',
box( width=12, background = 'green',
selectizeInput(inputId = 'year',
label='Select Year',
choices = c('', '2020', '2019'),
multiple=FALSE,
options = list(
maxItems = 1,
placeholder = '',
onInitialize = I("function() { this.setValue(''); }"))),
actionBttn(
inputId = 'applyTimeFilter',
label = "Apply",
style = "gradient",
color = "danger",
icon = icon("") ),
actionBttn(
inputId = 'clearTimeFilter',
label = "Clear",
style = "gradient",
color = "danger",
icon = icon("") )
) #box
), #div
div(id = 'nameAllFilters',
dropdown(
tags$h3("Filters"),
selectizeInput(inputId = 'name',
label='Select Name',
choices = c('','A', 'B'),
multiple=FALSE,
options = list(
maxItems = 1,
placeholder = '',
onInitialize = I("function() { this.setValue(''); }"))),
actionBttn(
inputId = 'applyNameFilter',
label = "Apply",
style = "gradient",
color = "danger",
icon = icon("") ),
actionBttn(
inputId = 'clearNameFilter',
label = "Clear",
style = "gradient",
color = "danger",
icon = icon("") )
) #dropdown
), #div
dataTableOutput('table')
) #tabItem
) #tabItems
) #dashboardBody
) #dashboardPage
server <- function(input, output, session) {
df1 = reactive({
input$applyTimeFilter
isolate( df %>% filter(Year %in% input$year) )
})
# clear time filters
observeEvent(input$clearTimeFilter, {
reset("timeAllFilters")
})
df2 = reactive({
input$applyNameFilter
isolate ( df1() %>% filter(Name %in% input$name) )
})
# clear name filters
observeEvent(input$clearNameFilter, {
reset("nameAllFilters")
})
output$table = renderDataTable({
DT::datatable(df2())
})
}
shinyApp(ui = ui, server = server)
The issue appears to be with the actionBttn being inside box(). It works just fine without. Any chance you could find another way to get the same style without box()?
I need to show\hide input and will be great get NULL or empty string if the input not exists, here reproducible example:
ui <-
dashboardPage(
dashboardHeader(
title = 'Test'),
dashboardSidebar(),
dashboardBody(
selectInput(
inputId = 'mainInput',
label = 'Main input',
selected = 'Show',
choices = c('Show', 'Hide')
),
uiOutput(
outputId = 'secondInputUI'
),
actionButton(
inputId = 'thirdInput',
label = 'Check value'
)
)
)
server <- function(input, output, session){
observeEvent(input$mainInput, ignoreNULL = TRUE, {
if (input$mainInput == 'Show')
output$secondInputUI <-
renderUI(
selectInput(
inputId = 'secondInput',
label = 'Second input',
selected = 0,
multiple = FALSE,
choices = c(1, 0)
)
)
else {
output$secondInputUI <-
renderUI(
selectInput(
inputId = 'secondInput',
label = 'Second input',
selected = '',
multiple = TRUE,
choices = c(1, 0)
)
)
# If uncommit - input value don't update and will return latest available before delete input
# output$secondInputUI <-
# NULL
}
})
observeEvent(input$thirdInput, {
showNotification(
session = session,
ui = paste(input$secondInput, collapse = ', '))
})
}
shinyApp(
ui = ui,
server = server)
You can see commented part with setting NULL to uioutput, if it active - shiny return latest available value before clear that ui, so how to deal with that?
I think I understand. You could create a reactive variable that is independent of the UI, because inputs are not updated when the UI element is removed.
library(shiny)
library(shinydashboard)
ui <-
dashboardPage(
dashboardHeader(
title = 'Test'),
dashboardSidebar(),
dashboardBody(
selectInput(
inputId = 'mainInput',
label = 'Main input',
selected = 'Show',
choices = c('Show', 'Hide')
),
uiOutput(
outputId = 'secondInputUI'
),
actionButton(
inputId = 'thirdInput',
label = 'Check value'
)
)
)
server <- function(input, output, session){
secondInputVar <- reactive({
if(input$mainInput == 'Show'){
input$secondInput
} else {
}
})
observeEvent(input$mainInput, ignoreNULL = TRUE, {
if (input$mainInput == 'Show')
output$secondInputUI <-
renderUI(
selectInput(
inputId = 'secondInput',
label = 'Second input',
selected = 0,
multiple = FALSE,
choices = c(1, 0)
)
)
else {
output$secondInputUI <- renderUI({
NULL
})
}
})
observeEvent(input$thirdInput, {
showNotification(
session = session,
ui = paste(secondInputVar(), collapse = ', '))
})
}
shinyApp(
ui = ui,
server = server)
So, I found another solution, the main idea is: update input value in observer for first input, hide second input from observer for the second input. Will be better if I show:
ui <-
dashboardPage(
dashboardHeader(
title = 'Test'),
dashboardSidebar(),
dashboardBody(
selectInput(
inputId = 'mainInput',
label = 'Main input',
selected = 'Show',
choices = c('Show', 'Hide')
),
uiOutput(
outputId = 'secondInputUI'
),
actionButton(
inputId = 'thirdInput',
label = 'Check value'
)
)
)
server <- function(input, output, session){
observeEvent(input$mainInput, {
if (input$mainInput == 'Show')
output$secondInputUI <-
renderUI(
selectInput(
inputId = 'secondInput',
label = 'Second input',
selected = 0,
multiple = FALSE,
choices = c(1, 0)
)
)
else {
output$secondInputUI <-
renderUI(
selectInput(
inputId = 'secondInput',
label = 'Second input',
selected = '',
multiple = TRUE,
choices = c(1, 0)
)
)
}
})
# THE TRICK HERE ####
observeEvent(input$secondInput, ignoreNULL = FALSE, {
if (input$mainInput != 'Show'){
output$secondInputUI <-
renderUI(NULL)
}
})
observeEvent(input$thirdInput, {
showNotification(
session = session,
ui = paste(input$secondInput, collapse = ', '))
})
}
shinyApp(
ui = ui,
server = server)
I have an shinydashboard app, the app get an filter box and a tabset which show a datatatable depending on filter.
I have a reset button which reset the filters whith shinyjs::reset function, and I want to reset also the tableset and showing the complete table or nothing.
I want also to do it for a valuboxes.
My app is like this :
For server interface I have an basic : output$tableprint_A <- DT::renderDataRable ({})
ui :
body <- dashboardBody(
tabItems(
#### First tab item #####
tabItem(tabName = "fpc",
fluidRow(
infoBoxOutput("kpm_inf", width = 6),
infoBoxOutput(outputId = "fpc_inf", width = 6)
),
fluidRow(
box(title = "Variables filter",
shinyjs::useShinyjs(),
id = "side_panel",
br(),
background = "light-blue",
solidHeader = TRUE,
width = 2,
selectInput("aaa", "aaa", multiple = T, choices = c("All", as.character(unique(fpc$aaa))))
br(),
br(),
p(class = "text-center", div(style = "display:inline-block", actionButton("go_button", "Search",
icon = icon("arrow-circle-o-right"))),
div(style = "display:inline-block", actionButton("reset_button", "Reset",
icon = icon("repeat")))),
p(class = 'text-center', downloadButton('dl_fpc', 'Download Data'))),
tabBox(
title = tagList(),
id = "tabset1",
width = 10,
tabPanel(
"A \u2030 ",
DT::dataTableOutput("tableprint_A"),
bsModal(id = 'startupModal', title = 'Update message', trigger = '',
size = 'large',
tags$p(tags$h2("Last update of A : 01/09/2017",
br(), br(),
"Last update of B : 01/09/2017",
br(), br(),
"Last update of C : 01/09/2017",
style = "color:green", align = "center")))
),
tabPanel(
"B % Table",
DT::dataTableOutput("tableprint_B")),
type = "pills"
)
),
fluidRow(
# Dynamic valueBoxes
valueBoxOutput("info_gen", width = 6)
)
I tried this :
observeEvent(input$reset_button, {
output$tableprint_A <- NULL
})
Edit:
I want something like that, but when I action the search button I want it to appear again :
shinyjs::onclick("reset_button",
shinyjs::toggle(id = "tableprint_A", anim = TRUE))
You should try this out:
output$tableprint_A <- renderDataTable({
if(input$reset_button == 1) {
NULL
}else{
datatable(...)
}
})
if the button is clicked then nothing will be displayed, else the datatable is shown.
[EDIT]
library(shiny)
library(DT)
shinyApp(
ui = fluidPage(selectInput("select", "select", choices = unique(iris$Species), multiple = T),
actionButton("go_button", "Search",
icon = icon("arrow-circle-o-right")),
actionButton("reset_button", "Reset",
icon = icon("repeat")),
DT::dataTableOutput('tbl')),
server = function(input, output) {
values <- reactiveValues(matrix = NULL)
observe({
if (input$go_button == 0)
return()
values$matrix <- iris[iris$Species %in% input$select, ]
})
observe({
if (input$reset_button == 0)
return()
values$matrix <- NULL
})
output$tbl = DT::renderDataTable({
datatable(values$matrix, options = list(lengthChange = FALSE))}
)
}
)
I am having a conditionalPanel problem when more than one option is valid.
A part of my code that the user makes two choices in sequence, so that filters are made in the database.
In the first choice, a State will be selected from a list of possibilities. It is important to know that the user can select more than one State.
In the second choice, the City will be selected from a list of possibilities. In this second choice, the user can also select more than one City.
As I said, important information is that the user can select more than one state, so from that multiple choice of states, it should be shown the cities of all selected states.
Everything works fine when the user selects only one state. The problem with my code starts when it selects more than one state, the ConditionalPanel simply disappears (nothing is shown, not even the first option that was already shown). It only appears again when the user removes the selections, keeping only one.
If anyone has a few minutes to help me to sort out this problem I'm facing, I'll be very grateful.
library(shiny)
library(shinydashboard)
library(readr)
state_options <- c("1. Texas", "2. Massachusetts", "3. Colorado")
options_state_texas <- c("Alamo", "Alton", "Angus", "Atlanta", "Aurora",
"Brownsboro", "Premont", "Princeton", "Red Oak",
"Staples", "Texas City")
options_state_massachusetts <- c("Boston", "Cambridge", "Chelsea", "Springfield")
options_state_colorado <- c("Aspen", "Aurora", "Avon", "Cortez", "Denver",
"Vail")
createMainPanel <- function(index_id) {
mainPanel(
width = 12,
tabsetPanel(
tabPanel(
strong("Split"),
br(),
box(
title = strong("State:"),
status = "primary",
width = 3,
collapsible = TRUE,
checkboxGroupInput(
inputId = paste0(index_id, "_state"),
label = NULL,
choices = state_options
)
),
conditionalPanel(
condition = "input.distribution_of_sales_sub_state == '1. Texas'",
box(
title = strong("Cities state 1:"),
status = "primary",
width = 3,
collapsible = TRUE,
checkboxGroupInput(
inputId = paste0(index_id, "_checkbox_city_1"),
label = NULL,
choices = options_state_texas
)
)
),
conditionalPanel(
condition = "input.distribution_of_sales_sub_state == '2. Massachusetts'",
box(
title = strong("Cities state 2:"),
status = "primary",
width = 3,
collapsible = TRUE,
checkboxGroupInput(
inputId = paste0(index_id, "_checkbox_city_2"),
label = NULL,
choices = options_state_massachusetts
)
)
),
conditionalPanel(
condition = "input.distribution_of_sales_sub_state == '3. Colorado'",
box(
title = strong("Cities state 3:"),
status = "primary",
width = 3,
collapsible = TRUE,
checkboxGroupInput(
inputId = paste0(index_id, "_checkbox_city_3"),
label = NULL,
choices = options_state_colorado
)
)
)
)
)
)
}
createTabItem <- function(title, index_id) {
tabItem(
tabName <- paste0(index_id, "_tab"),
h2(title),
createMainPanel(index_id))
}
createBox <- function(session, index_id, opcoes){
updateCheckboxGroupInput(
session,
index_id,
choices = c(opcoes))
}
ui <- dashboardPage(
dashboardHeader(disable = TRUE),
dashboardSidebar(
title = img(src='logo.png', height = 60, width = 180, style = "display: block;
margin-left: auto; margin-right: auto;"),
HTML("<br><br>"),
width = 230,
sidebarMenu(
menuItem(strong("Sales"), tabName = "distribution_of_sales_sub_tab")
)
),
dashboardBody(
tabItems(
createTabItem(strong("Distribution of sales"),
"distribution_of_sales_sub")
)
)
)
server <- function(input, output, session) {
observe({
createBox(session,"distribution_of_sales_sub_state", state_options)
createBox(session,"distribution_of_sales_sub_checkbox_city_1",
options_state_texas)
createBox(session,"distribution_of_sales_sub_checkbox_city_2",
options_state_massachusetts)
createBox(session,"distribution_of_sales_sub_checkbox_city_3",
options_state_colorado)
})
}
shinyApp(ui, server)
You need to change your conditions to
condition = "input.distribution_of_sales_sub_state.includes('1. Texas')",
condition = "input.distribution_of_sales_sub_state.includes('2. Massachusetts')",
condition = "input.distribution_of_sales_sub_state.includes('3. Colorado')",
EDIT: SOLUTION FOR QUESTION IN COMMENTS
This definitely is not the best solution but this should give you what you want and a good start to make it better.
library(shiny)
library(shinydashboard)
library(readr)
state_options <- c("1. Texas", "2. Massachusetts", "3. Colorado")
options_state_texas <- c("Alamo", "Alton", "Angus", "Atlanta", "Aurora",
"Brownsboro", "Premont", "Princeton", "Red Oak",
"Staples", "Texas City")
options_state_massachusetts <- c("Boston", "Cambridge", "Chelsea", "Springfield")
options_state_colorado <- c("Aspen", "Aurora", "Avon", "Cortez", "Denver",
"Vail")
city_options <- c()
createMainPanel <- function(index_id) {
mainPanel(
width = 12,
tabsetPanel(
tabPanel(
strong("Split"),
br(),
box(
title = strong("State:"),
status = "primary",
width = 3,
collapsible = TRUE,
checkboxGroupInput(
inputId = paste0(index_id, "_state"),
label = NULL,
choices = state_options
)
),
conditionalPanel(
condition = "input.distribution_of_sales_sub_state != ''",
uiOutput("city")
)
)
)
)
}
createTabItem <- function(title, index_id) {
tabItem(
tabName <- paste0(index_id, "_tab"),
h2(title),
createMainPanel(index_id))
}
createBox <- function(session, index_id, opcoes){
updateCheckboxGroupInput(
session,
index_id,
choices = c(opcoes))
}
ui <- dashboardPage(
dashboardHeader(disable = TRUE),
dashboardSidebar(
title = img(src='logo.png', height = 60, width = 180, style = "display: block;
margin-left: auto; margin-right: auto;"),
HTML("<br><br>"),
width = 230,
sidebarMenu(
menuItem(strong("Sales"), tabName = "distribution_of_sales_sub_tab")
)
),
dashboardBody(
tabItems(
createTabItem(strong("Distribution of sales"),
"distribution_of_sales_sub")
)
)
)
server <- function(input, output, session) {
output$city <- renderUI({
box(
title = strong("Cities state:"),
status = "primary",
width = 3,
collapsible = TRUE,
checkboxGroupInput(
inputId = paste0("distribution_of_sales_sub", "_checkbox_city_1"),
label = NULL,
choices = cities()
)
)
})
city_options1 <- c()
city_options2 <- c()
city_options3 <- c()
cities <- reactive({
if(c("1. Texas") %in% input$distribution_of_sales_sub_state ){
city_options1<- c(options_state_texas)
}
if (c("2. Massachusetts") %in% input$distribution_of_sales_sub_state) {
city_options2 <- c(options_state_massachusetts)
}
if (c("3. Colorado") %in% input$distribution_of_sales_sub_state ) {
city_options3 <- c(options_state_colorado)
}
city_options <- c(city_options1,city_options2, city_options3)
city_options <- sort(city_options)
})
observe({
createBox(session,"distribution_of_sales_sub_state", state_options)
createBox(session,"distribution_of_sales_sub_checkbox_city_1",
options_state_texas)
createBox(session,"distribution_of_sales_sub_checkbox_city_2",
options_state_massachusetts)
createBox(session,"distribution_of_sales_sub_checkbox_city_3",
options_state_colorado)
})
}
shinyApp(ui, server)
Your code is not reproducible at all, You should take care of that before posting the question.
Well my guess without proper code and data would be to move all your conditions to server.R. So in ui.R you should create for each state: uiOutput("state1") (its for the first conditional state: Texas), then in server.R:
output$state1 <- renderUI({
if(any(input$state == '1. Texas')){
box(
title = strong("Cities state 1:"),
status = "primary",
width = 3,
collapsible = TRUE,
checkboxGroupInput(
inputId = "checkbox_city_1"),
label = NULL,
choices = options_state_texas
)}
else{NULL})