How to pass a plot (renderPlot) from shiny app as parameter to R Markdown? - variables

I'm trying to download report form shiny app using R Markdown, but I'm lost! I need to pass a plot from shiny as parameter to R Markdown, and then, include this plot in my report.
I searched a lot about this, but I couldn't find anything. How can I plot this in my report?
Server.R
lm_dif_filter <- reactive({
lm_dif_corn[(lm_dif_corn$farmer == input$farmer) & (lm_dif_corn$Treat_X == 'Farmer'),]
})
output$difPlot <- renderPlotly({
dif <- ggplot(data=lm_dif_filter(), aes(x=Treat_Y, y=dif)) +
geom_bar(stat="identity",color = 'black', position=position_dodge(), width = 0.7)+
geom_hline(yintercept = 0) +
#annotate("text", min(Treat_Y), 0, vjust = -1, label = "Farmer")+
theme(legend.position = "none") +
labs(x = "Treats", y = "Diff")
ggplotly(dif)
To download:
output$report <- downloadHandler(
filename = "report.pdf",
content = function(file) {
tempReport <- file.path(tempdir(), "report.Rmd")
file.copy("report.Rmd", tempReport, overwrite = TRUE)
# Set up parameters to pass to Rmd document
params <- list(set_subtitle = input$farmer, plot = output$difPlot)
rmarkdown::render(tempReport, output_file = file,
params = params,
envir = new.env(parent = globalenv())
)
}
)
My report.rmd
---
title: "Some title"
params:
set_subtitle: test
plot: NA
subtitle: "`r params$set_subtitle`"
date: '`r format(Sys.Date(), "%B %d, %Y")`'
output:
pdf_document:
toc: yes
header-includes:
- \usepackage{fancyhdr}
always_allow_html: yes
---
\addtolength{\headheight}{1.0cm}
\pagestyle{fancyplain}
\lhead{\includegraphics[height=1.2cm]{bg.png}}
\renewcommand{\headrulewidth}{0pt}
```{r, include=FALSE}
options(tinytex.verbose = TRUE)
knitr::opts_chunk$set(echo = FALSE)
cat(params$plot)

One easy option is to not pass the plot, and instead pass the parameter, and refer to a shared plot function used by the shiny app and Rmd doc. For example,
Shiny app,
note the source("util.R") and report_hist(params$n)
source("util.R")
library(shiny)
shinyApp(
ui = fluidPage(
sliderInput("slider", "Slider", 1, 100, 50),
downloadButton("report", "Generate report"),
plotOutput("report_hist")
),
server = function(input, output) {
output$report_hist <- renderPlot({
report_hist(n = input$slider)
})
output$report <- downloadHandler(
# For PDF output, change this to "report.pdf"
filename = "report.html",
content = function(file) {
# Copy the report file to a temporary directory before processing it, in
# case we don't have write permissions to the current working dir (which
# can happen when deployed).
tempReport <- file.path(tempdir(), "report.Rmd")
file.copy("report.Rmd", tempReport, overwrite = TRUE)
# Set up parameters to pass to Rmd document
params <- list(n = input$slider)
# Knit the document, passing in the `params` list, and eval it in a
# child of the global environment (this isolates the code in the document
# from the code in this app).
rmarkdown::render(tempReport, output_file = file,
params = params,
envir = new.env(parent = globalenv())
)
}
)
}
)
Rmd report,
note the report_hist(params$n)
---
title: "Dynamic report"
output: html_document
params:
n: NA
---
```{r}
# The `params` object is available in the document.
params$n
```
A plot of `params$n` random points.
```{r}
report_hist(params$n) #note this function was created in util.R and loaded by the shiny app.
```
Shared function in util.R
report_hist <- function(n){
hist(rnorm(n))
}
Here's a demo shiny app you can test it out with, https://rstudio.cloud/project/295626

Related

What is the easiest way to add a tooltip to a boxplot(ggplot) generated through Shiny?

I need the y-value displayed in a tooltip-style text box when the cursor hovers over a bar. I have to imagine this is a simple function through Shiny, but I haven't been able to figure it out.
I'll include the relevant UI and server code below:
UI :
#TAB 3 (QUOTA/SALES)
tabPanel(title = "Quota/Sales",
fluidRow(column(9,
wellPanel(height=600, width ="100%",
plotOutput("quota", height=550, width ="100%"
))),
column(3,
wellPanel(height=100, width ="100%",
selectInput("countyquota", "County:", choices=countychoices, selected = "Statewide"))))
)))
Server:
hdata <- reactive({
if(input$sexage == "All" & input$countyharv == "Statewide") {
harvdata}
else if(input$sexage == "All" & input$countyharv != "Statewide")
{filter(harvdata, NAME == input$countyharv)}
else if (input$sexage != "All" & input$countyharv != "Statewide")
{filter(harvdata, sexage == input$sexage, NAME == input$countyharv)}
else if (input$countyharv == "Statewide" & input$sexage != "All"){
filter(harvdata, sexage == input$sexage)
}
})
output$harv <- renderPlot({
ggplot(hdata(), aes(fill=sexage, y=harvest, x=year, label = harvest)) +
geom_bar(position="dodge", stat="identity") +
xlab("Year") +
ylab("Harvest") +
labs(fill = NULL)+
theme_bw()
})`
Welcome to StackOverflow. The first thing is that it is always a good idea to include a minimal reproducible example of your base code. That way you help us to help you. In your case, the code you provide does not run (is not reporducible) you have to include the data (or a sample).
Going into the answer. ggplot2 output by default does not show tooltip, you need to use a JavaScript base library for that. The more common are plotly and highcharter.
Lets create a shiny app using the mtcars dataset to show you how to take ggplot2 plots to plotly using the plotly::ggplotly() function.
Note the important comments within the code.
library(shiny)
library(plotly) # you need this packages
ui <- fluidPage(
selectInput('x', 'X axis', choices = names(mtcars), selected = 'wt'),
selectInput('y', 'Y axis', choices = names(mtcars), selected = 'mpg'),
fluidRow(
column(
width = 6,
plotOutput('static'),
),
column(
width = 6,
# New function to render plotly outputs
plotlyOutput('dynamic')
)
)
)
server <- function(input, output, session) {
# This a regular ggplot2 object.
plot <- reactive({
ggplot(
data = mtcars,
mapping = aes(x = .data[[input$x]], y = .data[[input$y]])
) +
geom_point() +
theme_bw()
})
output$static <- renderPlot({ plot() })
# 1- New render frunction to handel plotly outputs
# 2- Place a ggplot2 object within the ggplotly() function
output$dynamic <- renderPlotly({ ggplotly(plot()) })
}
shinyApp(ui, server)

kable unable to output unicode character in pdf_book (bookdown)

I am trying to use the checkmark unicode character (\u2713) in a table rendered by kable in a bookdown project. A MWE consists in the following 2 files (index.Rmd, preamble.tex) part of the generated minimal bookdown project.
index.Rmd
---
title: "A Minimal Book Example"
subtitle: "subtitle"
lang: fr
author: "Yihui Xie"
date: "`r Sys.Date()`"
site: bookdown::bookdown_site
documentclass: book
mainfont: Arial
mathfont: Arial
bibliography: [book.bib, packages.bib]
biblio-style: apalike
link-citations: yes
subparagraph: yes
description: "This is a minimal example of using the bookdown package to write a book. The output format for this example is bookdown::gitbook."
---
```{r setup, include=FALSE}
# Set locale to french for month and day names (calendar plots)
Sys.setlocale(locale = 'French')
# Load all needed libraries
if(!require('pacman'))install.packages('pacman')
pacman::p_load(kableExtra)
```
(ref:O3) O~3~
# Prerequisites
✓
```{r stations-polluants, echo=FALSE}
stations_polluants_table <- data.frame(
stations = c("41B001", "41B004", "41B011", "41MEU1", "41N043", "41R001", "41R002", "41R012", "41WOL1", "Total / polluant"),
O3 = c("", rep("✓", 5), "", rep("\u2713", 2), "7")
)
kable(stations_polluants_table, col.names = c("Station", "(ref:O3)"), booktabs = T, align = "c", caption = "Caption text") %>%
row_spec(0, bold = T) %>%
row_spec(10, bold = T) %>%
collapse_rows(columns = 1, latex_hline = "major", valign = "top")
```
```{r include=FALSE}
# automatically create a bib database for R packages
knitr::write_bib(c(
.packages(), 'bookdown', 'knitr', 'rmarkdown'
), 'packages.bib')
```
preamble.tex
\usepackage{booktabs}
\newfontfamily{\unicodefont}{Arial Unicode MS}
\usepackage{newunicodechar}
\newunicodechar{✓}{{\unicodefont{✓}}}
By compiling in PDF with rmarkdown::render_site(output_format = 'bookdown::pdf_book', encoding = 'UTF-8') one can notice that ✓ is correctly rendered in the text, while it is replaced by <U+2713> in the generated table. I also tried to use \u2713 in the table without more success.
What am I doing wrong ? Please note that, even if the prefered output is PDF, I would also like to compile as gitbook (so Rmd files need to stay independent from the output format).
Many thanks.
After having a moment of clarity, the solution simply lies in using text references in bookdown, i.e. (ref:check) ✓ and use the reference within the table.
index.Rmd
```{r setup, include=FALSE}
# Set locale to french for month and day names (calendar plots)
Sys.setlocale(locale = 'French')
# Load all needed libraries
if(!require('pacman'))install.packages('pacman')
pacman::p_load(kableExtra)
```
(ref:O3) O~3~
# Prerequisites
✓
(ref:check) ✓
```{r stations-polluants, echo=FALSE}
stations_polluants_table <- data.frame(
stations = c("41B001", "41B004", "41B011", "41MEU1", "41N043", "41R001", "41R002", "41R012", "41WOL1", "Total / polluant"),
O3 = c("", rep("(ref:check)", 5), "", rep("(ref:check)", 2), "7")
)
kable(stations_polluants_table, col.names = c("Station", "(ref:O3)"), booktabs = T, align = "c", caption = "Caption text") %>%
row_spec(0, bold = T) %>%
row_spec(10, bold = T) %>%
collapse_rows(columns = 1, latex_hline = "major", valign = "top")
```
```{r include=FALSE}
# automatically create a bib database for R packages
knitr::write_bib(c(
.packages(), 'bookdown', 'knitr', 'rmarkdown'
), 'packages.bib')
```

Flexdashboard not able to render ggplotly and ggplot object on same markdown

I have a basic reproducible example here that I think might just be a package limitation. I was wondering if I am just doing something wrong? They both plot fine separately but when combined in the same markdown make the dashboard unable to correctly render.
---
title: "Untitled"
output:
flexdashboard::flex_dashboard:
orientation: rows
source_code: embed
runtime: shiny
---
```{r setup, include=FALSE}
library(tidyverse)
library(plotly)
library(albersusa)
state_sf <- usa_sf("aeqd")
state_dat <- data.frame(state = c("Washington", "Wyoming","Texas","California"), pct = c(0.3,0.5,0.8,0.1))
state_map <- state_sf %>%
left_join(state_dat, by = c("name" = "state"))
```
Test
=====================================
Sidebar {.sidebar data-width=200}
-------------------------------------
Testing
Row
-----------------------------------------------------------------------
###Plotly
```{r graph 1, fig.height=4, fig.width=6}
#Symptoms by state last week===================================================
ggplotly(
ggplot(data = state_map) +
geom_sf(aes(fill=pct))
)
```
###Bar
```{r graph 2, fig.height=4, fig.width=3}
ggplot(data=state_dat) +
geom_col(aes(state,pct,fill=pct))
```
If you are using runtime: shiny you need to use the proper type of Shiny's renderX() functions for each type of plot object to display properly. I don't know why only one plot chunk (w/o renderX()) works, but two breaks it.
### Plotly
```{r graph_1, fig.height=4, fig.width=3}
#Symptoms by state last week
renderPlotly({
ggplotly(
ggplot(data = state_map) +
geom_sf(aes(fill=pct))
)
})
```
### Bar
```{r graph_2, fig.height=4, fig.width=3}
renderPlot({
ggplot(data=state_dat) +
geom_col(aes(state,pct,fill=pct))
})
```

Reactive or observe in dynamic filtering

I have a working app that uses multiple filters to plot some data and i want the filters to be dynamic and dependent on the filter above by only showing available options for the selection. For instance if the Location_Id == 1 then only 'Bike' User_Type is available in the 'User Type' filter. This all works when the app starts with the filters all constrained by the initial Location_ID starting value but as soon as i change the initial input (Location_Id) nothing is getting updated automatically and i have to do an Select All to see which data is available for the new selected Location Id. I have been reading all morning and it seems i need to perhaps include a reactive() somewhere in the server but its not clear how then i update the ui and if i need a render type function somewhere.
#Example for stack overflow
library(shiny)
library(datasets)
library(dplyr)
library(shinyWidgets)
library(lubridate)
#Create test data
set.seed(10)
Dates. <- sample(c(seq(as.Date("2017-01-01"),as.Date("2017-12-28"),1),seq(as.Date("2018-01-01"),as.Date("2019-12-28"),1)),1000)
Facility_Type. <- sample(c("Bikelane","No facility"),length(Dates.),replace = T)
Data.. <- data.frame(Date = Dates., Facility_Type = Facility_Type.)
Data..$User_Type_Desc<- sample(c("Bike","Pedestrian"),nrow(Data..),replace = T)
Data..$Counts <- sample(1:100,nrow(Data..),replace = T)
Data..$Location_Id <- sample(c("01","02","03","04"),nrow(Data..),replace = T)
Data..$Month <- months(Data..$Date)
Data..$Year <- year(Data..$Date)
Data..$User_Type_Desc <- as.character(Data..$User_Type_Desc)
Data..$Facility_Type <- as.character(Data..$Facility_Type)
#Force some changes on data to highlight problem
Data..$User_Type_Desc[Data..$Location_Id%in%"01"] <- "Bike"
Data..$User_Type_Desc[Data..$Location_Id%in%"04"] <- "Pedestrian"
ui <-
#shinyUI(fluidPage(
navbarPage(title = "Bend Bike/PedTraffic Counts",
#Graphics panel
tabPanel("Charting",
#headerPanel(title = "Bend Traffic Count Data Viewer"),
sidebarLayout(
sidebarPanel(
#Select Location Id
selectInput("Location_Id","Select a Location Id",choices = unique(Data..$Location_Id)),
#Select Year
pickerInput(inputId = "Year", label = "Select/deselect all + format selected", choices = NULL,
options = list(`actions-box` = TRUE, size = 10,`selected-text-format` = "count > 3"), multiple = TRUE),
#Select Month
pickerInput(inputId = "Month", label = "Select/deselect all + format selected", choices = NULL,
options = list(`actions-box` = TRUE, size = 10,`selected-text-format` = "count > 3"), multiple = TRUE),
#Location details
##################
#Select User Types
pickerInput(inputId = "User_Type", label = "Select/deselect all + format selected", choices = NULL,
options = list(`actions-box` = TRUE, size = 10,`selected-text-format` = "count > 3"), multiple = TRUE),
#Select Facility Types
pickerInput(inputId = "Facility_Type", label = "Select/deselect all + format selected", choices = NULL,
options = list(`actions-box` = TRUE, size = 10,`selected-text-format` = "count > 3"), multiple = TRUE)
#dateRangeInput("Date", "Input date range")
#selectInput("Date","Select a Product",choices = NULL)
#Panel end
),
mainPanel( plotOutput("location_plot"))
#Sidebar panel layout end
)
# Sidebar panel end
)
#PAge end
)
server <-
#print(str(product_list))
shinyServer(function(session,input,output) {
#Create selection menus
##########################
#Year selection with choices constrained by Location_Id
observe({
Years. <- unique(Data..$Year[Data..$Location_Id%in%input$Location_Id])
updatePickerInput(session,"Year","Select Year(s)",choices = Years.,selected = Years.[1])
})
#Month selection with Year choices
observe({
Months. <- unique(Data..$Month[Data..$Year%in%input$Year])
updatePickerInput(session,"Month","Select Month(s)",choices = Months., selected = Months.[1] )
})
#User Type
observe({
User_Type. <- unique(Data..$User_Type_Desc[Data..$Year%in%input$Year & Data..$Month%in%input$Month])
updatePickerInput(session,"User_Type","Select User Type(s)",choices = User_Type., selected = User_Type.[1])
})
#Facility Type
observe({
Facility_Type. <- unique(Data..$Facility_Type[Data..$Year%in%input$Year & Data..$Month%in%input$Month
& Data..$User_Type_Desc%in%input$User_Type])
updatePickerInput(session,"Facility_Type","Select Facility Type(s)",choices = Facility_Type., selected = Facility_Type.[1])
})
#Plot data
##########################
#Select final data and chart
output$location_plot <- renderPlot({
#Select data
dat <- Data..[Data..$Location_Id%in%input$Location_Id & Data..$Month%in%input$Month &
Data..$Year%in%input$Year & Data..$User_Type_Desc%in%input$User_Type,]
#Initialze chart
ggplot(data = dat, x=Date, y = Counts) +
geom_bar(aes(x = Date,y = Counts),color = "black", position = "dodge", stat = "identity")+
facet_wrap(Facility_Type~User_Type_Desc)
})
})
#Run App
shinyApp(ui,server)
I have developed a solution for the above problem that started this issue (making filters update with proper reactive-ness) but now that i have added a map the app tends to break after making selections in the first selector, in this example that would be the state.
I created a new example below that answers the above question but poses a new one: Why is my app crashing and does it have to do with improper way i handle the reactive-ness?
In order to get the app to crash you have to select a couple of different states and let it render. It seems to do it on California so it makes me wonder if its a matter of the amount of data the map is attempting to render. Unfortunately there is no error given RStudio just crashes. Not sure if this is the proper way to pose this question but if the reactive-ness is the problem with the RStudio crash i think its still relevant to this thread. Thx for any help!
library(shiny) # for shiny apps
library(ggplot2)
library(plotly)
library(dplyr)
library(shinyWidgets)
library(tigris)
library(mapview)
library(leaflet)
library(raster)
library(rgeos)
# Load(Create) data
State_01_Tracts_Sp <- tracts("01")
State_02_Tracts_Sp <- tracts("02")
State_04_Tracts_Sp <- tracts("04")
State_05_Tracts_Sp <- tracts("05")
State_06_Tracts_Sp <- tracts("06")
Tracts_Sp <- rbind(State_01_Tracts_Sp ,State_02_Tracts_Sp, State_04_Tracts_Sp,
State_05_Tracts_Sp , State_06_Tracts_Sp )
#Decode fips into descriptive state and county names
Tracts_Sp#data$State <-
fips_codes$state_name[match(Tracts_Sp#data$STATEFP,fips_codes$state_code)]
Tracts_Sp#data$County <-
fips_codes$county[match(Tracts_Sp#data$COUNTYFP,fips_codes$county_code)]
#Create a copy of the spatial data's data frame
Data.. <- Tracts_Sp#data
#Set up User Interface
ui <- fluidPage(
titlePanel("Census Viewer Test"),
tabsetPanel(
#Daily Counts Panel
##############
#Hourly Counts Panel
#######################
tabPanel("Tab 1",
#Call plot
fluidRow(column(width = 12,plotlyOutput("county_plot" ))),
#Location Details
fluidRow(
column(3,
h4("Select Details"),
uiOutput("State_selector"),
uiOutput("County_selector"),
uiOutput("Tract_selector")),
column(6,
#h4("Selected Location"),
leafletOutput("map_plot",height = 500))
#Close row
)
#Close panel
)
#Close setPanel
)
#PAge end
)
#Set up Server
#---------------------------
server <- shinyServer(function(session,input,output){
#Temporal Details
##################
#State
output$State_selector <- renderUI({
selectInput(inputId = "State",
label = "State", multiple = FALSE,
choices = c( unique(Data..$State)),
selected = unique(Data..$State)[1])
})
#County selection----
output$County_selector <- renderUI({
available0 <- as.character(unique(Data..$County[Data..$State %in% input$State ]
))
pickerInput(inputId = "County", label = "Select/deselect all + format selected",
choices = as.character(unique(available0)),
options = list(`actions-box` = TRUE, size = 10,`selected-text-format`
= "count > 3"), multiple = TRUE,selected = as.character(unique(available0)))
})
#Tract selection----
output$Tract_selector <- renderUI({
available1 <- as.character(unique(Data..$GEOID[Data..$State %in% input$State ] ))
pickerInput(inputId = "Tract", label = "Select/deselect all + format selected",
choices = as.character(unique(available1)),
options = list(`actions-box` = TRUE, size = 10,`selected-text-format`
= "count > 3"), multiple = TRUE,selected = as.character(unique(available1)))
})
#Graphics
#Select final data and chart-----
output$county_plot <- renderPlotly({
#Select data
dat <- Data..[Data..$State%in%input$State & Data..$County%in%input$County &
Data..$GEOID%in%input$Tract ,]
#Set up axis parameters depending on amount of data
angle = 90
#Initialze chart
ggplotly(ggplot(data = dat, x=GEOID, y = ALAND, fill = State) +
geom_bar(aes(x=GEOID, y = ALAND, fill = State),color = "black",
position = "dodge", stat = "identity")+
ggtitle(paste("Land Area of Select Counties
",unique(dat$State),sep="")) +
#Center plot
theme(plot.title = element_text(hjust = 0.5)) +
ylab("LAnd Area") +
xlab("") +
guides(color=guide_legend("State")) +
theme(axis.text.x = element_text(angle = angle, hjust =
1),plot.background = element_rect(fill = "darkseagreen"))) %>% layout(dragmode =
"select")
})
#Select final data and map-----
output$map_plot <- renderLeaflet({
#Select data
Map_Data_Sp <- Tracts_Sp[Tracts_Sp#data$State%in%input$State,]
class(Map_Data_Sp )
#Create map
Map <- mapview(Map_Data_Sp, map.types = "OpenStreetMap", legend = FALSE,
col.regions = "red",color = "black",cex = 10)
Map#map
#Close map
})
})
#Run App
shinyApp(ui,server)

Error when generating pdf using script in R

I'm using R to loop through the columns of a data frame and make a graph of the resulting analysis. I don't get any errors when the script runs, but it generates a pdf that cannot be opened.
If I run the content of the script, it works fine. I wondered if there is a problem with how quickly it is looping through, so I tried to force it to pause. This did not seem to make a difference. I'm interested in any suggestions that people have, and I'm also quite new to R so suggestions as to how I can improve the approach are welcome too. Thanks.
for (i in 2:22) {
# Organise data
pop_den_z = subset(pop_den, pop_den[i] != "0") # Remove zeros
y = pop_den_z[,i] # Get y col
x = pop_den_z[,1] # get x col
y = log(y) # Log transform
# Regression
lm.0 = lm(formula = y ~ x) # make linear model
inter = summary(lm.0)$coefficients[1,1] # Get intercept
slop = summary(lm.0)$coefficients[2,1] # Get slope
# Write to File
a = c(i, inter, slop)
write(a, file = "C:/pop_den_coef.txt", ncolumns = 3, append = TRUE, sep = ",")
## Setup pdf
string = paste("C:/LEED/results/Images/R_graphs/Pop_den", paste(i-2), "City.pdf")
pdf(string, height = 6, width = 9)
p <- qplot(
x, y,
xlab = "Radius [km]",
ylab = "Population Density [log(people/km)]",
xlim = x_range,
main = "Analysis of Cities"
)
# geom_abline(intercept,slope)
p + geom_abline(intercept = inter, slope = slop, colour = "red", size = 1)
Sys.sleep(5)
### close the PDF file
dev.off()
}
The line should be
print(p + geom_abline(intercept = inter, slope = slop, colour = "red", size = 1))
In pdf devices, ggplot (and lattice) only writes to file when explicitly printed.