I have created a shiny app that pulls software components and their versions off of a list of nodes. The goal here is to make all of our nodes consistent when possible and this app helps us see which nodes are inconsistent.
Currently you can modify the version in the 'baseline' handsontable and it will reactively update the pivot table below with the change as well as the BaselineStats column within the handsontable. This works as expected. I have been asked to add the ability to upload a csv file that would overwrite the baseline table so a user does not have to change these 'baseline' versions each time they load the app.
In addition, there are some components that are 100% consistent. Currently those do not appear in the 'baseline' handsontable (since this is a tool to show inconsistency) but I have added a checkbox so that the user can still report on those components that are 100% consistent.
For some reason neither the fileUpload nor the checkboxInput are updating and no matter how much I poke and prod at my code, I cannot figure out why.
server.R
library(shiny)
library(rhandsontable)
library(rpivotTable)
library(dplyr)
library(stringr)
library(lubridate)
shinyServer(function(input, output) {
# Create dataframe
df.consistency <- structure(list(Node = structure(c(1L, 1L, 1L, 1L, 2L, 2L, 2L,
2L, 3L, 3L, 3L, 3L, 4L, 4L, 4L, 4L), .Label = c("A", "B", "C",
"D"), class = "factor"), Component = structure(c(3L, 4L, 1L, 2L, 3L,
4L, 1L, 2L, 3L, 4L, 1L, 2L, 3L, 4L, 1L, 2L), .Label = c("docker.version",
"kernel.version", "os.name", "os.version"), class = "factor"),
Version = structure(c(10L, 3L, 1L, 6L, 10L, 3L, 1L, 7L, 10L,
5L, 1L, 8L, 10L, 4L, 2L, 9L), .Label = c("1.12.1", "1.13.1",
"16.04", "17.04", "18.04", "3.10.0", "3.11.0", "3.12.0",
"3.13.0", "RedHat"), class = "factor")), class = "data.frame", row.names = c(NA,
-16L))
# Get Date Time
Report.Date <- Sys.Date()
df.baseline <- reactive({
inputFile <- input$uploadBaselineData
if(!is.null(inputFile)){
read.csv(inputFile$datapath, header = input$header)
} else{
if(input$showConsistent == FALSE){
# Count the number of occurrences for Version and Component, then remove the Components that are consistent (not duplicated => nn == 1) and then remove nn column
df.clusterCons.countComponent <- df.consistency %>%
add_count(Version, Component) %>%
add_count(Component) %>%
filter(nn > 1) %>%
select(-nn)
# Change back to dataframe after grouping
df.clusterCons.countComponent <- as.data.frame(df.clusterCons.countComponent)
# Components and Versions are shown for every node/cluster.
# Reduce this df to get only a unique Component:Version combinations
df.clusterCons.dist_tbl <- df.clusterCons.countComponent %>%
distinct(Component, Version, .keep_all = TRUE)
#Create a df that contains only duplicated rows (rows that are unique i.e. versions are consistent, are removed)
df.clusterCons.dist_tbl.dup <- df.clusterCons.dist_tbl %>%
filter(Component %in% unique(.[["Component"]][duplicated(.[["Component"]])]))
#Create a baseline df to be used to filter larger dataset later
#(baseline = max(n) for Version -- but must retain Component since that is the parameter we will use to filter on later)
df.clusterCons.baseline <- df.clusterCons.dist_tbl.dup[order(df.clusterCons.dist_tbl.dup$Component, df.clusterCons.dist_tbl.dup$n, decreasing = TRUE),]
df.clusterCons.baseline <- df.clusterCons.baseline[!duplicated(df.clusterCons.baseline$Component), ]
df.clusterCons.baseline <- df.clusterCons.baseline %>%
select(Component, Version)
}
else{
# Count the number of occurrences for Version and Component, then remove the Components that are consistent (not duplicated => nn == 1) and then remove nn column
df.clusterCons.countComponent <- df.consistency %>%
add_count(Version, Component) %>%
add_count(Component) %>%
select(-nn)
# Change back to dataframe after grouping
df.clusterCons.countComponent <- as.data.frame(df.clusterCons.countComponent)
# Components and Versions are shown for every node/cluster.
# Reduce this df to get only a unique Component:Version combinations
df.clusterCons.dist_tbl <- df.clusterCons.countComponent %>%
distinct(Component, Version, .keep_all = TRUE)
df.clusterCons.baseline <- df.clusterCons.dist_tbl[order(df.clusterCons.dist_tbl$Component, df.clusterCons.dist_tbl$n, decreasing = TRUE),]
df.clusterCons.baseline <- df.clusterCons.baseline[!duplicated(df.clusterCons.baseline$Component), ]
df.clusterCons.baseline <- df.clusterCons.baseline %>%
select(Component, Version)
}
}
})
df.componentVersionCounts <- df.consistency %>%
add_count(Component) %>%
rename("CountComponents" = n) %>%
add_count(Component, Version) %>%
rename("CountComponentVersions" = n) %>%
mutate("BaselineStats" = paste0("Baseline: ", round(CountComponentVersions / CountComponents * 100, 2), "% of Total: ", CountComponents)) %>%
select(Component, Version, BaselineStats) %>%
distinct(.keep_all = TRUE)
df.componentVersions_tbl <- reactive({
df.componentVersions_tbl <- df.baseline() %>%
distinct(Component, .keep_all = TRUE) %>%
select(Component, Version) %>%
left_join(df.componentVersionCounts, by = c("Component" = "Component", "Version" = "Version"))
})
# Report Date Output
output$reportDate <- renderText({
return(paste0("Report last run: ", Report.Date))
})
# handsontable showing baseline and allowing for an updated baseline
output$baseline_table <- rhandsontable::renderRHandsontable({
rhandsontable(df.componentVersions_tbl(), rowHeaders = NULL) %>%
hot_col("Component", readOnly = TRUE) %>%
hot_col("BaselineStats", readOnly = TRUE) %>%
hot_cols(columnSorting = TRUE) %>%
hot_context_menu(allowRowEdit = FALSE, allowColEdit = FALSE, filters = TRUE)
})
observe({
hot = isolate(input$baseline_table)
if(!is.null(input$baseline_table)){
handsontable <- hot_to_r(input$baseline_table)
df.clusterCons.baseline2 <- handsontable %>%
select(-BaselineStats)
df.componentVersions_tbl <- df.clusterCons.baseline2 %>%
left_join(df.componentVersionCounts, by = c("Component" = "Component", "Version" = "Version"))
output$baseline_table <- rhandsontable::renderRHandsontable({
rhandsontable(df.componentVersions_tbl, rowHeaders = NULL) %>%
hot_col("Component", readOnly = TRUE) %>%
hot_col("BaselineStats", readOnly = TRUE) %>%
hot_cols(columnSorting = TRUE) %>%
hot_context_menu(allowRowEdit = FALSE, allowColEdit = FALSE, filters = TRUE)
})
df.clusterIncons <- anti_join(df.consistency, handsontable, by = c("Component" = "Component", "Version" = "Version"))
df.clusterIncons <- df.clusterIncons
# Pivot Table showing data with inconsistencies
output$pivotTable <- rpivotTable::renderRpivotTable({
rpivotTable::rpivotTable(df.clusterIncons, rows = c("Cluster", "Node"), cols = "Component", aggregatorName = "List Unique Values", vals = "Version",
rendererName = "Table",
inclusions = list(Component = list("os.version", "os.name", "kernel.version", "docker.version")))
})
output$downloadBaselineData <- downloadHandler(
filename = function() {
paste('baselineData-', Sys.Date(), '.csv', sep='')
},
content = function(file) {
baseline_handsontable <- handsontable %>%
select(-BaselineStats)
write.csv(baseline_handsontable, file, row.names = FALSE)
}
)
output$downloadPivotData <- downloadHandler(
filename = function() {
paste('pivotData-', Sys.Date(), '.csv', sep='')
},
content = function(file) {
write.csv(df.clusterIncons, file, row.names = FALSE)
}
)
}
})
})
ui.R
library(shiny)
library(shinydashboard)
library(rhandsontable)
library(rpivotTable)
dashboardPage(
dashboardHeader(title = "Test Dashboard", titleWidth = "97%"),
dashboardSidebar(
collapsed = TRUE,
sidebarMenu(
menuItem("App", tabName = "app", icon = icon("table"))
)
),
dashboardBody(
tabItems(
tabItem("app",
fluidRow(
box(width = 3, background = "light-blue",
"This box includes details to the user about how the application works", br(), br(), br(),
verbatimTextOutput("reportDate")
),
box(width = 7, status = "info", title = "Version baselines based on greatest occurance",
rHandsontableOutput("baseline_table", height = "350px")
),
column(width = 2,
fluidRow(
fileInput("uploadBaselineData", "Upload Other Baseline Data:", multiple = FALSE,
accept = ".csv")
),
fluidRow(
downloadButton("downloadBaselineData", "Download Baseline Data")
),
br(),
fluidRow(
downloadButton("downloadPivotData", "Download Pivot Table Data")
),
br(),
fluidRow(
checkboxInput("showConsistent", "Show Consistent Components in baseline")
)
)
),
fluidRow(
box(width = 12, status = "info", title = "Nodes with versions inconsistent with baseline",
div(style = 'overflow-x: scroll', rpivotTable::rpivotTableOutput("pivotTable", height = "500px"))
)
)
)
)
)
)
I have worked with reactivity quite often but I do not frequently use observe or isolate so that may be where I am running into an issue. I did also try out the new reactlog package but I am still not sure of a path forward.
Here is a picture of the reactlog output before I click the check box or upload new baseline data:
And after:
Actually the given structure of the Shiny App is very tangled and it does not use reactivity efficiently. So first we can start with a simpler app to make sure the basic components are working, then add more.
Some of the problems
the included dataframe df.consistency interferes with the real reactive components you want to add. For instance, the if/else flow is problematic because it always jumps to the first else since the csv does not exist when the app is launched and the expression to read it is not accurate, however df.consistency is always available.
there is duplication of the same component like output$baseline_table which is defined twice.
with read.csv, you passed an argument header = input$header which is not defined (if you took this from the example here, it refers to the checkbox, but it is not valid here).
Minimal app
If you want to start with a minimal app, you can start with the following code. This will allow you to:
use default data or upload a csv to override the default.
view the results in the rhandsontable in the middle.
Notice that:
baseline_data is reactive, that's why the other expressions that use it are also reactive.
if you want to have different calculations of df.componentVersionCounts depending on the checkbox, you can add the if/else inside the expression to write the calculations for both cases.
library(shiny)
library(rpivotTable)
library(dplyr)
library(stringr)
library(lubridate)
library(shinydashboard)
library(rhandsontable)
## UI ------------------------------------------------------------------------------
ui <- dashboardPage(
dashboardHeader(title = "Test Dashboard", titleWidth = "97%"),
dashboardSidebar(
collapsed = TRUE,
sidebarMenu(
menuItem("App", tabName = "app", icon = icon("table"))
)
),
dashboardBody(
tabItems(
tabItem("app",
fluidRow(
box(width = 3, background = "light-blue",
"This box includes details to the user about how the application works", br(), br(), br(),
verbatimTextOutput("reportDate")
),
box(width = 7, status = "info", title = "Version baselines based on greatest occurance",
rHandsontableOutput("baseline_table", height = "350px")
),
column(width = 2,
fluidRow(
fileInput("uploadBaselineData", "Upload Other Baseline Data:", multiple = FALSE,
accept = ".csv")
),
fluidRow(
checkboxInput("showConsistent", "Show Consistent Components in baseline")
)
)
)
)
)
)
)
## define default baseline data
df.consistency <- structure(list(Node = structure(c(1L, 1L, 1L, 1L, 2L, 2L, 2L,
2L, 3L, 3L, 3L, 3L, 4L, 4L, 4L, 4L),
.Label = c("A", "B", "C",
"D"), class = "factor"), Component = structure(c(3L, 4L, 1L, 2L, 3L,
4L, 1L, 2L, 3L, 4L, 1L, 2L, 3L, 4L, 1L, 2L), .Label = c("docker.version",
"kernel.version", "os.name", "os.version"), class = "factor"),
Version = structure(c(10L, 3L, 1L, 6L, 10L, 3L, 1L, 7L, 10L,
5L, 1L, 8L, 10L, 4L, 2L, 9L),
.Label = c("1.12.1", "1.13.1",
"16.04", "17.04", "18.04", "3.10.0", "3.11.0", "3.12.0",
"3.13.0", "RedHat"), class = "factor")), class = "data.frame", row.names = c(NA,
-16L))
## Server ------------------------------------------------------------------
server <- function(input, output) {
## Get Date Time
Report.Date <- Sys.Date()
baseline_data <- reactive({
inputFile <- input$uploadBaselineData
if(!is.null(inputFile)){
## WHEN A CSV IS UPLOADED
read.csv(inputFile$datapath)
}else{
## DEFAULT
df.consistency #or write the any other expression to read from a certain path or query
}
})
## df.componentVersionCounts ---------------------------------------------------------------
df.componentVersionCounts <- reactive({
req(baseline_data())
baseline_data() %>%
add_count(Component) %>%
rename("CountComponents" = n) %>%
add_count(Component, Version) %>%
rename("CountComponentVersions" = n) %>%
mutate("BaselineStats" = paste0("Baseline: ", round(CountComponentVersions / CountComponents * 100, 2), "% of Total: ", CountComponents)) %>%
select(Component, Version, BaselineStats) %>%
distinct(.keep_all = TRUE)
})
## df.componentVersions_tbl ------------------------------------------------------------
df.componentVersions_tbl <- reactive({
req(baseline_data())
baseline_data() %>% ##df.baseline()
distinct(Component, .keep_all = TRUE) %>%
select(Component, Version) %>%
left_join(df.componentVersionCounts(),
by = c("Component" = "Component", "Version" = "Version"))
})
# handsontable showing baseline and allowing for an updated baseline ---------------------
output$baseline_table <- rhandsontable::renderRHandsontable({
rhandsontable(df.componentVersions_tbl(), rowHeaders = NULL) %>%
hot_col("Component", readOnly = TRUE) %>%
hot_col("BaselineStats", readOnly = TRUE) %>%
hot_cols(columnSorting = TRUE) %>%
hot_context_menu(allowRowEdit = FALSE, allowColEdit = FALSE, filters = TRUE)
})
# Report Date Output -------------------------------------------------------
output$reportDate <- renderText({
return(paste0("Report last run: ", Report.Date))
})
}
# Run the application
shinyApp(ui = ui, server = server)
Related
You can see I'm trying to setup three different filters, all of them reactive to each other, but it keeps giving me errors when I test it out.
What I'm trying to accomplish is setting up these filters in a way where say I choose Territory 1, it'll only give me the corresponding states (Ohio) and cities (Columbus and Cleveland). At the same time, say I select both Territory 1 and 4, it will give me the states (Ohio and Michigan) and the cities (Columbus, Cleveland, and Grand Rapids, but not Detroit). At the same time, say I wanted to ignore the territory field and decided to just go right to the State filter, it will give me all the state options (keeping in mind, I haven't chosen anything in territory yet). Same thing if I just wanted to go right to the city filter.
So basically, I want all the filters to be reactively tied to each other, but with no rigid hierarchy where I have to choose territory first, then state, and finally cities.
Was I able to explain that well?
Here is the code.
The setup:
library(shiny)
library(dplyr)
library(highcharter)
df <- structure(list(territory = structure(c(1L, 1L, 2L, 2L, 3L, 4L
), .Label = c("1", "2", "3", "4"), class = "factor"), state = structure(c(3L,
3L, 1L, 1L, 2L, 2L), .Label = c("Indiana", "Michigan", "Ohio"
), class = "factor"), city = structure(c(2L, 1L, 6L, 4L, 3L,
5L), .Label = c("Cleveland", "Columbus", "Detroit", "Gary", "Grand Rapids",
"Indianapolis"), class = "factor"), sales = 5:10, leads = 11:16), class = "data.frame", row.names = c(NA,
-6L)) %>%
mutate_all(as.character)
ui <- {
fluidPage(
fluidRow(
selectizeInput(
inputId = 'selectTerritory',
label = 'Select Territory',
choices = c('All Territories', sort(unique(df$territory))),
multiple = TRUE,
selected = 'All Territories'),
uiOutput(
outputId = 'selectState'),
uiOutput(
outputId = 'selectCity'),
highchartOutput("test")
# plotOutput()
)
)
}
server <- function(input, output, session) {
output$selectState <- renderUI({
# if 'All Territories' is not selected, then filter df by selected Territories. Otherwise, just get all states.
if (!('All Territories' %in% input$selectTerritory)) {
df <- df %>%
filter(
territory %in% input$selectTerritory)
}
states <- sort(unique(df$state))
selectizeInput(
inputId = 'selectState',
label = 'Select State',
choices = c('All States', states),
multiple = TRUE,
selected = 'All States')
})
output$selectCity <- renderUI({
# same strategy
if (!('All States' %in% input$selectState)) {
df <- df %>%
filter(
state %in% input$selectState,
territory %in% input$selectTerritory)
} else {
df <- df %>%
filter(
territory %in% input$selectTerritory)
}
cities <- sort(unique(df$city))
selectizeInput(
inputId = 'selectCity',
label = 'Select City',
choices = c('All Cities', cities),
multiple = TRUE,
selected = 'All Cities')
})
geog <- reactive({
res <- df %>% filter(is.null(input$selectTerritory) | territory %in% input$selectTerritory,
is.null(input$selectState) | state %in% input$selectState,
is.null(input$selectCity) | city %in% input$selectCity)
})
output$test <- renderHighchart({
res <- geog() %>% select_all()
graph <- res %>% group_by_all() %>% summarise(totals=sum(sales))
highchart() %>% hc_add_series(data = graph, type = "bar", hcaes(y = totals),
showInLegend = TRUE) %>% hc_add_theme(hc_theme_flat())
})
}
shinyApp(ui, server)
Firstly, I prefer single-file Shiny apps (it's much easier to copy/paste the whole app rather than having separate files for ui and server).
The other benefit of single-file Shiny apps is that when you post the code to something like Stack Overflow, you can just copy and paste the whole thing, including your calls to library() which are very important! For example, I don't know what package you are using for highChartOutput(), so including those library() calls makes it easier when people are reproducing your code (and becomes the default if you just have a single-file Shiny app). On a related note, your question doesn't really have anything to do with a plot output, so I'm ignoring that part here (you should be able to access the outputs the same way you normally would in a Shiny app).
Secondly, I wouldn't use rbind() to make a df (it can do weird things with the data types). You can just define your variable columns, and directly call data.frame() (e.g., df <- data.frame(v1,v2)). I created the reproducible data by defining your variable columns, calling data.frame, and then running dput(df), which means we can define your dataframe in a single call (and so it's easy to reproduce and avoid any typos).
Thirdly, I'm using dplyr::mutate_all(as.character) because I don't know the package you use for this (taRifx).
Finally, to answer your question... The way I would approach this problem is to define extra variables to each class corresponding effectively to 'All variables', and have these selected as the default for each selectizeInput.
library(shiny)
library(dplyr)
df <- structure(list(territory = structure(c(1L, 1L, 2L, 2L, 3L, 4L
), .Label = c("1", "2", "3", "4"), class = "factor"), state = structure(c(3L,
3L, 1L, 1L, 2L, 2L), .Label = c("Indiana", "Michigan", "Ohio"
), class = "factor"), city = structure(c(2L, 1L, 6L, 4L, 3L,
5L), .Label = c("Cleveland", "Columbus", "Detroit", "Gary", "Grand Rapids",
"Indianapolis"), class = "factor"), sales = 5:10, leads = 11:16), class = "data.frame", row.names = c(NA,
-6L)) %>%
mutate_all(as.character)
ui <- {
fluidPage(
fluidRow(
selectizeInput(
inputId = 'selectTerritory',
label = 'Select Territory',
choices = c('All Territories', sort(unique(df$territory))),
multiple = TRUE,
selected = 'All Territories'),
uiOutput(
outputId = 'selectState'),
uiOutput(
outputId = 'selectCity')
# plotOutput()
)
)
}
server <- function(input, output, session) {
output$selectState <- renderUI({
# if 'All Territories' is not selected, then filter df by selected Territories. Otherwise, just get all states.
if (!('All Territories' %in% input$selectTerritory)) {
df <- df %>%
filter(
territory %in% input$selectTerritory)
}
states <- sort(unique(df$state))
selectizeInput(
inputId = 'selectState',
label = 'Select State',
choices = c('All States', states),
multiple = TRUE,
selected = 'All States')
})
output$selectCity <- renderUI({
# same strategy
if (!('All States' %in% input$selectState)) {
df <- df %>%
filter(
state %in% input$selectState,
territory %in% input$selectTerritory)
} else {
df <- df %>%
filter(
territory %in% input$selectTerritory)
}
cities <- sort(unique(df$city))
selectizeInput(
inputId = 'selectCity',
label = 'Select City',
choices = c('All Cities', cities),
multiple = TRUE,
selected = 'All Cities')
})
}
shinyApp(ui, server)
I have a Shiny app where I have a first Selectizegroup module in the sidebar that filter my data on 3 variables. I want to put a second selectize or pickergroup module in a tabpanel to produce some plot with the data filtered on supplementary 2 variables. But I found no way to apply the pickerGroup module on the reactive data obtained with the first group module.
I already tried to achieve it with isolate(), update(), observeEvent(), but I always failed....
A minimal example of my database:
base <- structure(list(annee = c(2017, 2018, 2017, 2016, 2018, 2017,
2017, 2018, 2018, 2016),
code_composante = structure(c(2L, 1L,2L, 1L, 2L, 2L, 2L, 2L, 2L, 1L),
.Label = c("APS", "FSI"),
class = "factor"),
code_etape = structure(c(25L, 26L, 21L, 28L, 16L, 16L, 12L, 13L, 21L, 28L),
.Label = c("EP3CHE", "EP3EEE", "EP3GCE", "EP3INE", "EP3MAE", "EP3MEE", "EP3PHE", "EP40EE", "EP40GE", "EP40IE", "EP40KE", "EPCHIE", "EPCHSE", "EPEEAE", "EPGCCE", "EPINFE", "EPMACE", "EPMASE", "EPMATE", "EPMECE", "EPMIAE", "EPPHPE", "EPPHSE", "EPSDTE", "EPSDVE", "SP3SCE", "SP40PE", "SPAPSE"),
class = "factor"),
particularite = structure(c(3L,1L, 3L, 3L, 3L, 3L, 3L, 4L, 3L, 3L),
.Label = c("3LA", "4LA","Classique", "Parcours spécial"),
class = "factor"),
origine_gen2 = structure(c(1L, 3L, 3L, 4L, 4L, 3L, 4L, 1L, 3L, 3L),
.Label = c("Bacheliers antérieurs", "Flux latéral", "Néo-bacheliers", "Redoublement ", "Réorientation "),
class = "factor"),
code_resultat = structure(c(2L, 4L, 2L, 3L, 4L, 3L, 3L, 4L, 4L, 1L),
.Label = c("Admis", "Ajourné","Défaillant / démissionnaire", "Donnée manquante", "Réorientation (à affiner)"), class = "factor"),
poursuite = structure(c(4L, 3L, 4L,6L, 3L, 6L, 4L, 3L, 3L, 2L),
.Label = c("Année supérieure - Flux latéral","Année supérieure - Flux normal", "Non déterminé", "Redoublement", "Réorientation", "Sortie UPS - Echec", "Sortie UPS - Réussite" ),
class = "factor")),
class = c("tbl_df", "tbl", "data.frame" ),
row.names = c(NA, -10L))
And a little piece of the shiny app:
# contenu global ####
ui <- shinydashboard::dashboardPage(
shinydashboard::dashboardHeader(title = "Devenir et réussite en L1",
titleWidth = 300),
# shiny::uiOutput("logout_button")),
shinydashboard::dashboardSidebar(tags$head(tags$style(HTML(".sidebar { position: fixed; width: 300px;}" ))),
width = 300,
div(h1("Filtres", style = "margin-left: 10px;")),
shinyWidgets::selectizeGroupUI(id = "filterset",
btn_label = "Remettre les filtres à zéro",
inline = FALSE,
params = list(
annee = list(inputId = "annee", title = "Année"),
composante = list(inputId = "code_composante", title = "Code composante"),
particularite = list(inputId = "particularite", title = "Type de L1"),
etape = list(inputId = "code_etape", title = "Code étape")))),
shinydashboard::dashboardBody(
#### onglet "tables" ####
shiny::tabsetPanel(id = "tabset",
shiny::tabPanel(title = "Tables des flux",
shiny::fluidRow(shinydashboard::box(width = 4,
title = "Origine des étudiants",
DT::DTOutput("table_origine")))),
#### onglet "flowchart"####
shiny::tabPanel(title = "Flow chart",
shinydashboard::box(width = 12,
shinyWidgets::pickerGroupUI(id = "filterset_flowchart",
btn_label = "Remettre les filtres à zéro",
params = list(
origine = list(inputId = "origine_gen2", title = "Origine"),
resultat = list(inputId = "code_resultat", title = "Résultat")))),
shinydashboard::box(width = 12, height = "700px", shiny::plotOutput("flowchart"))
))))
####SERVER####
server <- function(input, output, session) {
#first filter
filtered_data <- callModule(
module = shinyWidgets::selectizeGroupServer,
id = "filterset",
data = base ,
vars = c("annee", "code_composante", "particularite", "code_etape")
)
# box_origine ####
output$table_origine <- DT::renderDT({
effectif_origine <- filtered_data() %>%
dplyr::select(origine_gen2) %>%
dplyr::group_by(origine_gen2) %>%
dplyr::count()
DT::datatable(effectif_origine,
selection = 'single')
})
# flowchart ####
filtered_flowchart_data <- callModule(
module = shinyWidgets::pickerGroupServer,
id = "filterset_flowchart",
data = filtered_data() %>%
droplevels()%>%
dplyr::mutate_if(is.factor, as.character),
vars = c("origine_gen2", "code_resultat")
)
output$flowchart <- shiny::renderPlot({
actualized_data <- filtered_flowchart_data() %>%
dplyr::mutate_if(is.character, as.factor) %>%
dplyr::group_by(poursuite) %>%
dplyr::count()%>%
dplyr::ungroup()
pie_chart <- pie(actualized_data$n, labels = actualized_data$poursuite)
})}
shiny::shinyApp(ui, server)
In the 2nd tabPannel ("Flow chart") I would like the pickerGroup (filtered_flowchart_data) to work on the filtered data from the selectizeGroup (filtered_data()) from the sidebar but without affecting the data of other tabpanels of course :)
With the version provided of my code I obtain a message
Error in .getReactiveEnvironment()$currentContext() : Operation not allowed without an active reactive context.
I think there is possibly a way with a combination of observeEvent, update reactive and isolate but I didn't achieve it....
You can call the module inside a reactive conductor:
filtered_flowchart_data <- reactive({
x <- callModule(
module = shinyWidgets::pickerGroupServer,
id = "filterset_flowchart",
data = filtered_data() %>%
droplevels() %>%
dplyr::mutate_if(is.factor, as.character),
vars = c("origine_gen2", "code_resultat")
)
x()
})
If there's an issue you can also try
filtered_flowchart_data <- reactive({
callModule(
module = shinyWidgets::pickerGroupServer,
id = "filterset_flowchart",
data = filtered_data() %>%
droplevels() %>%
dplyr::mutate_if(is.factor, as.character),
vars = c("origine_gen2", "code_resultat")
)
})
and then you get the data by doing filtered_flowchart_data()().
Thanks for your answer Stéphane, the 2nd proposition achieves the job!
filtered_flowchart_data <- reactive({
callModule(
module = shinyWidgets::pickerGroupServer,
id = "filterset_flowchart",
data = filtered_data() %>%
droplevels() %>%
dplyr::mutate_if(is.factor, as.character),
vars = c("origine_gen2", "code_resultat")
)})
and get the data by using :
filtered_flowchart_data()()
I don't know if its very clean, I never used or saw double ()(), but the result is perfect :)
I'm trying to plot the graph using plotly where the person clicks on the geom_points and it should populate that geom_point row into the rendered table below.
I have been successful in doing that. So Person clicks on the geom_point on the graph, that geom_point data (row) gets displayed. Now I am trying to append multiple rows to the same table instead of overwriting the previous row the person selected. Basically, I want the person should click on the multiple geom_points and the table should show all the geom_points data instead of overwriting the previous one.
library(shiny)
library(plotly)
library(DT)
d1=structure(list(Topic = c("compensation", "manager", "benefits",
"family", "communication", "worklifebalance", "perks", "compensation",
"benefits", "manager", "communication", "worklifebalance", "family",
"perks", "benefits", "compensation", "manager", "communication",
"family", "worklifebalance", "perks"),
variable = structure(c(1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L),
.Label = c("Prct", "Count"), class = "factor"),
value = c(2.23121245555964, 0.723305136692411, 0.576192227534633,
0.202280250091946, 0.190020840995464, 0.153242613706019,
0.0122594090964816, 0.913705583756345, 0.609137055837563,
0.50761421319797, 0.50761421319797, 0.304568527918782, 0.203045685279188,
0, 1.49977276170277, 1.21193758521436, 0.893803969095592,
0.439327374640206, 0.348432055749129, 0.242387517042872,
0.0757460990758976),
group = c("APAC", "APAC", "APAC", "APAC", "APAC", "APAC", "APAC",
"EMEA", "EMEA", "EMEA", "EMEA", "EMEA", "EMEA", "EMEA",
"AMERICAS", "AMERICAS", "AMERICAS", "AMERICAS", "AMERICAS",
"AMERICAS", "AMERICAS")),
.Names = c("Topic", "variable", "value", "group"), class = c("data.table", "data.frame"),
row.names = c(NA, -21L))
ui <- fluidPage(
fluidRow(plotlyOutput('keywords')),
fluidRow(verbatimTextOutput("selection")),
fluidRow(DT::dataTableOutput("table1"))
)
d0 = d1
key <- row.names(d0)
server = function(input,output){
output$keywords = renderPlotly({
d0 <- data.frame(d0, key)
p = ggplot(d0, aes(reorder(Topic,-value), value, key = key)) +
geom_point(aes(colour = value),
shape = 16,
size = 3,
show.legend = F) +
facet_wrap(~ group)+
theme_minimal()
ggplotly(p)
})
output$selection <- renderPrint({
s <- event_data("plotly_click")
cat("You selected: \n\n")
data.frame(s)
})
selection2 <- reactive({
s <- event_data("plotly_click")
cat("You selected: \n\n")
df <- data.frame(s)
})
output$table1 = renderDT({
d2 <- d1 %>% filter(key == selection2()$key)
d2
})
}
shinyApp(ui, server)
if you will run this code and click on points. you will notice that it overwrites the rows in the table. I expect that it should keep appending the rows when you keep clicking on points. I am new to using shiny but if there is a way to do use reactiveValues or observeEvent or anything else?
You have to update value of d2 so you can do it with reactiveVal(). Here's what I've changed in yours server function:
d2 <- reactiveVal(data.frame())
observeEvent(event_data("plotly_click"), {
d2Temp <- rbind(
d2(),
d1 %>% filter(key == selection2()$key)
)
d2(d2Temp)
})
output$table1 = renderDT({
d2()
})
Firstly you must initialise d2 reactive value with an empty data.frame. Then, observe "plotly_click" and bind new row to old data.frame. Lastly update value of yours reactiveVal with d2(d2Temp).
New R shiny user here..
I have 6 filters for a datatable and want to be able to have dynamic filters working in any direction. For instance: I have filters A, B, C, D, E, F. If I filter at A or B or C etc, I want all the other filters dynamically update to show unique() of filtered datatable and so on if I move through the filters in any direction.
I tried a bunch of different techniques and they all didn't seem to work well. Eventually I bit the bullet and wrote the most verbose code to account for all possible combinations of filter directions. So for example:
First in ui.R I set up selectInput for filters A, B, C, D, E, F
Then in server.R I easily filter the table
tt <- reactive({
dt <- mytable
dt <- dt[,input$ColumnsToShow2,drop=FALSE]
if (input$A != "All") {
dt <- dt[dt$A == input$A,]
}
if (input$B != "All") {
dt <- dt[dt$B == input$B,]
}
if (input$C != "All") {
dt <- dt[dt$C == input$C,]
}
if (input$D != "All") {
dt <- dT[dt$D == input$D,]
}
if (input$E != "All") {
dt <- dt[dt$E == input$E,]
}
if (input$F != "All") {
dt <- dt[dt$F == input$F,]
}
dt
})
and then I go -
observe({
#One filter is used:
If A!="All" && B && C && D && E && F are all =="All", then UpdateSelectInput filters B,C,D,E,F
If B!="All" and A && C && D && E && F are all == "All", then
UpdateSelectInput filters A,C,D,E,F
If C and so on, you get the logic
#Two filters are used:
If A!="All" && B!="All" && C && D && E && F are all == "All", then
UpdateSelectInput filters C, D, E, F
if A!="All" && C!="All" && B && D && E && F are all == "All", then
UpdateSelectInput filters B, D, E, F
#etc all the way through
if E!="All" && F!="All" && A && B && C && D are all == "All", then
UpdateSelectInput filters A, B, C, D.
#three filters are used...all the way through 5 filters are used
)}
You get the point now. I'm pretty sure you can set up a similar example to work with.
NB: When I tried to only use just 6 if != "All" without the additional "&&" conditions for the boolean (like I did to filter the datatable itself), it did not work.
I have the filters working perfectly this way like I want them, but my gut feeling is that I'm working too hard at this.
Thanks for reading all this and for your help!!
Addendum - here's an example that I was expecting to work but doesn't:
data <- structure(list(Country.Name = structure(c(1L, 1L, 1L, 1L, 1L,
1L, 1L, 2L, 2L,
2L, 2L, 2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, 3L, 3L
), .Label = c("High income", "Low income", "Mid income"), class =
"factor"),
Country.Code = structure(c(1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L,
2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, 3L,
3L), .Label = c("HIC",
"LIC", "MIC"), class = "factor"), Indicator.Name = structure(c(10L,
9L, 11L, 8L, 6L, 4L, 7L, 5L, 3L, 2L, 18L, 19L, 1L, 17L, 16L,
12L, 20L, 13L, 14L, 15L, 3L), .Label = c("2005 PPP conversion factor,
GDP (LCU per international $)",
"2005 PPP conversion factor, private consumption (LCU per international
$)",
"Adequacy of social protection and labor programs (% of total welfare
of beneficiary households)",
"Adequacy of unemployment benefits and ALMP (% of total welfare of
beneficiary households)",
"Benefit incidence of social protection and labor programs to poorest
quintile (% of total SPL benefits)",
"Benefit incidence of unemployment benefits and ALMP to poorest
quintile (% of total U/ALMP benefits)",
"Coverage of social protection and labor programs (% of population)",
"Coverage of unemployment benefits and ALMP (% of population)",
"Coverage of unemployment benefits and ALMP in 2nd quintile (% of
population)",
"Coverage of unemployment benefits and ALMP in 3rd quintile (% of
population)",
"Coverage of unemployment benefits and ALMP in poorest quintile (% of
population)",
"DEC alternative conversion factor (LCU per US$)", "Net secondary
income (Net current transfers from abroad) (constant LCU)",
"Net secondary income (Net current transfers from abroad) (current
LCU)",
"Net secondary income (Net current transfers from abroad) (current
US$)",
"Official exchange rate (LCU per US$, period average)", "PPP conversion
factor, GDP (LCU per international $)",
"PPP conversion factor, private consumption (LCU per international $)",
"Price level ratio of PPP conversion factor (GDP) to market exchange
rate",
"Terms of trade adjustment (constant LCU)"), class = "factor"),
Indicator.Code = structure(c(21L, 20L, 19L, 18L, 17L, 16L,
15L, 14L, 13L, 12L, 11L, 10L, 9L, 8L, 7L, 6L,
5L, 4L, 3L,
2L, 1L), .Label = c("NY.GSR.NFCY.CN",
"NY.GSR.NFCY.KN", "NY.TAX.NIND.CD",
"NY.TAX.NIND.CN",
"NY.TAX.NIND.KN", "NY.TRF.NCTR.CD", "NY.TRF.NCTR.CN",
"NY.TRF.NCTR.KN",
"NY.TTF.GNFS.KN", "PA.NUS.ATLS", "PA.NUS.FCRF",
"PA.NUS.PPP",
"PA.NUS.PPP.05", "PA.NUS.PPPC.RF", "per_allsp.cov_pop_tot",
"per_lm_alllm.adq_pop_tot", "per_lm_alllm.ben_q1_tot",
"per_lm_alllm.cov_pop_tot",
"per_lm_alllm.cov_q1_tot",
"per_lm_alllm.cov_q2_tot", "per_lm_alllm.cov_q3_tot"
), class = "factor"), Source.no =
structure(c(3L, 3L, 3L,
3L, 3L, 3L, 3L, 3L, 3L, 8L, 1L, 7L, 8L, 1L, 5L, 4L, 9L, 6L,
2L, 10L, 11L), .Label = c(" for Economic Co-operation and Development
(OECD).",
" nonresidents. Data are in current local currency.", "es include both
direct and indirect beneficiaries.",
"expressed in local currency units per U.S. dollar.", "local currency
units relative to the U.S. dollar).",
"nonresidents. Data are in constant local currency.", "onversion
factors are based on the 2011 ICP round.",
"rapolated estimates based on the latest ICP round.", "stant prices.
Data are in constant local currency.",
"to nonresidents. Data are in current U.S. dollars.", "to producers.
Data are in constant local currency."
), class = "factor"), Source.organization = structure(c(4L,
4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 1L, 1L, 1L, 1L, 1L, 2L, 5L,
3L, 3L, 3L, 3L, 3L), .Label = c("d Bank, International Comparison
Program database.",
"Monetary Fund, International Financial Statistics.", "ounts data, and
OECD National Accounts data files.",
"sehold surveys. (datatopics.worldbank.org/aspire/)", "stics,
supplemented by World Bank staff estimates."
), class = "factor")), .Names = c("Country.Name", "Country.Code",
"Indicator.Name", "Indicator.Code", "Source.no", "Source.organization"
), class = "data.frame", row.names = c(NA, -21L))
shinyApp(
ui = fluidPage(
fluidRow(
column(2,
selectInput("CN",
"Country name:",
c("All",
unique(as.character(data$Country.Name))))
),
column(2,
selectInput("CC",
"Country code:",
c("All",
unique(as.character(data$Country.Code))))
),
column(2,
selectInput("IN",
"Indicator name:",
c("All",
unique(as.character(data$Indicator.Name))))
),
column(2,
selectInput("IC",
"Indicator Code:",
c("All",
unique(as.character(data$Indicator.Code))))
),
column(2,
selectInput("SN",
"Source no:",
c("All",
unique(as.character(data$Source.no))))
),
column(2,
selectInput("SO",
"Source org:",
c("All",
unique(as.character(data$Source.organization))))
)
),
fluidRow(
div(DT::dataTableOutput("table1"),style="font-size: 100%",tags$head(tags$style(type="text/css", "#table table td {line-height:50%;}")) )
)
),
server = function(input, output,session) {
table_one <- reactive({
if (input$CN != "All") {
data <- data[data$Country.Name == input$CN,]
}
if (input$CC != "All") {
data <- data[data$Country.Code == input$CC,]
}
if (input$IN != "All") {
data <- data[data$Indicator.Name == input$IN,]
}
if (input$IC != "All") {
data <- data[data$Indicator.Code == input$IC,]
}
if (input$SN != "All") {
data <- data[data$Source.no == input$SN,]
}
if (input$SO != "All") {
data <- data[data$Source.organization == input$SO,]
}
data
})
output$table1 <- DT::renderDataTable(DT::datatable({
table_one()
},rownames = FALSE,
options = list(scrollX=TRUE,
autoWidth = TRUE,
columnDefs = list(list(width = '150px', targets = "_all")))
))
#filter code begin
#if all filters are "all"
observe({
if (input$CN=="All"&&input$CC=="All"&&input$IN=="All"&&input$IC=="All"&&input$SN=="All"&&input$SO=="All"){
updateSelectInput(session,"CN",choices = c("All",unique(as.character(data$Country.Name))))
updateSelectInput(session,"CC",choices = c("All",unique(as.character(data$Country.Code))))
updateSelectInput(session,"IN",choices = c("All",unique(as.character(data$Indicator.Name))))
updateSelectInput(session,"IC",choices = c("All",unique(as.character(data$Indicator.Code))))
updateSelectInput(session,"SN",choices = c("All",unique(as.character(data$Source.no))))
updateSelectInput(session,"SO",choices = c("All",unique(as.character(data$Source.organization))))
}
#otherwise
if (input$CN!="All"){
#updateSelectInput(session,"CN",choices = c("All",unique(as.character(table_one()$Country.Name))))
updateSelectInput(session,"CC",choices = c("All",unique(as.character(table_one()$Country.Code))))
updateSelectInput(session,"IN",choices = c("All",unique(as.character(table_one()$Indicator.Name))))
updateSelectInput(session,"IC",choices = c("All",unique(as.character(table_one()$Indicator.Code))))
updateSelectInput(session,"SN",choices = c("All",unique(as.character(table_one()$Source.no))))
updateSelectInput(session,"SO",choices = c("All",unique(as.character(table_one()$Source.organization))))
}
if (input$CC!="All"){
updateSelectInput(session,"CN",choices = c("All",unique(as.character(table_one()$Country.Name))))
#updateSelectInput(session,"CC",choices = c("All",unique(as.character(table_one()$Country.Code))))
updateSelectInput(session,"IN",choices = c("All",unique(as.character(table_one()$Indicator.Name))))
updateSelectInput(session,"IC",choices = c("All",unique(as.character(table_one()$Indicator.Code))))
updateSelectInput(session,"SN",choices = c("All",unique(as.character(table_one()$Source.no))))
updateSelectInput(session,"SO",choices = c("All",unique(as.character(table_one()$Source.organization))))
}
if (input$IN!="All"){
updateSelectInput(session,"CN",choices = c("All",unique(as.character(table_one()$Country.Name))))
updateSelectInput(session,"CC",choices = c("All",unique(as.character(table_one()$Country.Code))))
#updateSelectInput(session,"IN",choices = c("All",unique(as.character(table_one()$Indicator.Name))))
updateSelectInput(session,"IC",choices = c("All",unique(as.character(table_one()$Indicator.Code))))
updateSelectInput(session,"SN",choices = c("All",unique(as.character(table_one()$Source.no))))
updateSelectInput(session,"SO",choices = c("All",unique(as.character(table_one()$Source.organization))))
}
if (input$IC!="All"){
updateSelectInput(session,"CN",choices = c("All",unique(as.character(table_one()$Country.Name))))
updateSelectInput(session,"CC",choices = c("All",unique(as.character(table_one()$Country.Code))))
updateSelectInput(session,"IN",choices = c("All",unique(as.character(table_one()$Indicator.Name))))
#updateSelectInput(session,"IC",choices = c("All",unique(as.character(table_one()$Indicator.Code))))
updateSelectInput(session,"SN",choices = c("All",unique(as.character(table_one()$Source.no))))
updateSelectInput(session,"SO",choices = c("All",unique(as.character(table_one()$Source.organization))))
}
if (input$SN!="All"){
updateSelectInput(session,"CN",choices = c("All",unique(as.character(table_one()$Country.Name))))
updateSelectInput(session,"CC",choices = c("All",unique(as.character(table_one()$Country.Code))))
updateSelectInput(session,"IN",choices = c("All",unique(as.character(table_one()$Indicator.Name))))
updateSelectInput(session,"IC",choices = c("All",unique(as.character(table_one()$Indicator.Code))))
#updateSelectInput(session,"SN",choices = c("All",unique(as.character(table_one()$Source.no))))
updateSelectInput(session,"SO",choices = c("All",unique(as.character(table_one()$Source.organization))))
}
if (input$SO!="All"){
updateSelectInput(session,"CN",choices = c("All",unique(as.character(table_one()$Country.Name))))
updateSelectInput(session,"CC",choices = c("All",unique(as.character(table_one()$Country.Code))))
updateSelectInput(session,"IN",choices = c("All",unique(as.character(table_one()$Indicator.Name))))
updateSelectInput(session,"IC",choices = c("All",unique(as.character(table_one()$Indicator.Code))))
updateSelectInput(session,"SN",choices = c("All",unique(as.character(table_one()$Source.no))))
#updateSelectInput(session,"SO",choices = c("All",unique(as.character(table_one()$Source.organization))))
}
})
}
)
Using the filter() function and piping from dplyr might be the answer. I used it inside of a renderPlot({}) server function, and it worked for me (I didn't try it in an observe function).
data = data %>% filter(if(input$CN == 'ALL'){Country.Name %in% c("countryname_1", "countryname_2",...,"countryname_n")} else {Country.Name == input$CN}) %>%
filter(if(input$CC == 'ALL'){Country.Code %in% c("countrycode_1",..,"countrycode_n")} else {Country.Code == input$CC}) %>%
and so on for each filter
There is probably a better way to get the unfiltered version in case you have a lot of countries than this part inside the if statement: Country.Code %in% c("countrycode_1",..,"countrycode_n") , but the if/else nested inside the filter, and filter statements for each attribute connected with %>% piping worked for me (and saved a LOT of space).
These links might help too:
filtering values
using filter with if/else statement
*edit update: I ended up put this filter function configuration in the observe function and it works great, seems more organized too
You dont have to code individually to update each dropdown. You can make the dataset reactive, and set the dropdowns choices as column values from that reactive dataset.
You might want to use Observe function, to update the SelectInput.
observe(
UpdateSelectInput(session,inputId,label, choices = c(unique(dataframe()$Column))
)
if you provide a reproducible example, it would be easier to demonstrate
Updated Solution
shinyApp(
ui = fluidPage(
fluidRow(
column(2,
selectInput("CN",
"Country name:",
c("All",
unique(as.character(data$Country.Name))))
),
column(2,
selectInput("CC",
"Country code:",
c("All",
unique(as.character(data$Country.Code))))
),
column(2,
selectInput("IN",
"Indicator name:",
c("All",
unique(as.character(data$Indicator.Name))))
),
column(2,
selectInput("IC",
"Indicator Code:",
c("All",
unique(as.character(data$Indicator.Code))))
),
column(2,
selectInput("SN",
"Source no:",
c("All",
unique(as.character(data$Source.no))))
),
column(2,
selectInput("SO",
"Source org:",
c("All",
unique(as.character(data$Source.organization))))
)
),
fluidRow(
div(DT::dataTableOutput("table1"),style="font-size: 100%",tags$head(tags$style(type="text/css", "#table table td {line-height:50%;}")) )
),
fluidRow(actionButton('reset','reset'))
),
server = function(input, output,session) {
rv = reactiveValues()
rv$data=data
observe({
#table_one <- data
if (input$CN != "All") {
rv$data <- rv$data[rv$data$Country.Name == input$CN,]
}
if (input$CC != "All") {
rv$data <- rv$data[rv$data$Country.Code == input$CC,]
}
if (input$IN != "All") {
rv$data <- rv$data[rv$data$Indicator.Name == input$IN,]
}
if (input$IC != "All") {
rv$data <- rv$data[rv$data$Indicator.Code == input$IC,]
}
if (input$SN != "All") {
rv$data <- rv$data[rv$data$Source.no == input$SN,]
}
if (input$SO != "All") {
rv$data <- rv$data[data$Source.organization == input$SO,]
}
})
observeEvent(input$reset,{
rv$data <- data
})
output$table1 <- DT::renderDataTable(DT::datatable({
rv$data
},rownames = FALSE,
options = list(scrollX=TRUE,
autoWidth = TRUE,
columnDefs = list(list(width = '150px', targets = "_all")))
))
#filter code begin
#if all filters are "all"
observe({
#if (input$CN=="All"&&input$CC=="All"&&input$IN=="All"&&input$IC=="All"&&input$SN=="All"&&input$SO=="All"){
updateSelectInput(session,"CN",choices = c("All",unique(as.character(rv$data$Country.Name))))
updateSelectInput(session,"CC",choices = c("All",unique(as.character(rv$data$Country.Code))))
updateSelectInput(session,"IN",choices = c("All",unique(as.character(rv$data$Indicator.Name))))
updateSelectInput(session,"IC",choices = c("All",unique(as.character(rv$data$Indicator.Code))))
updateSelectInput(session,"SN",choices = c("All",unique(as.character(rv$data$Source.no))))
updateSelectInput(session,"SO",choices = c("All",unique(as.character(rv$data$Source.organization))))
})
}
)
The code demonstrates how you can update the dropdowns using reactiveValues. I havent written up code to handle the 'All' situation, but have provided a Reset button as a workaround. You can add on code to capture the All situation without the need for a reset button.
I am creating a shiny app where I want the user to download data from the shiny app into one single excel file with multiple(more than one) datasets in the same sheet. I looked at the other similar questions but I am not able to get my code working with that help.
Datasets Used:
sample <- structure(list(type = structure(c(1L, 5L, 3L, 5L, 2L, 4L), .Label = c("add select multiple prompt using alphaOptions",
"add select multiple prompt using imageOptions", "add select one prompt using alphaOptions",
"add select one prompt using imageOptions", "add select one prompt using numOptions"
), class = "factor"), name = structure(c(4L, 5L, 3L, 6L, 1L,
2L), .Label = c("grid", "grid_two_columns", "quick_advance",
"select", "select1", "spinner"), class = "factor"), caption = structure(c(4L,
5L, 3L, 6L, 1L, 2L), .Label = c("grid widget", "grid with a maximum of two columns",
"quick advance select widget", "select multiple widget", "select one widget",
"spinner widget"), class = "factor"), hint = structure(c(4L,
6L, 1L, 3L, 2L, 5L), .Label = c("click a choice to select it and advance to the next question",
"click an image to select it (you must have the images on your sdcard to see them)",
"click the button to provide a response", "don't pick c and d together",
"regardless of screen size this widget will only show two columns of images",
"scroll down to see default selection"), class = "factor")), .Names = c("type",
"name", "caption", "hint"), class = "data.frame", row.names = c(NA,
-6L))
profile <- structure(list(Company.Name = structure(c(1L, 3L, 4L, 2L, 5L), .Label = c("Address",
"Assigned MB", "Contact Name", "Contact Phone", "Website"), class = "factor"),
ABC = structure(c(2L, 5L, 1L, 3L, 4L), .Label = c("(398) 657-8401",
"48,S St, Denver, CO, 80233", "Bob Harris, Active", "www.abc.com",
"John Gardner"), class = "factor")), .Names = c("Company.Name",
"ABC"), class = "data.frame", row.names = c(NA, -5L))
I have this same data as csv files.
Below is my code for excel with two sheets:
ui.R
shinyUI(pageWithSidebar(
headerPanel('Download'),
sidebarPanel(
downloadButton('downloadData', 'Download')
),
mainPanel(
)
))
server.R
sample <- read.csv("sample.csv")
profile <- read.csv("profile.csv")
shinyServer(function(input, output) {
output$downloadData <- downloadHandler(
filename = "test.xlsx",
content = function(file) {
write.xlsx2(profile, file, sheetName = "Sheet1")
write.xlsx2(sample, file, sheetName = "Sheet2", append = TRUE)
}
)
})
This is what I am trying for downloading both datasets in the same sheet.
shinyServer(function(input, output) {
output$downloadData <- downloadHandler(
filename = "test.xlsx",
content = function(file) {
write.xlsx2(profile, file, sheetName = "Sheet1")
write.xlsx2(sample, file, sheetName = "Sheet1", append = TRUE)
}
)
})
This is the error I get:
Error : java.lang.IllegalArgumentException: The workbook already contains a sheet of this name
Warning: Error in .jcall: java.lang.IllegalArgumentException: The workbook already contains a sheet of this name
Stack trace (innermost first):
I am expecting the profile and sample datasets to be one below the other in one sheet with some space between them something like in the image below:
I don't think append() works within a given sheet, but you can use the addDataFrame() function:
data <- data.frame(a = 1:3, b = 4:6, c = 7:9)
wb <- createWorkbook()
sheet <- createSheet(wb, sheetName="addDataFrame1")
addDataFrame(data, sheet, row.names = FALSE)
addDataFrame(data, sheet, startRow = nrow(data) + 3, , row.names = FALSE)
saveWorkbook(wb, file = "test.xlsx")