Closed McCartneyAC closed 3 years ago
Could you show me a REPREX please?
yep! It's a bit big, but I've preserved minimal functionality just to show the gist. the idea is upload a document, get summary stats, download a report. I'm working on the download report part right now, but the button at the top isn't getting its proper icon.
# Packages ---------------------------------------------------------------
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(shinyWidgets)
library(psych)
library(dplyr)
library(tidyr)
library(tibble)
library(gt)
# functions ---------------------------------------------------------------
is_extant <-function(x) any(!is.na(x))
is_numeric<-function(x) any(is.numeric(x))
# Data import
use <- function(name) {
# consider future support for .json?
if (grepl(".csv", name)) {
readr::read_csv(name)
} else if (grepl(".xlsx", name)) {
readxl::read_xlsx(name)
} else if (grepl(".dta", name)) {
haven::read_dta(name)
} else if (grepl(".sav", name)) {
haven::read_spss(name)
} else if (grepl(".rda", name)) {
load(name)
} else {
stop("unknown data type.")
}
}
# UI components -----------------------------------------------------------
ui <- dashboardPagePlus(
dashboardHeaderPlus(title = "ShindashboardPlus Reprex",
left_menu = tagList(
dropdownBlock(
id = "download_dropdown",
title = "Download Report",
#### ERROR WITH ICON HERE
icon = icon("sliders"),
#### SLIDERS ICON DOESN'T APPEAR
#### nor does "download"
radioButtons('format',
helpText('Document format'),
c('PDF', 'HTML', 'Word')),
downloadButton('downloadReport'),
badgeStatus = NULL
)
)
),
## Sidebar -----------------------------------------------------------------
dashboardSidebar(
sidebarMenu(id = "sidebar",
tags$h4("Your Data:"),
menuItem("Upload", tabName = "reg_upload", icon = icon("upload")),
menuItem("Describe", tabName = "reg_desc", icon = icon("list-ol"))
) # sidebarmenu
), #sidebar
dashboardBody(
tags$head(tags$title("Left navbar reprex")),
tabItems(
## Data Subsection ---------------------------------------------------------
tabItem(tabName = "reg_upload",
box( title = "Upload and Model",width = 7,
fileInput("FileInput", "Input Your Data Set"),
helpText("Dataset must be one of: .csv, .sav, .dta, .xlsx, or .rda")
), #upload box
box(title = "Your Data", width = 12,
DT::dataTableOutput("reg_data_table")
) # box (Dataset output)
), #tabItem (reg upload)
# # Describe
tabItem(tabName = "reg_desc", title = "Describe",
box(title = "Data Description", width = 10,
materialSwitch(
inputId = "ext_desc",
label = "Extended Description",
value = FALSE,
status = "primary"
),
# selectInput(
# inputId = "desc_group",
# label = "Describe By A Group",
# choices = NULL
# ),
gt::gt_output("description"))
)
) #tabitems
) #Dashboard Body
) #Dashboard Page
# Server Components -------------------------------------------------------
server <- function(input, output, session) {
# Data Input --------------------------------------------------------------
datasetInput <- reactive({
infile <- input$FileInput
if (is.null(infile))
return(NULL)
dat<-use(infile$datapath)
names(dat) <- gsub(" ", "_", names(dat), fixed = TRUE)
return(dat)
})
# Describe the Data Set ---------------------------------------------------
descgroup <- reactive({
input$desc_group
})
desc <- reactive({
req(datasetInput())
#desc_formula<- as.formula(substitute(datasetInput() ~ descgroup() ))
#grp<-paste0(deparse(substitute(descgroup())))
datasetInput() %>%
select_if(is_numeric) %>%
psych::describe(., fast = !(input$ext_desc)) %>%
add_rownames(var = "Variable") %>%
dplyr::select(-c(vars)) %>%
dplyr::mutate(dplyr::across(is.numeric, round, 2)) %>%
gt::gt() %>%
gt::tab_options(
column_labels.font.size = "small",
table.font.size = "small",
row_group.font.size = "small",
data_row.padding = px(3)
) %>%
gt::tab_header(title = paste0("Data Description"))
})
output$description = gt::render_gt(desc())
# download report ---------------------------------------------------------
output$downloadReport <- downloadHandler(
filename = function() {
paste('RegressionOutput', sep = '.', switch(
input$format, "PDF" = 'pdf', "HTML" = 'html', "Word" = 'docx'
))
},
content = function(file) {
src <- normalizePath('report.Rmd')
owd <- setwd(tempdir())
on.exit(setwd(owd))
file.copy(src, 'report.Rmd')
out <- render('report.Rmd', switch(
input$format,
PDF = pdf_document(), HTML = html_document(), Word = word_document()
))
file.rename(out, file)
})
}
shinyApp(ui, server)
Thanks. According to the documentation, the icon
param of dropdownBlock
does not expect the use of shiny::icon("<icon_name>")
:
dropdownBlock(
id = "mydropdown",
title = "Dropdown 1",
icon = "sliders",
sliderInput(
inputId = "n",
label = "Number of observations",
min = 10, max = 100, value = 30
),
prettyToggle(
inputId = "na",
label_on = "NAs kept",
label_off = "NAs removed",
icon_on = icon("check"),
icon_off = icon("remove")
)
)
I acknowledge this is misleading since shinydashboard
uses icon
which allows to choose between different libraries (fontawesome, glyphicons, ...).
You could use the custom below function before I decide any action on shinydashboardPlus
:
validStatuses <- c("primary", "success", "info", "warning", "danger" )
validateStatus <- function (status)
{
if (status %in% validStatuses) {
return(TRUE)
}
stop("Invalid status: ", status, ". Valid statuses are: ",
paste(validStatuses, collapse = ", "), ".")
}
dropdownBlock <- function(..., id, icon = NULL, title = NULL,
badgeStatus = "danger") {
if (!is.null(badgeStatus))
validateStatus(badgeStatus)
items <- c(list(...))
# Make sure the items are li tags
#lapply(items, tagAssert, type = "li")
# items <- lapply(1:length(items), FUN = function(i) {
# item <- items[[i]]
# name <- item$name
# if (name != "li") {
# wrapper <- shiny::tags$li()
# item <- shiny::tagAppendChild(wrapper, item)
# }
# })
dropdownClass <- paste0("dropdown")
numItems <- length(items)
if (is.null(badgeStatus)) {
badge <- NULL
} else {
badge <- dashboardLabel(status = badgeStatus, numItems)
}
shiny::tags$li(
shiny::singleton(
shiny::tags$head(
# custom javascript so that the dropdown
#is not hidden when the user click on it
shiny::tags$script(
shiny::HTML(
paste0(
"$(document).ready(function(){
$('#", id, "').find('ul').click(function(e){
e.stopPropagation();
});
});
"
)
)
)
)
),
class = dropdownClass,
id = id,
shiny::tags$a(
href = "#",
class = "dropdown-toggle",
`data-toggle` = "dropdown",
icon,
title,
badge
),
shiny::tags$ul(
class = "dropdown-menu",
style = "left: 0; right: auto;",
shiny::tags$li(
shiny::tags$ul(
class = "menu",
shiny::tags$div(
style = "margin-left: auto; margin-right: auto; width: 80%;",
items
)
)
)
)
)
}
Oh! my apologies. Thanks for the catch.
Hmm, removing the icon
function and just having the name of the icon in "quotes" doesn't appear to solve the issue.
If you use the function I gave you above, you can still use your previous code.
!! okay got it. thank you.
I've tried a few different icons so I know the issue isn't with fontAwesome. The icons appear if I add them to the left navbar list, but when I add a left menu dropdown to the header, it appears as title text but without the
icon
appearing. Am I crazy?