The HTML output is created by summarytool::dfSummary function.
summarytools
summarytools uses Bootstrap’s stylesheets to generate standalone HTML documents that can be displayed in a Web Browser or in RStudio’s Viewer using the generic print() function.
When the HTML gets rendered on the tabpanel, the whole UI changes. Is there a way to render the HTML on the tabpanel without changing the UI?
library(summarytools)
ui <- fluidPage(
titlePanel("dfSummary"),
sidebarLayout(
sidebarPanel(
uiOutput("dfSummaryButton")
),
mainPanel(
tabsetPanel(
tabPanel("Data Input",
dataTableOutput("dataInput"),
br(),
verbatimTextOutput("profileSTR")),
tabPanel("dfSummary Output",
htmlOutput("profileSummary")))
)
)
)
server <- function(input, output, session) {
#Read in data file
recVal <- reactiveValues()
dfdata <- iris
#First 10 records of input file
output$dataInput <- renderDataTable(head(dfdata, n = 10), options = list(scrollY = '500px',
scrollX = TRUE, searching = FALSE, paging = FALSE, info = FALSE,
ordering = FALSE, columnDefs = list(list(className = 'dt-center',
targets = '_all'))))
#str() of input file
output$profileSTR <- renderPrint({
ProStr <- str(dfdata)
return(ProStr)
})
#Create dfSummary Button
output$dfSummaryButton <- renderUI({
actionButton("dfsummarybutton", "Create dfSummary")
})
### Apply dfSummary Buttom
observeEvent(input$dfsummarybutton, {
recVal$dfdata <- dfdata
})
#dfSummary data
output$profileSummary <- renderUI({
req(recVal$dfdata)
SumProfile <- print(dfSummary(recVal$dfdata), omit.headings = TRUE, method = 'render')
SumProfile
})
}
shinyApp(ui, server)
Version 0.8.3 of summarytools has a new boolean option, bootstrap.css which will prevent this from happening. Also, graph.magnif allows adjusting the graphs' size.
SumProfile <- print(dfSummary(recVal$dfdata),
method = 'render',
omit.headings = TRUE,
footnote = NA,
bootstrap.css = FALSE,
graph.magnif = 0.8)
The latest version can be installed with devtools:
devtools::install_github("dcomtois/summarytools")
Good luck :)
Related
I'm trying to make a horizontal legend in a Shiny app with a Leaflet map.
I can change the display to display: flex; using CSS which makes the legend horizontal but what I'm aiming at is something like:
0% - a palette of colors - 100%
edit and NOT -color- 0% -color- 10% - color- 20% etc.
I don't see a way to do that in CSS and I can't find enough info about addLegend to find a solution,
Here's a reprex:
library(leaflet)
library(RColorBrewer)
ui <- bootstrapPage(
tags$style(type = "text/css", "html, body {width:100%;height:100%}"),
leafletOutput("map", width = "100%", height = "100%"),
absolutePanel(top = 10, right = 10,
sliderInput("range", "Magnitudes", min(quakes$mag), max(quakes$mag),
value = range(quakes$mag), step = 0.1
),
selectInput("colors", "Color Scheme",
rownames(subset(brewer.pal.info, category %in% c("seq", "div")))
),
checkboxInput("legend", "Show legend", TRUE)
)
)
server <- function(input, output, session) {
# Reactive expression for the data subsetted to what the user selected
filteredData <- reactive({
quakes[quakes$mag >= input$range[1] & quakes$mag <= input$range[2],]
})
# This reactive expression represents the palette function,
# which changes as the user makes selections in UI.
colorpal <- reactive({
colorNumeric(input$colors, quakes$mag)
})
output$map <- renderLeaflet({
# Use leaflet() here, and only include aspects of the map that
# won't need to change dynamically (at least, not unless the
# entire map is being torn down and recreated).
leaflet(quakes) %>% addTiles() %>%
fitBounds(~min(long), ~min(lat), ~max(long), ~max(lat))
})
# Incremental changes to the map (in this case, replacing the
# circles when a new color is chosen) should be performed in
# an observer. Each independent set of things that can change
# should be managed in its own observer.
observe({
pal <- colorpal()
leafletProxy("map", data = filteredData()) %>%
clearShapes() %>%
addCircles(radius = ~10^mag/10, weight = 1, color = "#777777",
fillColor = ~pal(mag), fillOpacity = 0.7, popup = ~paste(mag)
)
})
# Use a separate observer to recreate the legend as needed.
observe({
proxy <- leafletProxy("map", data = quakes)
# Remove any existing legend, and only if the legend is
# enabled, create a new one.
proxy %>% clearControls()
if (input$legend) {
pal <- colorpal()
proxy %>% addLegend(position = "bottomright",
pal = pal, values = ~mag
)
}
})
}
shinyApp(ui, server)```
It does not look like it's possible to manipulate the leaflet legend as it's rendered as an <svg> element and a few other <divs>. I came up with a potential solution that involved generating a new legend using tags$ul and tags$li.
I wrote a new function called legend which generates the html markup for a legend using colorNumeric and some set of values (using quakes$mag in this example). The markup is an unordered list <ul>. All list items are generated dynamically based on the number of bins specified (the default is 7). The code used to generate a sequence of colors is adapted from the R Leaflet package: https://github.com/rstudio/leaflet/blob/master/R/legend.R#L93.
Left and right titles can be specified by using the input arguments left_label and right_label. Background colors are defined using the style attribute. All other styles are defined using tags$style.
Here's an example (some of the code is clipped for readability).
legend(
values = quakes$mag,
palette = "BrBG",
title = "Magnitude",
left_label = "0%",
right_label = "100%"
)
#
# <span class="legend-title">Magnitude</span>
# <ul class="legend">
# <li class="legend-item ..."> 0%</li>
# <li class="legend-item ..." style="background-color: #543005; ..."></li>
# ...
To render the legend into the app, you will need to create an output element in the UI. I used absolutePanel to position the legend into the bottom right corner and defined a uiOutput element.
absolutePanel(
bottom = 20, right = 10, width: "225px;",
uiOutput("map_legend")
)
In the server, I replaced the code in the if (input$colors) with:
if (inputs$colors) {
output$map_legend <- renderUI({
legend(...)
})
}
I also added a condition to render a blank element should the option be unticked. Here's a screenshot followed by the example.
The only thing I couldn't figure out is how to link the legend color scale with the circles.
Hope this helps! Let me know if you have any questions.
Screenshot
Example
library(shiny)
library(leaflet)
library(RColorBrewer)
# manually create a legend
legend <- function(values, palette, title, left_label, right_label, bins = 7) {
# validate args
stopifnot(!is.null(values))
stopifnot(!is.null(palette))
stopifnot(!is.null(title))
stopifnot(!is.null(left_label))
stopifnot(!is.null(right_label))
# generate color palette using Bins (not sure if it's the best approach)
# #reference:
# https://github.com/rstudio/leaflet/blob/c19b0fb9c60d5caf5f6116c9e30dba3f27a5288a/R/legend.R#L93
pal <- colorNumeric(palette, values)
cuts <- if (length(bins) == 1) pretty(values, n = bins) else bins
n <- length(cuts)
r <- range(values, na.rm = TRUE)
# pretty cut points may be out of the range of `values`
cuts <- cuts[cuts >= r[1] & cuts <= r[2]]
colors <- pal(c(r[1], cuts, r[2]))
# generate html list object using colors
legend <- tags$ul(class = "legend")
legend$children <- lapply(seq_len(length(colors)), function(color) {
tags$li(
class = "legend-item legend-color",
style = paste0(
"background-color:", colors[color]
),
)
})
# add labels to list
legend$children <- tagList(
tags$li(
class = "legend-item legend-label left-label",
as.character(left_label)
),
legend$children,
tags$li(
class = "legend-item legend-label right-label",
as.character(right_label)
)
)
# render legend with title
return(
tagList(
tags$span(class = "legend-title", as.character(title)),
legend
)
)
}
# ui
ui <- tagList(
tags$head(
tags$style(
"html, body {
width: 100%;
height: 100%;
}",
".legend-title {
display: block;
font-weight: bold;
}",
".legend {
list-style: none;
padding: 0;
display: flex;
justify-content: center;
align-items: center;
}",
".legend-item {
display: inline-block;
}",
".legend-item.legend-label {
margin: 0 8px;
}",
".legend-item.legend-color {
width: 24px;
height: 16px;
}"
)
),
bootstrapPage(
leafletOutput("map", width = "100%", height = "100%"),
absolutePanel(
top = 10, right = 10,
sliderInput("range", "Magnitudes", min(quakes$mag), max(quakes$mag),
value = range(quakes$mag), step = 0.1
),
selectInput("colors", "Color Scheme",
rownames(subset(brewer.pal.info, category %in% c("seq", "div")))
),
checkboxInput("legend", "Show legend", TRUE)
),
absolutePanel(
bottom = 20,
right = 10,
width = "225px",
uiOutput("map_legend"),
)
)
)
server <- function(input, output, session) {
# Reactive expression for the data subsetted to what the user selected
filteredData <- reactive({
quakes[quakes$mag >= input$range[1] & quakes$mag <= input$range[2],]
})
# This reactive expression represents the palette function,
# which changes as the user makes selections in UI.
colorpal <- reactive({
colorNumeric(input$colors, quakes$mag)
})
output$map <- renderLeaflet({
# Use leaflet() here, and only include aspects of the map that
# won't need to change dynamically (at least, not unless the
# entire map is being torn down and recreated).
leaflet(quakes) %>%
addTiles() %>%
fitBounds(~min(long), ~min(lat), ~max(long), ~max(lat))
})
# Incremental changes to the map (in this case, replacing the
# circles when a new color is chosen) should be performed in
# an observer. Each independent set of things that can change
# should be managed in its own observer.
observe({
pal <- colorpal()
leafletProxy("map", data = filteredData()) %>%
clearShapes() %>%
addCircles(radius = ~10^mag/10, weight = 1, color = "#777777",
fillColor = ~pal(mag), fillOpacity = 0.7, popup = ~paste(mag)
)
})
# Use a separate observer to recreate the legend as needed.
observe({
if (input$legend) {
output$map_legend <- renderUI({
# build legend
legend(
values = filteredData()[["mag"]],
palette = as.character(input$colors),
title = "Mag",
left_label = "0%",
right_label = "100%"
)
})
}
if (!input$legend) {
output$map_legend <- renderUI({
tags$div("")
})
}
})
}
shinyApp(ui, server)
I have created quite a long and complicated shiny app, which produces tables and plots based on various user inputs. I want to create a 'download report' button which will display the charts and plots currently visible on the app.
However, I cannot seem to produce a report that works. I have used an example shiny app which contains my problem, hoping that there is a simple solution. When I click 'download report', it asks me to select the save location and produces a report called 'report'. However, it is not an HTML format. It does not have any format actually, so I cannot open it and view the results
Shiny app:
#install.packages("shiny")
library(shiny)
library(ggplot2)
ui <- fluidPage(
title = 'Example application',
sidebarLayout(
sidebarPanel(
helpText(),
selectInput('x', 'Build a regression model of mpg against:',
choices = names(mtcars)[-1]),
radioButtons('format', 'Document format', c('PDF', 'HTML', 'Word'),
inline = TRUE),
downloadButton('downloadReport')
),
mainPanel(
plotOutput('regPlot')
)
)
)
server <- function(input, output) {
chart1 <- reactive({
ggplot(data = mtcars, aes(x=input$x, y=mpg))+geom_point()
})
output$regPlot <- renderPlot({
chart1()
})
output$downloadReport <- downloadHandler(
filename = function() {
paste('my-report', 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', overwrite = TRUE)
library(rmarkdown)
out <- render('report.Rmd', switch(
input$format,
PDF = pdf_document(), HTML = html_document(), Word = word_document()
))
file.rename(out, file)
}
)
}
shinyApp(ui=ui, server=server)
R Markdown file:
---
title: "Download report"
author: "Test"
date: "24 October 2017"
output: html_document
---
```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE)
library(ggplot2)
library(shiny)
library(rmarkdown)
```
## Output plot
Should output plot, here:
```{r test plot, echo=FALSE}
chart1()
```
I must be missing something simple here!
The solution was very simple, but might help others.
The default setting in my Shiny app was to 'Run in Window' when used. However, simply changing this to 'Run External' allowed me to download reports as desired.
Hope this helps someone!
I have an interactive doc in rmarkdown using shiny apps.
My YAML:
---
title: "Shiny HTML Doc"
author: "theforestecologist"
date: "Apr 13, 2017"
output: html_document
runtime: shiny
---
I generate a number of shiny apps throughout this document, but they all are too long (i.e., they all require y scrollers to view their entirety.
I know I can add options = list(height = ###,width = ###) within the shinyApp function in my code chunk to control individual rendered apps, but I want my readers to see my shiny code (sans messy option controls).
So my desired approach is to control all of the shiny app outputs at once.
Specifically, is there a way to make it so they each can have variable heights, but each one be fully pictured (i.e., not needing a vertical (y) scroller)?
Example Code:
---
title: "Shiny HTML Doc"
author: "theforestecologist"
date: "Apr 13, 2017"
output: html_document
runtime: shiny
---
I have an interactive shiny doc with app outputs of varying heights.
By default, they all have the same height, which is too small of a value
(and thus creates the need for vertical scrolling bars).
##### **Example 1**
```{r, eval=TRUE,echo=FALSE}
library(shiny)
ui <- fluidPage(
titlePanel("Ex1"),
sidebarLayout(
sidebarPanel(
checkboxGroupInput(inputId = "type", label = "Plant Type", choices = levels(CO2$Type),
selected = levels(CO2$Type))
),
mainPanel(
plotOutput(outputId = "scatter.plot")
)
)
)
server <- function(input, output) {
output$scatter.plot <- renderPlot({
plot(uptake ~ conc, data = CO2, type = "n")
points(uptake ~ conc, data = CO2[CO2$Type %in% c(input$type),])
title(main = "Plant Trends")
})
}
shinyApp(ui = ui, server = server)
```
The output of the next example is longer and therefore needs a larger height assignment to get rid of the scroll bar.
##### **Example 2**
```{r, eval=TRUE,echo=FALSE}
ui <- fluidPage(
titlePanel("Ex1"),
sidebarLayout(
sidebarPanel(
div(style = "padding:0px 0px 450px 0px;",
checkboxGroupInput(inputId = "type", label = "Plant Type", choices = levels(CO2$Type),
selected = levels(CO2$Type))
)
),
mainPanel(
plotOutput(outputId = "scatter.plot")
)
)
)
server <- function(input, output) {
output$scatter.plot <- renderPlot({
plot(uptake ~ conc, data = CO2, type = "n")
points(uptake ~ conc, data = CO2[CO2$Type %in% c(input$type),])
title(main = "Plant Trends")
})
}
shinyApp(ui = ui, server = server)
```
I'm trying to create a checkbox for which the choices are plots created through ggplot. In the result, the UI looks like the HTML code itself instead of evaluating the HTML code to show the chart. Any ideas how I can get the checkboxGroupInput to show ggplots?
Sample code below -
runApp(shinyApp(
ui = fluidPage(
headerPanel("Plot check box"),
mainPanel(
uiOutput("plotscheckboxes")
)
),
server = function(input, output, session) {
output$plot1 = renderPlot({
ggplot(mtcars)+geom_point(aes(x=mpg,y=mpg))
})
output$plot2 = renderPlot({
ggplot(mtcars)+geom_point(aes(x=mpg,y=mpg))
})
output$plotscheckboxes = renderUI({
plotlist = list(
plotOutput('plot1'),
plotOutput('plot2')
)
plotlist2 = do.call(tagList, plotlist)
# this just produces a list with 1,2, some sort of underlying value for the checkboxGroup
finaloptionlist = lapply(
seq(length(plotlist2)),
function(x) x
)
# the names of the list are what get used in the options so setting the names accordingly as the HTML code of the ggplot rendering
names(finaloptionlist) = sapply(plotlist2, function(x) paste(x, collapse = "\n"))
checkboxGroupInput("checkGroup", label = h3("Checkbox group"),
choices = finaloptionlist,
selected = 1)
})
}
))
I would like to use the CSV quick plot application to analyze data however even with all the packages installed the app continues to show an error. The error message is:
Error in file(file, "rt") : cannot open the connection
Warning in run(timeoutMs) :
cannot open file
The code is below:
UI
library(shiny)
shinyUI(pageWithSidebar(
headerPanel("CSV Quick Plot"),
sidebarPanel(
fileInput('infile', 'Choose file to upload',
accept = c(
'text/csv',
'text/comma-separated-values',
'text/tab-separated-values',
'text/plain',
'.csv',
'.tsv'
)
),
selectInput("plotType", label = "Select Plot Type",
c("Histogram" = "hist",
"Correlation" = "corr")),
dateInput("date", "Date:"),
submitButton("Submit")
),
mainPanel(
h3('Output Information'),
h4('File entered'),
verbatimTextOutput("ofile"),
h4('You selected plot type'),
verbatimTextOutput("oplotType"),
h4('You entered'),
verbatimTextOutput("odate"),
plotOutput('newHist')
)
))
server
library(UsingR)
library(shiny)
library(Hmisc)
library(corrplot)
wd <- getwd()
setwd(wd)
shinyServer(
function(input, output) {
output$ofile <- renderPrint({input$infile})
output$oplotType <- renderPrint({input$plotType})
output$odate <- renderPrint({input$date})
plotdata <- reactive({
filestr <- input$infile
read.csv(filestr$name)
if(is.null(input$file1))
return(NULL)
})
output$newHist <- renderPlot({
hist(plotdata())
})
# Conditional plot selection is test in progress
# corrdf <- cor(plotdata)
# output$newHist <- renderPlot({
# corrplot(corrdf, method = "circle")
# })
}
)
Please help me in getting this application to run. Thank you!
There are three problems with your code.
you're checking for if(is.null(input$file1)) but I believe you want to use input$infile
the above check should be done BEFORE read.csv because if there is no file chosen, you don't want to read a file
when reading the file you want to use filestr$datapath instead of filestr$name. The name only gives you the name of the file on the user's local machine, while the datapath gives the actual full path to the file that's been uplodaed
Here is a simplification of your app that only deals with selecting a file and reading it into csv, demonstrating all those points
runApp(shinyApp(
ui = fluidPage(
fileInput('infile', 'Choose file to upload',
accept = c(
'text/csv',
'text/comma-separated-values',
'text/tab-separated-values',
'text/plain',
'.csv',
'.tsv'
)
)
),
server = function(input, output, session) {
plotdata <- reactive({
if (is.null(input$infile)) {
return()
}
filestr <- input$infile
read.csv(filestr$datapath)
})
observe({
cat(str(plotdata()))
})
}
))