R Shiny Dynamic Report Download - r

I have made a dynamic report visually in an r shiny app using renderui. I would like to be able to download this dynamic report but not sure how to correctly create it assuming I am unable to convert a render ui into an html file.
What is the best way to write a dynamic html file that can be displayed in the ui? and then download it?
Below is a minimal reproducible project. The download button is currently just for show.
library(shiny)
library(shinydashboard)
library(dplyr)
library(stringr)
library(DBI)
library(DT)
library(shinycssloaders)
library(lubridate)
library(tidyr)
library(ggplot2)
library(plotly)
library(scales)
ui <- dashboardPage(
dashboardHeader(title = "Key Performance Indicators", titleWidth =300),
dashboardSidebar(width = 300,
sidebarMenu(
menuItem("User Guide", tabName = "userguide", icon = icon("question-circle")),
menuItem("Dashboard", tabName = "dashboard", icon = icon("chart-line"), selected = TRUE)
),
selectizeInput(inputId="goals",
label="Goal:",
choices= c("Asset Management"
),
selected= "Asset Management",
multiple = FALSE),
uiOutput("kpis")
),
dashboardBody(
tabItems(
tabItem(
tabName = "userguide",
fluidRow(column(width = 12,
tabBox(width = NULL,
tabPanel("User Guide",
h3("General"),
h5("")
)
)
)
)
),
tabItem(
tabName = "dashboard",
fluidRow(column(width = 12,
tabBox(width = NULL,
tabPanel("Plot",
plotlyOutput("plot", height = 550) %>%
withSpinner(color="#1b6d96")),
tabPanel("Report",
uiOutput("report") %>%
withSpinner(color="#1b6d96")
)
)
)
)
)
)
)
)
server <- function(input, output) {
rawTable <- reactive({
df <- data.frame(KPI =c("Money Spent"),
measure = c("Dollars"),
FY2015= c(500),
FY2016= c(100),
FY2017= c(250),
FY2018= c(600),
FY2019= c(750),
FY2020= c(900))
return(df)
})
output$kpis <- renderUI({
selectizeInput(inputId="kpi",
label="KPI:",
choices= unique(rawTable()$KPI),
selected= unique(rawTable()$KPI[1]),
multiple = FALSE)
})
KPIplot <- reactive({
req(input$kpi)
df <- rawTable() %>%
filter(KPI == input$kpi) %>%
tidyr::pivot_longer(cols = tidyr::starts_with("FY"),
names_to = "Fiscal.Year",
values_to = "Value") %>%
mutate(Values = as.numeric(gsub("[^A-Za-z0-9;._-]","",Value)))
#measure <- toupper(unique(df$`Y Axis Label`))
ggplotly(
ggplot(
data = df,
aes(x = Fiscal.Year, y= Value,
text = paste0("Fiscal Year: ", gsub("\\.","-",str_remove(Fiscal.Year, "FY")),
"<br>Value: ", Value))
) +
geom_bar(stat = "identity") +
scale_y_continuous(labels = comma, breaks = scales::pretty_breaks(n = 10)) +
theme_minimal(),
tooltip = c("text")
)
})
output$plot <- renderPlotly({KPIplot()})
output$report <- renderUI({
fluidPage(
fluidRow(
column(
8, align = "right", offset = 2,
downloadButton("report", "Generate report")
)
),
fluidRow(
column(
8, align="center", offset = 2,
h1("Key Performance Indicator"),
hr(),
h2(input$goals)
)
),
fluidRow(
column(
8, align="left", offset = 2,
h2(input$kpi),
br(),
h3("Description"),
h5("custom text"),
br(),
h3("Performance Data"),
renderPlotly({KPIplot()}),
br(),
h3("Analysis"),
h5("custom text")
)
)
)
})
}
# Run the application
shinyApp(ui = ui, server = server)

Related

How to dynamically pick dataset in selectizeInput depending on tab selection in shinydashboard

