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")
Related
This thread follows on from this answered qestion: Matching strings loop over multiple columns
I opened a new thread as I would like to make an update to flag for exact matches only..
I have a table of key words in separate colums as follows:
#codes table
codes <- structure(
list(
Support = structure(
c(2L, 3L, NA),
.Label = c("",
"help", "questions"),
class = "factor"
),
Online = structure(
c(1L,
3L, 2L),
.Label = c("activities", "discussion board", "quiz", "sy"),
class = "factor"
),
Resources = structure(
c(3L, 2L, NA),
.Label = c("", "pdf",
"textbook"),
class = "factor"
)
),
row.names = c(NA,-3L),
class = "data.frame"
)
I also have a comments table structured as follows:
#comments table
comments <- structure(
list(
SurveyID = structure(
1:5,
.Label = c("ID_1", "ID_2",
"ID_3", "ID_4", "ID_5"),
class = "factor"
),
Open_comments = structure(
c(2L,
4L, 3L, 5L, 1L),
.Label = c(
"I could never get the pdf to download",
"I could never get the system to work",
"I didn’t get the help I needed on time",
"my questions went unanswered",
"staying motivated to get through the textbook",
"there wasn’t enough engagement in the discussion board"
),
class = "factor"
)
),
class = "data.frame",
row.names = c(NA,-5L)
)
What I am trying to do:
Search for an exact match keyword. The following working code has been provided by #Len Greski and #Ronak Shah from the previous thread (with huge thanks to both):
resultsList <- lapply(1:ncol(codes),function(x){
y <- stri_detect_regex(comments$Open_comments,paste(codes[[x]],collapse = "|"))
ifelse(y == TRUE,1,0)
})
results <- as.data.frame(do.call(cbind,resultsList))
colnames(results) <- colnames(codes)
mergedData <- cbind(comments,results)
mergedData
and
comments[names(codes)] <- lapply(codes, function(x)
+(grepl(paste0(na.omit(x), collapse = "|"), comments$Open_comments)))
Both work great but I have come across a snag and now need to match the keywords exactly. As per the example tables above, if I have a keyword "sy", the code will flag any comment with the word "system". I would modify either of the above pieces of code to flag the comment where only "sy" exact match is present.
Many thanks
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 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)
I've been looking to create a multilevel pie-chart (or doughnut chart) in R and the best I found was the package sunburstR, which I must say is a very promising tool.
The interactive functionality is great - however I don't really need it. I'd like to add a title and counts in the legend object and export the graph to an image format. Does this require advanced html coding? There is not much help material about this package on the web yet. Should I look into a difference package? The pie() function is for single level data and the example of geom_polar of ggplot2 I found on this forum does not seem to be appropriate for factors.
Here is an example of my dataset and sunburstR object - however my question is more general in nature and not specific to this example.
require(sunburstR)
data = gg=structure(list(V1 = structure(c(2L, 1L, 3L, 4L, 8L, 5L, 6L, 7L
), .Label = c("Pine Tree-Soft", "Pine Tree-Hard",
"Pine Tree-Long", "Pine Tree-Undecided", "Maple Tree-Red",
"Maple Tree-Green", "Maple Tree-Yellow",
"Maple Tree-Delicious"), class = "factor"), V2 = c(3L,
5L, 2L, 1L, 10L, 5L, 3L, 2L)), .Names = c("V1", "V2"), row.names = c(NA,
-8L), class = "data.frame")
sunburst(data)
Any help or suggestion would be appreciated. Thank you.
I will add an example just in case you might want to pursue this option, but it seems you would like to avoid extra coding.
require(sunburstR)
data = gg=structure(list(V1 = structure(c(2L, 1L, 3L, 4L, 8L, 5L, 6L, 7L
), .Label = c("Pine Tree-Soft", "Pine Tree-Hard",
"Pine Tree-Long", "Pine Tree-Undecided", "Maple Tree-Red",
"Maple Tree-Green", "Maple Tree-Yellow",
"Maple Tree-Delicious"), class = "factor"), V2 = c(3L,
5L, 2L, 1L, 10L, 5L, 3L, 2L)), .Names = c("V1", "V2"), row.names = c(NA,
-8L), class = "data.frame")
sb <- sunburst(
data,
count = TRUE, # add count just for demonstration
legend = list(w=250), # make extra room for our legend
legendOrder = unique(unlist(strsplit(as.character(data$V1),"-")))
)
# for the coding part
# to add some additional information in the legend,
# force show the legend,
# and disable toggling of the legend
htmlwidgets::onRender(
sb,
"
function(el,x) {
// force show the legend
// check legend
d3.select(el).select('.sunburst-togglelegend').property('checked',true);
// simulate click
d3.select(el).select('.sunburst-togglelegend').on('click')();
// change the text in the legend to add count
d3.select(el).selectAll('.sunburst-legend text')
.text(function(d) {return d.name + ' ' + d.value})
// remove the legend toggle
d3.select(el).select('.sunburst-togglelegend').remove()
}
"
)
You can generate a sunburst using the ggsunburst package.
It is based on ggplot2, so you can use ggsave to export as image.
Here there is an example using your data. All the information can be included in the plot, so I removed the legend
# install ggsunburst package
if (!require("ggplot2")) install.packages("ggplot2")
if (!require("rPython")) install.packages("rPython")
install.packages("http://genome.crg.es/~didac/ggsunburst/ggsunburst_0.0.9.tar.gz", repos=NULL, type="source")
library(ggsunburst)
df <- read.table(header = T, text = "
parent node size
Pine Hard 3
Pine Soft 5
Pine Long 2
Pine Undecided 1
Maple Delicious 10
Maple Red 5
Maple Green 3
Maple Yellow 2
")
write.table(df, 'df.csv', sep = ",", row.names = F)
sb <- sunburst_data('df.csv', type = "node_parent", sep = ",", node_attributes = "size")
p <- sunburst(sb, node_labels = T, leaf_labels = F, rects.fill.aes = "name") +
geom_text(data = sb$leaf_labels,
aes(x=x, y=y, label=paste(label, size, sep="\n"), angle=angle), size = 2) +
scale_fill_discrete(guide = F)
ggsave('sunburst.png', plot = p, w=4, h=4)
I have a dataframe (df):
df = structure(list(site = c(989L, 989L, 990L, 990L), filename = structure(1:4, .Label = c("989_1.csv", "989_5.csv", "990_2.csv", "990_9.csv"), class = "factor"), sourceA = structure(1:4, .Label = c("FolderA/989/989_1.csv", "FolderA/989/989_5.csv", "FolderA/990/990_2.csv", "FolderA/990/990_9.csv" ), class = "factor"), destination = structure(c(3L, 1L, 4L, 2L ), .Label = c("FolderB/989/989_5.csv", "FolderB/990/990_9.csv", "FolderC/989/989_1.csv", "FolderD/990/990_2.csv"), class = "factor")), .Names = c("site",
"filename", "sourceA", "destination"), class = "data.frame", row.names = c(NA,
-4L))
'FolderA' has a series of subfolders containing a number of files. I wish to copy subsets of these files to other folders (shown here as 'destination'). Note: 1) the destination varies from file to file, and 2) the primary folders (FolderB,FolderC,and FolderD) exist, but the subfolders do not (e.g., FolderC/989/).
I believe my solution may involve the file.copy() function, but I am having no success.
file.copy(df$sourceA, df$destination)
results in
Error in file.exists(from) : invalid 'file' argument
Ideas?
Edit: using column name 'source' was causing problems - changed to 'sourceA'.
I think it's because the class of df$sourceA is 'factor' and copy.file wants a 'character'.