I'm trying to get 2 Select all filters to work together in the example below; The logic works fine for 1 filter.
##CREATE DATA
Director <- c("dir1", "dir1","dir1", "dir2", "dir2", "dir3", "dir3", "dir3")
Manager <- c("mgr1", "mgr","mgr3", "mgr4", "mgr5", "mgr6", "mgr7", "mgr8")
df <- data.frame(Director, Manager)
df$Sales <- sample(100, size = nrow(df), replace = TRUE)
director_choices = c("All", c(as.character(unique(df$Director))))
manager_choices = c("All", c(as.character(unique(df$Manager))))
ui <- dashboardPage(
# Application title
dashboardHeader(title = "Sales"),
# Sidebar with a slider input
dashboardSidebar(
sidebarMenu(
menuItem("Maps",
tabName = "Maps",
icon = icon("dashboard")),
hr(),
selectInput("Director", "Director", choices = director_choices, multiple = T, selected = "All"),
selectInput("Manager", "Manager", choices = manager_choices, multiple = T)
The filter below gets me the correct filtering just at the director level, my goal is to have a select all filter at the manager level that reacts to the director filer.
server <- function(input, output, session) {
observe({
if("All" %in% input$Director)
selected_choices = Director[-1]
else
selected_choices = input$Director
updateSelectInput(session, "Director", selected = selected_choices)
})
# Run the application
shinyApp(ui = ui, server = server)
You don't need to update the first selectInput. Just the second one should suffice. Try this.
##CREATE DATA
Director <- c("dir1", "dir1","dir1", "dir2", "dir2", "dir3", "dir3", "dir3")
Manager <- c("mgr1", "mgr2","mgr3", "mgr4", "mgr5", "mgr6", "mgr7", "mgr8")
df <- data.frame(Director, Manager)
df$Sales <- sample(100, size = nrow(df), replace = TRUE)
director_choices = c("","All", c(as.character(unique(df$Director))))
manager_choices = c(as.character(unique(df$Manager)))
ui <- dashboardPage(
# Application title
dashboardHeader(title = "Sales"),
# Sidebar with a slider input
dashboardSidebar(
sidebarMenu(
menuItem("Maps",
tabName = "Maps",
icon = icon("dashboard")),
hr(),
selectInput("Director", "Director", choices = director_choices, multiple = T, selected = "All"),
selectInput("Manager", "Manager", choices = manager_choices, multiple = T)
)
),
dashboardBody()
)
server <- function(input, output, session) {
observe({
df1 <- df[df$Director %in% input$Director,]
if (is.null(input$Director)) {selected_choices = ""
}else if("All" %in% input$Director) {selected_choices = manager_choices
}else selected_choices = unique(df1$Manager)
updateSelectInput(session, "Manager", choices = selected_choices)
})
}
# Run the application
shinyApp(ui = ui, server = server)
Related
I have the shiny app below in which I want when the user ticks on a value on one of the 3 widgets, regardless of which will click on first,this value will automatically be hidden from the other 2 widgets.
## app.R ##
library(shiny)
library(shinydashboard)
library(shinyWidgets)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
uiOutput("sil1"),
uiOutput("sil2"),
uiOutput("sil4")
),
dashboardBody(
)
)
server <- function(session,input, output) {
output$sil1<-renderUI({
pickerInput( "si1", label = "Select target country",choices = colnames(iris)[-c(1)])
})
output$sil2<-renderUI({
ex_names <- colnames(iris)[-c(1)]
ex_names <- ex_names[!ex_names %in% input$si1]
pickerInput( "si2", label = "Select reference country",multiple = T, options = list(`actions-box` = TRUE), choices = ex_names)
})
output$sil4<-renderUI({
ex_names <- colnames(iris)[-c(1)]
ex_names <- ex_names[!ex_names %in% input$si1&!ex_names %in% input$si2]
pickerInput( "si4", label = "Select additional countries",multiple = T, options = list(`actions-box` = TRUE), choices =ex_names)
})
}
shinyApp(ui, server)
I need the "send" button to send all app info to a spreadsheet saved in Google Drive (not just the first info); each for a column (Name, Age, Birth...). Thanks!
This is my code:
library(shiny)
library(shinydashboard)
library(shinyWidgets)
library(googlesheets4)
library(googledrive)
library(readr)
library(DT)
# Dashboard
ui <- dashboardPage(skin = "red",
dashboardHeader(
title = "Controller"
),
dashboardSidebar(
sidebarMenu(
menuItem(
"Home",
tabName = "home",
icon = icon("home"))
)
),
dashboardBody(
tabItems(
tabItem(
tabName = "home", h2("Hello"),
br(),
box(
h2(icon("id-card"), "Client"),
width = 2000,
br(),
# Insery name
textInputIcon(
inputId = "name",
label = "Name"),
# Birth
dateInput(
inputId = "dob",
label ="Birth",
min = "1960-01-01",
max = Sys.Date(), format = "yyyy/mm/dd",
language = "en"),
textInputIcon(
inputId = "age",
label = "Age"),
# Phone
textInputIcon(
inputId = "phone",
label = "Phone"),
# E-mail
textInputIcon(
inputId = "email",
label = "E-mail"),
# Send
actionButton("send", "Send"),
)
)
)
)
)
# Server
server <- function(input, output, session) {
textname <- reactive({
as.data.frame(input$name)
})
observeEvent(input$sendname, {
Selfie <- gs4_get('link')
sheet_append(Selfie, data = textname())
})
observe({ dob <- input$dob
if(!is.null(dob)) {
days <- as.integer((Sys.Date() - as.Date(dob)))
years <- as.integer(days / 365)
months <- as.integer((days %% 365 ) / 30)
age <- paste(years, 'year(s)', months, 'month(s)')
#print(age)
updateTextInput(session, "age", value = age)
}
})
}
# App
shinyApp(ui = ui, server = server)
We can loop through input and gather everything in a df.
observeEvent(input$send, {
require(tidyverse)
#gather info of all the relevant inputs
client_df <- c('name', 'dob', 'age', 'phone', 'email') %>%
map_dfc(~ tibble("{.x}" := input[[.x]]))
print(client_df) #this will print a df with one row in the console
#Selfie <- gs4_get('link')
#sheet_append(Selfie, data = client_df)
})
I designed a Shiny app with a DT that can detect if the input fields changes and automatically update the values. Below is a screen shot and my code. This app works as I expected. When running this app, values are updated accordingly in DT based on the input values.
# Load the packages
library(tidyverse)
library(shiny)
library(DT)
# Create an empty data frame
dat <- tibble(
Input = c("SliderInput", "RadioButtons", "TextInput"),
Value = NA_character_
)
ui <- fluidPage(
titlePanel("DT: Document the Input Values"),
sidebarLayout(
sidebarPanel = sidebarPanel(
# The input widgets
sliderInput(inputId = "Slider", label = "The SliderInput", min = 1, max = 10, value = 5),
br(),
radioButtons(inputId = "Radio", label = "The RadioButtons", choices = c("A", "B", "C")),
br(),
textInput(inputId = "Text", label = "The TextInput", value = "Enter text ...")
),
mainPanel = mainPanel(
# The datatable
DTOutput(outputId = "d1")
)
)
)
server <- function(input, output, session){
# Save the dat to a reactive object
dat_save <- reactiveValues(df = dat)
output$d1 <- renderDT(dat, options = list(pageLength = 5), editable = TRUE, rownames = TRUE)
# Save the condition of the data table d1
d1_proxy <- dataTableProxy("d1")
# Edit the data table
observeEvent(input$d1_cell_edit, {
dat_save$df <- editData(dat_save$df, input$d1_cell_edit, d1_proxy)
})
# Update the input numbers for each cell
observeEvent(input$Slider, {
dat_save$df[1, "Value"] <- as.character(input$Slider)
})
observeEvent(input$Radio, {
dat_save$df[2, "Value"] <- input$Radio
})
observeEvent(input$Text, {
dat_save$df[3, "Value"] <- input$Text
})
observe({
replaceData(d1_proxy, dat_save$df, resetPaging = FALSE)
})
}
shinyApp(ui, server)
However, when I transferred the same code to a shinydahsboard with more than one tab. The DT cannot update the values when first initialize the app. Below is a screenshot and the code.
# Load the packages
library(tidyverse)
library(shiny)
library(shinydashboard)
library(DT)
# Create an empty data frame
dat <- tibble(
Input = c("SliderInput", "RadioButtons", "TextInput"),
Value = NA_character_
)
ui <- function(request) {
dashboardPage(
# The header panel
header = dashboardHeader(title = ""),
# The sidebar panel
sidebar = dashboardSidebar(
# The sidebar manual
sidebarMenu(
id = "tabs",
# Tab 1
menuItem(
text = "Tab1",
tabName = "Tab1"
),
# Tab 2
menuItem(
text = "DT Example",
tabName = "DT_E"
)
)),
# The main panel
body = dashboardBody(
tabItems(
tabItem(
# The tab name
tabName = "Tab1",
h2("Placeholder")
),
# Tab 2: DT example
tabItem(
# The tab name
tabName = "DT_E",
h2("DT: Document the Input Values"),
sidebarPanel(
# The input widgets
sliderInput(inputId = "Slider", label = "The SliderInput", min = 1, max = 10, value = 5),
br(),
radioButtons(inputId = "Radio", label = "The RadioButtons", choices = c("A", "B", "C")),
br(),
textInput(inputId = "Text", label = "The TextInput", value = "Enter text ...")
),
# The datatable
DTOutput(outputId = "d1")
)
)
)
)
}
server <- function(input, output, session){
# Save the dat to a reactive object
dat_save <- reactiveValues(df = dat)
output$d1 <- renderDT(dat, options = list(pageLength = 5), editable = TRUE, rownames = TRUE)
# Save the condition of the data table d1
d1_proxy <- dataTableProxy("d1")
# Edit the data table
observeEvent(input$d1_cell_edit, {
dat_save$df <- editData(dat_save$df, input$d1_cell_edit, d1_proxy)
})
# Update the input numbers for each cell
observeEvent(input$Slider, {
dat_save$df[1, "Value"] <- as.character(input$Slider)
})
observeEvent(input$Radio, {
dat_save$df[2, "Value"] <- input$Radio
})
observeEvent(input$Text, {
dat_save$df[3, "Value"] <- input$Text
})
observe({
replaceData(d1_proxy, dat_save$df, resetPaging = FALSE)
})
}
shinyApp(ui, server)
Notice that if there is only one tab in the shinydashboard, the DT will work. If changed any input values after initializing the app, the DT will also work. But it is a mystery to me why the DT cannot work in the first place when the shinydashboard has multiple tabs. Any suggestions or comments would be great.
After further search, I found a solution from this post and this post. For some reasons, the default setting for shinydashboard is to ignore hidden objects starting the second tab. In my case, adding outputOptions(output, "d1", suspendWhenHidden = FALSE) solves the issue. Below is the complete code.
# Load the packages
library(tidyverse)
library(shiny)
library(shinydashboard)
library(DT)
# Create an empty data frame
dat <- tibble(
Input = c("SliderInput", "RadioButtons", "TextInput"),
Value = NA_character_
)
ui <- function(request) {
dashboardPage(
# The header panel
header = dashboardHeader(title = ""),
# The sidebar panel
sidebar = dashboardSidebar(
# The sidebar manual
sidebarMenu(
id = "tabs",
# Tab 1
menuItem(
text = "Tab1",
tabName = "Tab1"
),
# Tab 2
menuItem(
text = "DT Example",
tabName = "DT_E"
)
)),
# The main panel
body = dashboardBody(
tabItems(
tabItem(
# The tab name
tabName = "Tab1",
h2("Placeholder")
),
# Tab 2: DT example
tabItem(
# The tab name
tabName = "DT_E",
h2("DT: Document the Input Values"),
sidebarPanel(
# The input widgets
sliderInput(inputId = "Slider", label = "The SliderInput", min = 1, max = 10, value = 5),
br(),
radioButtons(inputId = "Radio", label = "The RadioButtons", choices = c("A", "B", "C")),
br(),
textInput(inputId = "Text", label = "The TextInput", value = "Enter text ...")
),
# The datatable
DTOutput(outputId = "d1")
)
)
)
)
}
server <- function(input, output, session){
# Save the dat to a reactive object
dat_save <- reactiveValues(df = dat)
output$d1 <- renderDT(dat, options = list(pageLength = 5), editable = TRUE, rownames = TRUE)
outputOptions(output, "d1", suspendWhenHidden = FALSE)
# Save the condition of the data table d1
d1_proxy <- dataTableProxy("d1")
# Edit the data table in tab 3
observeEvent(input$d1_cell_edit, {
dat_save$df <- editData(dat_save$df, input$d1_cell_edit, d1_proxy)
})
# Update the input numbers for each cell
observeEvent(input$Slider, {
dat_save$df[1, "Value"] <- as.character(input$Slider)
})
observeEvent(input$Radio, {
dat_save$df[2, "Value"] <- input$Radio
})
observeEvent(input$Text, {
dat_save$df[3, "Value"] <- input$Text
})
observe({
replaceData(d1_proxy, dat_save$df, resetPaging = FALSE)
})
}
shinyApp(ui, server)
Is is possible to make the tabs interactive for the below code. So, only when I select "B" from the dropdown, Tab B should be open
library(shinydashboard)
library(readxl)
ui <- dashboardPage(
dashboardHeader(title = "Loading data"),
dashboardSidebar(fileInput("datafile","Choose the csv file",multiple = TRUE,
accept = c("text/csv","text/comma-separated-values,text/plain",".csv")),
("Or"),
fileInput("datafile1","Choose the excel file",multiple = TRUE,
accept = c(".xlsx")),
selectInput("S","Select Tabs",choices = c("A","B"))),
dashboardBody(
tabBox(fluidRow(title = "Dataset",uiOutput("filter_70"),width = 5000),fluidRow(title="B"))
))
server <- function(input,output){
}
shinyApp(ui, server)
Here is an example of using tab controls in Shiny.
library(shiny)
library(shinydashboard)
library(tidyverse)
library(magrittr)
header <- dashboardHeader(
title = "My Dashboard",
titleWidth = 500
)
siderbar <- dashboardSidebar(
sidebarMenu(
# Add buttons to choose the way you want to select your data
radioButtons("select_by", "Select by:",
c("Food Type" = "Food",
"Gym Type" = "Gym",
"TV show" = "TV"))
)
)
body <- dashboardBody(
fluidRow(
uiOutput("Output_panel")
),
tabBox(title = "RESULTS", width = 12,
tabPanel("Visualisation",
width = 12,
height = 800
)
)
)
ui <- dashboardPage(header, siderbar, body, skin = "purple")
server <- function(input, output, session){
nodes_data_1 <- data.frame(id = 1:15,
Food = as.character(c("Edibles", "Fried", "Home Cooked", "packaged", "vending machine")),
Product_name = as.character(c("Bacon", "Cheese", "eggs", "chips", "beans", "oast", "oats and beans", "fried beans", "chickpeas", "broad beans", "garbanzo", "oat bars", "dog meat", "cat food", "horse meat")),
Gym_type = as.character(paste("Gym", 1:15)), TV =
sample(LETTERS[1:3], 15, replace = TRUE))
# build a edges dataframe
edges_data_1 <- data.frame(from = trunc(runif(15)*(15-1))+1,
to = trunc(runif(15)*(15-1))+1)
# create reactive of nodes
nodes_data_reactive <- reactive({
nodes_data_1
}) # end of reactive
# create reacive of edges
edges_data_reactive <- reactive({
edges_data_1
}) # end of reactive
# The output panel differs depending on the how the data is selected
# so it needs to be in the server section, not the UI section and created
# with renderUI as it is reactive
output$Output_panel <- renderUI({
# When selecting by workstream and issues:
if(input$select_by == "Food") {
box(title = "Output PANEL",
collapsible = TRUE,
width = 12,
do.call(tabsetPanel, c(id='t',lapply(1:length(unique(nodes_data_reactive()$Food)), function(i) {
food <- unique(sort(as.character(nodes_data_reactive()$Food)))
tabPanel(food[i],
checkboxGroupInput(paste0("checkboxfood_", i),
label = NULL,
choices = nodes_data_reactive() %>%
filter(Food == food[i]) %>%
select(Product_name) %>%
unlist(use.names = FALSE)),
checkboxInput(paste0("all_", i), "Select all", value = TRUE)
)
})))
) # end of Tab box
# When selecting by the strength of links connected to the issues:
} else if(input$select_by == "Gym") {
box(title = "Output PANEL", collapsible = TRUE, width = 12,
checkboxGroupInput("select_gyms", "Select gyms you want to display", choices = unique(nodes_data_reactive()$Gym_type)
,
selected = NULL,
inline = FALSE
)# end of checkboxGroupInput
) # end of box
} else if(input$select_by == "TV") {
box(title = "Output PANEL", collapsible = TRUE, width = 12,
checkboxGroupInput("select_tvs",
"Select the tv shows you want to see",choices = sort(unique(nodes_data_reactive()$TV)),
selected = NULL,
inline = FALSE
)# end of checkboxGroupInput
) # end of box
} # end of else if
}) # end of renderUI
observe({
lapply(1:length(unique(nodes_data_reactive()$Food)), function(i) {
food <- unique(sort(as.character(nodes_data_reactive()$Food)))
product_choices <- nodes_data_reactive() %>%
filter(Food == food[i]) %>%
select(Product_name) %>%
unlist(use.names = FALSE)
if(!is.null(input[[paste0("all_", i)]])){
if(input[[paste0("all_", i)]] == TRUE) {
updateCheckboxGroupInput(session,
paste0("checkboxfood_", i),
label = NULL,
choices = product_choices,
selected = product_choices)
} else {
updateCheckboxGroupInput(session,
paste0("checkboxfood_", i),
label = NULL,
choices =product_choices)
}
}
})
})
} # end of server
# Run the application
shinyApp(ui = ui, server = server)
Now, if you want to use Shiny to import datasets and have some tab controls to select different views, you can do it this way.
library(shiny)
library(ggplot2)
#ui.R
ui <- fluidPage(
titlePanel("My shiny app"), sidebarLayout(
sidebarPanel(
helpText("This app shows how a user can upload a csv file. Then, plot the data.
Any file can be uploaded but analysis is only available
if the data is in same format as the sample file, downloadable below
"),
a("Data to be plotted", href="https://www.dropbox.com/s/t3q2eayogbe0bgl/shiny_data.csv?dl=0"),
tags$hr(),
fileInput("file","Upload the file"),
h5(helpText("Select the read.table parameters below")),
checkboxInput(inputId = 'header', label = 'Header', value = TRUE),
checkboxInput(inputId = "stringAsFactors", "stringAsFactors", FALSE),
br(),
radioButtons(inputId = 'sep', label = 'Separator', choices = c(Comma=',',Semicolon=';',Tab='\t', Space=''), selected = ',')
),
mainPanel(
uiOutput("tb"),
plotOutput("line")
)
)
)
#server.R
server <- function(input,output){
data <- reactive({
file1 <- input$file
if(is.null(file1)){return()}
read.table(file=file1$datapath, sep=input$sep, header = input$header, stringsAsFactors = input$stringAsFactors)})
output$filedf <- renderTable({
if(is.null(data())){return ()}
input$file
})
output$sum <- renderTable({
if(is.null(data())){return ()}
summary(data())
})
output$table <- renderTable({
if(is.null(data())){return ()}
data()
})
output$line <- renderPlot({
if (is.null(data())) { return() }
print(ggplot(data(), aes(x=date, y=aa)) + geom_line()+ facet_wrap(~station)) })
output$tb <- renderUI({if(is.null(data()))
h5()
else
tabsetPanel(tabPanel("About file", tableOutput("filedf")),tabPanel("Data", tableOutput("table")),tabPanel("Summary", tableOutput("sum")))
})
}
shinyApp(ui = ui, server = server)
I am working on a Shiny App that uses rhandsontable and I would like to provide the user an option to save and load the progress. A minimal example of my code is as follows:
library(shinydashboard)
library(shiny)
library(data.table)
library(rhandsontable)
library(markdown)
sidebar <- dashboardSidebar(
sidebarMenu(
menuItem("Data", tabName = "data", icon = icon("file")),
menuItem("Control", tabName = "control", icon = icon("list-alt"))
)
)
body <- dashboardBody(
tabItems(
tabItem(tabName = "data",
fluidRow(
box(title = h3("Input data manually or by importing a .csv file:"),
#fileInput("file1", "Choose CSV File:", width = '30%',
# multiple = TRUE,
# accept = c("text/csv",
# "text/comma-separated-values,text/plain",
# ".csv")),
width = 12, height = 800, rHandsontableOutput("hot"))
)
),
tabItem(tabName = "control",
fluidRow(
actionButton("save", "Save"), actionButton("load", "Load"),
box(title = h2("1. General Information"), width = '100%',
radioButtons("Type",
h4("Type:"),
choices = list("1" = "1", "2" = "2")),
radioButtons("DataExtraction",
h4("Extract information:"),
choices = list("Yes" = "Yes", "No" = "No"), selected = "No")
)
)
)
)
)
ui <- dashboardPage(
dashboardHeader(title = "Shiny"),
sidebar,
body
)
server <- function(input, output, session) {
observeEvent(input$load,{
values <<- readRDS("C:/Documents/ws1.RData")
if (exists("values")) {
lapply(names(values),
function(x) session$sendInputMessage(x, list(value = values[[x]]))
)
}
})
observeEvent(input$save,{
values <<- lapply(reactiveValuesToList(input), unclass)
saveRDS( values , file = "C:/Documents/ws1.RData")
})
filedata <- reactive({
inFile <- input$file1
if (is.null(inFile)){
data.table(Number1 = numeric(20),
Number2 = numeric(20),
Date1 = seq(from = Sys.Date(), by = "days", length.out = 20),
Date2 = seq(from = Sys.Date(), by = "days", length.out = 20))
} else{
fread(input$file1$datapath)
}
})
output$hot = renderRHandsontable({
rhandsontable(filedata()) %>%
hot_cols(columnSorting = TRUE) %>%
hot_table(highlightCol = TRUE, highlightRow = TRUE)
})
}
shinyApp(ui, server)
I am encountering two issues:
When I include the fileInput("file1", ...), the inputs do not update
anymore once I click the load action button;
The Rhandsontable is not updated. However, when I look into values$hot$data, it does seem as if the data is properly stored in values.
Does anyone have an idea of what I am doing wrong?
Thanks!