I have the following app created in shiny using shinydashboard
library(shiny)
library(shinydashboard)
production_data <- data.frame(Variable = c('GDP', 'IP', 'Manufacturing'),
Value = c(1,2,3)) %>%
as_tibble()
housing_data <- data.frame(Variable = c('Prices', 'Sales', 'Mortgages'),
Value = c(1,2,3)) %>%
as_tibble()
ui <- dashboardPage(
dashboardHeader(title = 'Dashboard'),
dashboardSidebar(sidebarMenu(
menuItem(tabName = 'Panel1', text = 'Heatmaps'),
menuItem(tabName = 'Panel2', text = 'Linecharts')
)
),
dashboardBody(tabItems(tabItem(tabName = 'Panel1',
fluidRow(box(selectizeInput('select', 'Select Variable',
choices = production_data %>% select(Variable)
), height=80,width=4,
)
),
fluidRow(tabBox(
id = 'tabset1', width = 13, height = 655,
tabPanel('Production', height = 655),
tabPanel('Housing', height = 655)
)
)
)
)
)
)
server <- function(input, output) {
}
shinyApp(ui, server)
I'm trying to dynamically select the inputs in my selectizeInput (Line 21) depending on which tabPanel selected. For example, if I have the Production tab selected (line 28), I want to pass the production_data dataframe as the options in selectizeInput placeholder. Similarly, I want the housing_data dataframe to be selected if I'm on the housing tab (line 29).
Is there a way to dynamically select the dataframe in line 22 (it's currently just production_data) depending on which tab I'm on in the app?
Using an updateSelectizeInput inside an observer you could do:
library(shiny)
library(shinydashboard)
library(tibble)
production_data <- data.frame(
Variable = c("GDP", "IP", "Manufacturing"),
Value = c(1, 2, 3)
) %>%
as_tibble()
housing_data <- data.frame(
Variable = c("Prices", "Sales", "Mortgages"),
Value = c(1, 2, 3)
) %>%
as_tibble()
ui <- dashboardPage(
dashboardHeader(title = "Dashboard"),
dashboardSidebar(sidebarMenu(
menuItem(tabName = "Panel1", text = "Heatmaps"),
menuItem(tabName = "Panel2", text = "Linecharts")
)),
dashboardBody(tabItems(tabItem(
tabName = "Panel1",
fluidRow(box(selectizeInput("select", "Select Variable",
choices = production_data %>% select(Variable)
), height = 80, width = 4, )),
fluidRow(tabBox(
id = "tabset1", width = 13, height = 655,
tabPanel("Production", height = 655),
tabPanel("Housing", height = 655)
))
)))
)
server <- function(input, output) {
observe({
choices <- if (input$tabset1 == "Production") {
unique(production_data$Variable)
} else {
unique(housing_data$Variable)
}
updateSelectizeInput(inputId = "select", choices = choices)
})
}
shinyApp(ui, server)

Make a Horizontal scrollbar with R ShinyDashboard for DT table

I'm creating a table that has 88 columns, so naturally I'd require a scrollbar, I'd also like to highlight some column variables depending on their values, however my issue is that no horizontal scrollbar appears. This is the code:
library(DT)
library(shiny)
library(shinydashboard)
library(dashboardthemes)
library(shinyjs)
data <- read.csv("somedata.csv", check.names = FALSE)
options(DT.options = list(pageLength = 5), scrollX = TRUE)
ui <- dashboardPage(
dashboardHeader(title = "Table Summary"),
dashboardSidebar(collapsed = FALSE,
sidebarMenu(
id = "tabs",
menuItem(text = "Tab 1",
tabName = "t1",
icon = icon('trophy'),
selected = TRUE
)
)
),
dashboardBody(
shinyjs::useShinyjs(),
tabItems(
tabItem(
tabName = "t1",
#we wan to create 3 separate pages on this tab
tabsetPanel(
id = "t1Selected", #returns value of current page we're on,
type = "tabs",
tabPanel(
title = "totals",
id = "tab_totals",
fluidRow(
column(width = 6, align = "right", DT::dataTableOutput("table"))
#DT::dataTableOutput("table")
),
fluidRow(
column(
width = 3, align = "left", checkboxInput("bt1", "Test for this?", TRUE)
),
column(
width = 3, align = "left",numericInput("bt1C", "Choice", 0, min = -100, max = 100)
),
column(
width = 3, align = "left", checkboxInput("bt2", "Test for this?", TRUE)
),
column(
width = 3, align = "left",numericInput("bt2C", "Choice", 0, min = -100, max = 100)
),
)
)
)
)
)
)
)
server <- function(input, output, session) {
observe({
shinyjs::enable("bt1C")
if(input$bt1 == 0){
shinyjs::disable("bt1C")
}
})
output$table <- DT::renderDataTable({
datatable(data) %>% formatStyle('Message_ratio', backgroundColor = styleEqual(c(0, 9.57), c('gray', 'yellow')))
})
}
shinyApp(ui, server)
I have the global setting for DT.options saying that scrollX should be on, but no horizontal taskbar comes up....
If it matters, I'm using windows.
Any suggestions would be helpful.
Before anyone recommends this link: How to make the horizontal scrollbar visible in DT::datatable
I've already tried what theyre saying, did not seem to help.
Using mtcars as example this works for me to get a horizontal scroll bar.
library(DT)
library(shiny)
library(shinydashboard)
library(dashboardthemes)
library(shinyjs)
data <- mtcars
ui <- dashboardPage(
dashboardHeader(title = "Table Summary"),
dashboardSidebar(collapsed = FALSE,
sidebarMenu(
id = "tabs",
menuItem(text = "Tab 1",
tabName = "t1",
icon = icon('trophy'),
selected = TRUE
)
)
),
dashboardBody(
shinyjs::useShinyjs(),
tabItems(
tabItem(
tabName = "t1",
#we wan to create 3 separate pages on this tab
tabsetPanel(
id = "t1Selected", #returns value of current page we're on,
type = "tabs",
tabPanel(
title = "totals",
id = "tab_totals",
fluidRow(
column(width = 6, align = "right", DT::dataTableOutput("table"))
#DT::dataTableOutput("table")
),
fluidRow(
column(
width = 3, align = "left", checkboxInput("bt1", "Test for this?", TRUE)
),
column(
width = 3, align = "left",numericInput("bt1C", "Choice", 0, min = -100, max = 100)
),
column(
width = 3, align = "left", checkboxInput("bt2", "Test for this?", TRUE)
),
column(
width = 3, align = "left",numericInput("bt2C", "Choice", 0, min = -100, max = 100)
),
)
)
)
)
)
)
)
server <- function(input, output, session) {
observe({
shinyjs::enable("bt1C")
if(input$bt1 == 0){
shinyjs::disable("bt1C")
}
})
output$table <- DT::renderDataTable({
datatable(data, options = list(scrollX = TRUE)) %>%
formatStyle('mpg', backgroundColor = styleEqual(c(0, 9.57), c('gray', 'yellow')))
})
}
shinyApp(ui, server)

shiny fix position of collapsible panel

I'm trying to make this shiny app have a collapsible panel fixed at the top. But, whenever I make the position fixed, the collapse functionality doesn't work.
What do I have to do to fix this collapsible panel on top?
library(shiny)
library(shinyWidgets)
library(shinyBS)
library(DT)
ui <- fluidPage(
fluidRow(
column(4),
column(4,
div(
bsCollapse(id = "cntrlC1", open = "Panel 2",
bsCollapsePanel("Control Panel",
htmlOutput("dateSelector", inline = TRUE),
style = "info"
)
)
)
)
),
fluidRow(
DTOutput('sampleTbl')
)
)
server <- function(input, output, session){
output$dateSelector <- renderUI({
airDatepickerInput(
"dateSelector",
label = "Select Start & End Dates",
value = c("2020-01-01", "2020-01-10"),
multiple = 2
)
})
output$sampleTbl <- DT::renderDT(server = TRUE, {
data <- data.frame(A = rep(1, 100), B = rep(2, 100), C = rep(3, 100))
m <- datatable(
data,
options = list(pageLength = 100)
)
m
})
}
shinyApp(ui, server)
Perhaps you are looking for this
ui <- fluidPage(
fluidRow(
column(4),
column(4,
div(
bsCollapse(id = "cntrlC1", open = "Panel 2",
bsCollapsePanel("Control Panel",
htmlOutput("dateSelector", inline = TRUE),
style = "info"
)
), style="position:fixed;"
)
)
),
fluidRow(
column(width=2, textInput("searchField1", "Search")),
column(width=2, uiOutput("saveText1"), actionButton("saveBtn1", "Save"))
),
fluidRow(
DTOutput('sampleTbl')
)
)
server <- function(input, output, session){
output$dateSelector <- renderUI({
airDatepickerInput(
"dateSelector",
label = "Select Start & End Dates",
value = c("2020-01-01", "2020-01-10"),
multiple = 2
)
})
output$sampleTbl <- DT::renderDT(server = TRUE, {
data <- data.frame(A = rep(1, 100), B = rep(2, 100), C = rep(3, 100))
m <- datatable(
data,
options = list(pageLength = 100)
)
m
})
}
shinyApp(ui, server)

To allign text to the rightmost region of shinydashboard :R

DATA
I want to add text in rightmost region in the dashboard and the text should cover all the right space column.
dashboardPage(skin="yellow",
dashboardHeader(title = "Wheat Price dashboard ),
dashboardSidebar(
sidebarMenu(
menuItem("Punjab-khanna", tabName = "dashboard", icon = icon("area-chart"))
)
),
dashboardBody(
tabItems(
tabItem(tabName = "dashboard",
fluidPage(
titlePanel("Wheat DARA"),
mainPanel(fluidRow(
box( side="right",
tabPanel("Price chart", dygraphOutput("plot1")
)
),box(side = "right",height="250px",includeMarkdown("read.md")))
) )
)
))
)
SERVER.R
d1<-read_excel("data/Wheat data forecasted.xlsx",sheet = 1,col_names =
TRUE)
#stock
d2 <-subset(d1, select = c(1,2,3,4,5))
#last
d1 <-subset(d1, select = c(1,5,6,7))
d1$`Date GMT` <- as.POSIXct(d1$`Date GMT`, format = "%Y-%m-%d", tz="GMT")
ts1 <- irts(time=d1$`Date GMT`,value=as.matrix(d1[,2:4]))
#stock
d2$`Date GMT` <- as.POSIXct(d2$`Date GMT`, format = "%Y-%m-%d", tz="GMT")
ts2 <- irts(time=d2$`Date GMT`,value=as.matrix(d2[,2:5]))
shinyServer(function(input, output) {
output$plot1 <- renderDygraph({
dygraph(ts1) %>%
dyRangeSelector() %>%
dyLegend(show = "always", hideOnMouseOut = FALSE) %>%
dyHighlight(highlightCircleSize = 5) %>%
dyOptions(axisLineColor = "navy", gridLineColor = "grey")
})
} )
I am not able to arrange it to the right side.
NOTE:I have written different text(from the image) but the task is same to arrange the text to rightmost region in dashboard
I've added a minimal reproducible code myself. Please check. You just have to play with fluidrow and column with width values.
if(interactive()) {
## app.R ##
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Basic dashboard"),
dashboardSidebar(),
dashboardBody(
# Boxes need to be put in a row (or column)
fluidRow(
column(
column(
fluidRow(
box(plotOutput("plot1"))
),
fluidRow(
box(plotOutput("plot2"))
),
width = 10
),
column(
h3(
textOutput('text1')
),
width = 2
),
width = 12
)
)
)
)
server <- function(input, output) {
set.seed(122)
histdata <- rnorm(500)
output$plot1 <- renderPlot({
hist(histdata)
})
output$plot2 <- renderPlot({
hist(histdata)
})
output$text1 <- renderText({
"Uniform: These functions provide information about the uniform distribution on the interval from min to max. dunif gives the density, punif gives the distribution function qunif gives the quantile function and runif generates random deviates."
})
}
shinyApp(ui, server)
}
Source Code modified:
Please modify your dashboard input like this below. It also has plot2, since your initial question had one.
dashboardBody(
# Boxes need to be put in a row (or column)
fluidRow(
column(
column(
fluidRow(
tabPanel("Price chart", dygraphOutput("plot1")
),
fluidRow(
plotOutput("plot2")
),
width = 10
),
column(
h3(
includeMarkdown("read.md")
),
width = 2
),
width = 12
)
)
)

R: get sum from selected Input

I am relative new to R and trying to learn on my own.
I want to create in a shiny dashboard a select-field where i can choose products of my Data (.xls) and get a sum returned.
The Input is via selectInput and selectize. This is the part, which works :)
If I choose 1 product i'll get the calories of this product back...so far.
My Problem is that wanna choose more products then 1 and get the sum of the calories. How do i have to identify/search the products of the input field in my table and how do i get the sum of it?
Thanks a lot for your help!
PS: Do you need further info about file? only two columns are important for this: product and calories.
library(dplyr)
library(plotly)
library(readxl)
library(shiny)
library(shinydashboard)
# Daten einlesen
McDaten <- read_excel("~/Desktop/McDaten.xlsx")
McDaten$kcal <- McDaten$`kcal (100g)`
ui <- dashboardPage(
skin="red",
dashboardHeader(title = "Analytics Dashboard", titleWidth = 290),
dashboardSidebar(
width = 290,
sidebarMenu(
menuItem("Virtuelles Menü", tabName = "charts", icon = icon("cutlery"))
)
),
dashboardBody(
tabItems(
tabItem(tabName = "charts",
fluidPage(
br(),
fluidRow(
column(4,
selectInput('in6', 'Menü', McDaten$Produkt, multiple=TRUE, selectize=TRUE)),
column(4,infoBoxOutput("progressBox"))
)
)
))))
server <- function(input, output) {
output$progressBox <- renderInfoBox({
b <- McDaten %>%
select(`kcal (Portion)`, Produkt) %>%
filter(McDaten$Produkt %in% input$in6) %>%
summarise(`kcal (Portion)`)
infoBox(
"Progress", paste0(b, " kcal"), icon = icon("list"),
color = "purple", fill = TRUE
)
})
}
shinyApp(ui, server)
We need the choices = unique(McDaten$Produkt) in the 'ui' and in summarise the sum needs to be specified for the column of interest
-ui
ui <- dashboardPage(
skin="red",
dashboardHeader(title = "Analytics Dashboard", titleWidth = 290),
dashboardSidebar(
width = 290,
sidebarMenu(
menuItem("Virtuelles Menü", tabName = "charts", icon = icon("cutlery"))
)
),
dashboardBody(
tabItems(
tabItem(tabName = "charts",
fluidPage(
br(),
fluidRow(
column(4,
selectInput('in6', 'Menü',
choices = unique(McDaten$Produkt), multiple=TRUE, selectize=TRUE )),
column(4,infoBoxOutput("progressBox"))
)
)
))))
-server
server <- function(input, output) {
output$progressBox <- renderInfoBox({
b <- McDaten %>%
select(`kcal (Portion)`, Produkt) %>%
filter(Produkt %in% input$in6) %>%
summarise(`kcal (Portion)` = sum(`kcal (Portion)`)) %>%
pull(`kcal (Portion)`)
infoBox(
"Progress", paste0(b, " kcal"), icon = icon("list"),
color = "purple", fill = TRUE
)
})
}
-run the app
shinyApp(ui, server)
-data
set.seed(24)
McDaten <- data.frame(Produkt = sample(LETTERS[1:5], 30, replace = TRUE),
`kcal (Portion)` = sample(1400:2000, 30, replace = TRUE),
stringsAsFactors= FALSE, check.names = FALSE)
McDaten$kcal <- McDaten$`kcal (Portion)`
-output

Resources