I have created a Rmarkdown document with shiny runtime. The reason is that depending on some selections, the data is fetched from a database and the output (tables and plots) are updated accordingly to the new selections. For the plots I was using ggplot2 and this is working fine, but I wanted to introduce more interaction using rCharts, and here is where I'm stuck, having tried a variety of combinations using renderPlot(), renderChart() and renderChart2() returning the rCharts object p, using p$show() or p$print() with different parameters, none of the options working for me.
These are code samples I'm using.
Header:
---
title: "my title"
runtime: shiny
output:
html_document
ext_widgets: {rCharts: [libraries/nvd3]}
---
Here is the plotting code
```{r, echo=FALSE, comment = NA, results = "asis", comment = NA, tidy = F}
renderPlot({
data.dt <- data.table(analysisData())
aggdata2 <- as.data.frame(data.dt[, lapply(.SD, sum), by = date])
aggdata2 <- aggdata2[with(aggdata2,order(date)),]
p <- nPlot(y ~ date, data = aggdata2, type = "lineChart", width = 600)
p$xAxis(
tickFormat = "#!
function(d) {return d3.time.format('%Y-%m-%d')(new Date(d*1000*3600*24));}
!#"
)
#p$print()
#p$show('iframesrc', cdn =TRUE, include_assets=TRUE)
return(p)
})
```
Which is indeed the best solution I have found so far: it is opening a new window with the chart that I want to create. However, it leaves a blank space in the markdown html where I want the chart to be.
For the analysisData() function here is a simplified code
```{r, echo=FALSE}
analysisData <- reactive({
variable1 = input$variable1
variable2 = input$variable2
tables = "sqlTable"
drv <- dbDriver("PostgreSQL")
dbname <- "dbname"; dbuser <- "dbuser";
dbport = dbport
dbhost <- "dbhost.com";
con <- dbConnect(drv, host=dbhost, port = dbport, dbname=dbname, user=dbuser)
selectStatement = "select * from %s where variable1=%s and variable2=%s"
query = sprintf(selectStatement, tables, variable1, variable2)
dataset <- dbGetQuery(con,query)
lapply(dbListConnections(drv),dbDisconnect)
dbUnloadDriver(drv)
dataset$date <- as.Date(dataset$date)
dataset
})
```
Do you have any suggestions on how can I solve the problem? Any hint is appreciated.
Related
I'm working on a project to make it easier to create flex/shiny dashboards from qualtrics surveys. I'd really like to be able to write a couple functions that would let co-workers who have less experience with R be able to make similar documents without having to know Rmarkdown syntax.
For example, if someone wanted to make a one page dashboard with a scatterplot, I'd like to be able to have them use a couple functions like (make_dashboard, make_page) etc:
make_dashboard(
title = "Qualtrics Report Dashboard",
page 1 = make_page(header = "Page 1", format = "column", render = "plot",
data = survey_data, variables = c("var1", "var2"))
)
which would then create a rmd file with this:
---
title: "Qualtrics Report Dashboard"
output:
flexdashboard::flex_dashboard:
orientation: columns
vertical_layout: scroll
runtime: shiny
---
Page 1
=====================================
renderPlot( {
ggplot(data = survey_data, mapping = aes_string(x = var1,
y = var2)) +
geom_point() +
labs(x = get_label(get(var1, survey_data)),
y = get_label(get(var2, survey_data)))
}
)
I haven't gotten very far with trying to write these functions / implement this logic, because I'm not even sure if I'm thinking about it in the right way - is it possible to create rmarkdown chunks with functions like this?
I've looked at other posts 1 and 2 about child documents in knitr, but I don't really want every chunk to be the same, rather have the person be able to change certain aspects (e.g. type of plot, data, etc.).
Not sure if this will be useful to anyone else, but I ended up using whisker (https://github.com/edwindj/whisker), which can render strings into documents to construct an Rmd in the style of flexdashboard.
TLDR: Essentially I made functions that create strings of text matching the building blocks of flexdashboard. With whisker, you can pass in variables by encasing words in the string with two bracket parentheses and then assigning their values with a list of var_name = value for each variable in the string, e.g.
template <- "My name is {{name}}."
d <- list(name = "Emily")
cat(whisker.render(template, data = d))
print(d)
My name is Emily
I used a combination of this and the str_c from stringr to construct strings for different elements of the flexdashboard, allowing the user to input variables like title, variable for plots, etc. that then could be rendered into the string using whisker. Then, I joined all of those strings together and render it into an Rmd file. Honestly, I am not sure this is actually easier for people who don't know R to use, and I'll probably end up doing something different, but I wanted to share in case anyone is thinking about this.
Example: running the chunk below creates a file called "test_dashboard.Rmd" with the text format for a flexdashboard with a 1 input sidebar and a single page with one plot.
```
make_dashboard(title = "Test Dashboard",
sidebar = make_sidebar(sidebar_title = "here is the input",
input_type = "multi-select",
input_name = "Interesting Var #1"),
page1 = make_page(page_title = "Cool Plots!",
element_one = make_plot(plot_title = "this is my plot",
type = "bivariate",
vars = c("cool_var1",
"cool_var2"))),
fn = "test_dashboard")
```
OUTPUT:
```
---
title: Test Dashboard
output:
flexdashboard::flex_dashboard:
orientation: columns
vertical_layout: scroll
runtime: shiny
---
\```{r setup, include=FALSE}
library(flexdashboard)
library(tidytext)
library(tidyverse)
library(janitor)
library(DT)
library(gghighlight)
library(knitr)
library(shiny)
library(qualtRics)
library(curl)
library(sjlabelled)
library(naniar)
library(scales)
library(lme4)
library(MASS)
library(snakecase)
\```
\```{r global, include=FALSE}
#setting global options for table scrolling and plot theme
options(DT.options = list(scrollY="100vh"))
theme_set(theme_minimal())
#this fetches all of your survey info
surveys <- all_surveys()
#this saves the survey responses into
docusign_survey <- fetch_survey(surveyID = surveys$id[1],
verbose = TRUE,
label = TRUE,
breakout_sets = TRUE,
force_request = TRUE)
#this saves the question text into a dataframe
questions <- survey_questions(surveyID = surveys$id[1])
rename_df <- rename_variables(docusign_survey)
#this renames all of the variables
docusign_survey <- docusign_survey %>%
rename_at(as.vector(rename_df$old_name), ~ as.vector(rename_df$new_labels))
#new variables
new_var <- rename_df$new_labels
#which are multi_select?
multi_select <- rename_df %>%
filter(ms == 1) %>%
dplyr::select(new_labels)
#relabel those NAs as No
docusign_survey <- docusign_survey %>%
purrr::modify_at(multi_select$new_labels, na_to_y)
\```
Sidebar {.sidebar}
=====================================
here is the input
\```{r}
selectInput("p_var_1", label = "Interesting Var #1",
choices = new_var,
multiple = TRUE)
\```
Cool Plots!
=====================================
Column {.tabset}
-------------------------------------
### this is my plot
\```{r}
renderPlot( {
make_bivariate_plot(docusign_survey, input$cool_var1, input$cool_var2)
})
\```
```
Functions
make_dashboard()
I saved the parts that will repeat every time, probably will want to make them editable for changes in scrolling, etc. but just trying to make proof of concept at the moment.
```
make_dashboard <- function(title, sidebar, page1, fn){
load("data/top_matter.rda")
load("data/libraries.rda")
load("data/main_chunk.rda")
initial_bit <- stringr::str_c(top_matter, libraries, main_chunk, sep = "\n\n")
intermediate <- stringr::str_c(initial_bit, sidebar, sep = "\n\n")
total <- stringr::str_c(intermediate, page1, sep = "\n\n")
data <- list(title = title)
out_fn <- paste0("./", fn, ".Rmd")
writeLines(whisker.render(total, data), con = out_fn)
}
```
make_sidebar()
```
make_sidebar <- function(sidebar_title, input_type, input_name){
top_sidebar <-
'Sidebar {.sidebar}
=====================================
'
sidebar_text <- str_c(top_sidebar, sidebar_title, sep = "\n\n")
if(input_type == "multi-select"){
ms <- "TRUE"
} else {
ms <- "FALSE"
}
input_one <- make_select_input(input_name, ms)
sidebar_total <- str_c(sidebar_text, "```{r}", input_one, "```", sep = "\n\n")
return(sidebar_total)
}
```
make_page()
```
make_page <- function(page_title, element_one){
top_page <-
'{{page_title}}
=====================================
Column {.tabset}
-------------------------------------'
add_element <- stringr::str_c(top_page, element_one, sep = "\n\n")
data <- list(page_title = page_title)
page <- whisker.render(add_element, data = data)
return(page)
}
```
make_plot()
```
make_plot <- function(plot_title, type = c("univariate", "bivariate"), vars){
top_plot_piece <-' {{plot_title}}
\```{r}
renderPlot( {
'
if(type == "univariate"){
plot_piece <-
'make_univariate_plot(docusign_survey, input${{vars}})
})
\```'
total_plot <- stringr::str_c(top_plot_piece, plot_piece, sep = "\n\n")
data <- list(plot_title = plot_title,
vars = vars)
plot_chunk <- whisker.render(total_plot, data = data)
} else{
plot_piece <-
'make_bivariate_plot(docusign_survey, input${{var_1}}, input${{var_2}})
})
\```'
total_plot <- stringr::str_c(top_plot_piece, plot_piece, sep = "\n\n")
data <- list(plot_title = plot_title,
var_1 = vars[1],
var_2 = vars[2])
plot_chunk <- whisker.render(total_plot, data = data)
}
return(plot_chunk)
}
```
Apologies for the bad title, I wasn't sure how to best convey what my problem is.
To give some context, I want to create a personalized scorecard for each provider in our organization using Rmarkdown. I already figured out how to create an individual PDF for each provider ; however, I want to have a simple bar chart on everyone's report with the provider's position highlighted so that they can compare themselves to their peers. Below is what I have so far:
First I created the dataset:
############################## Create dataset and export #####################################
df = data.frame(
"Provider" = c("A","B","C","D"),
"Measure" = c(1.2,0.8,1.7,0.4)
)
write.csv(df, "pathway/df.csv")
Next I created an Rmarkdown file named "TEST" that calls in the dataset and includes a graph
###################### Create Rmarkdown file named "TEST" ####################################
---
output: pdf_document
---
```{r echo=FALSE}
df <- read.csv("pathway/df.csv", stringsAsFactors = FALSE)
name <- df$Provider[i]
Dear `r name`,
This is your personalized scorecard.
```{r}
ggplot() +
geom_bar(data=df, aes(x=reorder(Provider, -Measure), y=Measure,
fill = factor(ifelse(Provider == "A", "You","Your Peers"))),
stat = "identity") +
scale_fill_manual(name = "Provider", values=c("steelblue","lightgrey"))
Finally I created an R file with the for-loop to create as many PDFs as there are providers
################ Run R file with loop to make separate PDFs per Provider #####################
library(knitr)
library(rmarkdown)
#Read data
df <- read.csv("pathway/df.csv", stringsAsFactors = FALSE)
#Create loop
for (i in 1:nrow(df)){
rmarkdown::render(input = "pathway/TEST.Rmd",
output_format = "pdf_document",
output_file = paste("handout_", i, ".pdf", sep=''),
output_dir = "pathway/folder/")
}
In the code above for the ggplot2 graph I manually coded provider "A" to be highlighted in blue and the rest of the providers grey, but we have over 30 providers and I don't want to manually code for each one. If there is some way for Rmarkdown to automatically highlight each provider in blue and the rest grey for each of their PDF reports that would be amazing. Any help is much appreciated!
There were some errors in your code, so I give the correct files here.
The RMD file:
you have to submit parameters, in your case i. You also did this in name <- df$Provider[i] but i was not given. Also you have to load ggplot2 and set your chunks ob the right positions.
---
output: pdf_document
params:
i: 1
---
```{r echo=FALSE}
library(ggplot2)
df <- read.csv("df.csv", stringsAsFactors = FALSE)
name <- df$Provider[i]
```
Dear `r name`,
This is your personalized scorecard.
```{r}
ggplot() +
geom_bar(data=df, aes(x=reorder(Provider, -Measure), y=Measure,
fill = factor(ifelse(Provider == df$Provider[i], "You","Your Peers"))),
stat = "identity") +
scale_fill_manual(name = "Provider", values=c("steelblue","lightgrey"))
```
The R file loop
Here you also have to submit the parameter too.
library(knitr)
library(rmarkdown)
#Read data
df <- read.csv("pathway/df.csv", stringsAsFactors = FALSE)
#Create loop
for (i in 1:nrow(df)){
rmarkdown::render(input = "pathway/TEST.Rmd",
output_format = "pdf_document",
output_file = paste("handout_", i, ".pdf", sep=''),
output_dir = "pathway/folder/",
params = list(i = i)))}
I want to be able to pass a reactive data.table to my Rmarkdown document that will sort the table and print the top, say 5, sorted entries.
I keep running into "Error : x must be a data.frame or data.table" at setorderv. I suspect the reactive is upsetting the is.data.table checks.
How do I simply pass a copy of the data to the Rmd document? And remove the reactivity wrapper?
Here is a simplified example cobbled from reactivity and downloadHandler stock examples. I took at look at this on SO which suggested using observe but I am not sure how to implement this. Thanks I appreciate some help on this.
RMARKDOWN - SOtestreport.Rmd
---
title: "Top in Segment Report"
output: html_document
params:
n: 5
dt: NA
top.field: NA
---
```{r setup, echo = FALSE}
library(data.table)
library(knitr) # for kable
```
Data report as at: `r format(Sys.time(), "%a %b %d %Y %X")`
```{r, echo = FALSE}
table.str <- paste0("Showing Top ", params$n ," tables for these fields: ",
params$top.field)
# is this the best way of having dynamic labels?
```
`r table.str`
```{r, echo = FALSE}
# tried this
# test.dt <- copy(dt)
# normally a function GenerateTopTable with limit sort field etc.
setorderv(dt, params$top.field, -1) # -1 is descending. THIS IS WHERE IT CRASHES
out <- dt[1:params$n,]
```
```{r toptable, echo = FALSE}
kable(out, digits = 3)
```
app.R
# SO test report
# mini example based on https://shiny.rstudio.com/gallery/reactivity.html
library(shiny)
library(datasets)
server <- function(input, output) {
datasetInput <- reactive({
switch(input$dataset,
"rock" = rock,
"pressure" = pressure,
"cars" = cars)
})
output$caption <- renderText({
input$caption
})
output$summary <- renderPrint({
dataset <- datasetInput()
summary(dataset)
})
output$view <- renderTable({
head(datasetInput(), n = input$obs)
})
# PROBLEM BIT WHERE I AM ADDING ON GALLERY EXAMPLE
# handler from https://stackoverflow.com/questions/37347463/generate-report-with-shiny-app-and
output$topreport <- downloadHandler(
filename = "topreport.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(), "SOtestreport.Rmd")
file.copy("SOtestreport.Rmd", tempReport, overwrite = TRUE)
# Set up parameters to pass to Rmd document
# TRIED THIS TOO
# my.dt <- as.data.table(datasetInput())
my.dt <- datasetInput()
my.params <- list(n = input$obs,
dt = my.dt,
top.field = names(my.dt)[1])
rmarkdown::render(tempReport, output_file = file,
params = my.params,
envir = new.env(parent = globalenv())
)
}
)
I fixed this example - dt in Rmd was not prefaced with params$!
setorderv(params$dt, params$top.field, -1) # -1 is descending
out <- params$dt[1:params$n,]
I still looking for answers on whether this is the right approach above (in passing parameters in Shiny to RMarkdown apps).
I also want to point out to others that these answers were also useful:
use of ReactiveValues by #NicE https://stackoverflow.com/a/32295811/4606130
What's the difference between Reactive Value and Reactive Expression?
I also made use of copying the dataset to break the reactivity, i.e.
my.dt <- copy(params$dt)
#do this before passing into render params list
Another tip in RStudio is not to use the internal Viewer Pane but to run externally in the browser. This fixed where the temporary file was saved issues. You can choose to always Run Externally under Run App in image below:
I try to create multiple plotly figures in a Rmarkdown document using loop or lapply.
The R script:
require(plotly)
data(iris)
b <- lapply(setdiff(names(iris), c("Sepal.Length","Species")),
function(x) {
plot_ly(iris,
x = iris[["Sepal.Length"]],
y = iris[[x]],
mode = "markers")
})
print(b)
works well, but it fails when included in a knitr chunk:
---
output: html_document
---
```{r,results='asis'}
require(plotly)
data(iris)
b <- lapply(setdiff(names(iris), c("Sepal.Length","Species")),
function(x) {
plot_ly(iris,
x = iris[["Sepal.Length"]],
y = iris[[x]],
mode = "markers")
})
print(b)
```
I tried replacing print(b) with a combination of lapply eval and parse but only the last figure was displayed.
I suspect a scoping/environment issue but I cannot find any solution.
Instead of print(b), put b in htmltools::tagList(), e.g.
```{r}
library(plotly)
b <- lapply(
setdiff(names(iris),
c("Sepal.Length","Species")),
function(x) {
plot_ly(iris,
x = iris[["Sepal.Length"]],
y = iris[[x]],
mode = "markers")
}
)
htmltools::tagList(b)
```
Note: Before Plotly v4 it was necessary to convert the Plotly objects to htmlwidgets using Plotly's as.widget() function. As of Plotly v4 they are htmlwiget objects by default.
For people who are interested in the technical background, you may see this blog post of mine. In short, only top-level expressions get printed.
I found a "dirty" solution by using temp file and kniting it :
```{r,echo=FALSE}
mytempfile<-tempfile()
write("```{r graphlist,echo=FALSE}\n",file=mytempfile)
write(paste("p[[",1:length(p),"]]"),file=mytempfile,append = TRUE)
write("\n```",file=mytempfile,append = TRUE)
```
`r knit_child(mytempfile, quiet=T)`
But it's unsatisfactory.
For anyone struggling with a loop, here's what worked for me.
p=list()
for (n in 1:3){
p[[n]] <- plot_ly(x = 1:100, y = rnorm(100)+n, mode = 'lines', type="scatter")
}
htmltools::tagList(p)
I.e. it doesn't matter if the list p is created in a loop or lapply, etc. as long as you call htmltools::tagList outside the loop.
Thanks to Yihui for helping me get there and for immense work developing and helping with these tools.
I would like to create an automated knitr report that will produce histograms for each numeric field within my dataframe. My goal is to do this without having to specify the actual fields (this dataset contains over 70 and I would also like to reuse the script).
I've tried a few different approaches:
saving the plot to an object, p, and then calling p after the loop
This only plots the final plot
Creating an array of plots, PLOTS <- NULL, and appending the plots within the loop PLOTS <- append(PLOTS, p)
Accessing these plots out of the loop did not work at all
Even tried saving each to a .png file but would rather not have to deal with the overhead of saving and then re-accessing each file
I'm afraid the intricacies of the plot devices are escaping me.
Question
How can I make the following chunk output each plot within the loop to the report? Currently, the best I can achieve is output of the final plot produced by saving it to an object and calling that object outside of the loop.
R markdown chunk using knitr in RStudio:
```{r plotNumeric, echo=TRUE, fig.height=3}
suppressPackageStartupMessages(library(ggplot2))
FIELDS <- names(df)[sapply(df, class)=="numeric"]
for (field in FIELDS){
qplot(df[,field], main=field)
}
```
From this point, I hope to customize the plots further.
Wrap the qplot in print.
knitr will do that for you if the qplot is outside a loop, but (at least the version I have installed) doesn't detect this inside the loop (which is consistent with the behaviour of the R command line).
Wish to add a quick note:
Somehow I googled the same question and get into this page.
Now in 2018, just use print() in the loop.
for (i in 1:n){
...
f <- ggplot(.......)
print(f)
}
I am using child Rmd files in markdown, also works in sweave.
in Rmd use following snippet:
```{r run-numeric-md, include=FALSE}
out = NULL
for (i in c(1:num_vars)) {
out = c(out, knit_child('da-numeric.Rmd'))
}
```
da-numeric.Rmd looks like:
Variabele `r num_var_names[i]`
------------------------------------
Missing : `r sum(is.na(data[[num_var_names[i]]]))`
Minimum value : `r min(na.omit(data[[num_var_names[i]]]))`
Percentile 1 : `r quantile(na.omit(data[[num_var_names[i]]]),probs = seq(0, 1, 0.01))[2]`
Percentile 99 : `r quantile(na.omit(data[[num_var_names[i]]]),probs = seq(0, 1, 0.01))[100]`
Maximum value : `r max(na.omit(data[[num_var_names[i]]]))`
```{r results='asis', comment="" }
warn_extreme_values=3
d1 = quantile(na.omit(data[[num_var_names[i]]]),probs = seq(0, 1, 0.01))[2] > warn_extreme_values*quantile(na.omit(data[[num_var_names[i]]]),probs = seq(0, 1, 0.01))[1]
d99 = quantile(na.omit(data[[num_var_names[i]]]),probs = seq(0, 1, 0.01))[101] > warn_extreme_values*quantile(na.omit(data[[num_var_names[i]]]),probs = seq(0, 1, 0.01))[100]
if(d1){cat('Warning : Suspect extreme values in left tail')}
if(d99){cat('Warning : Suspect extreme values in right tail')}
```
``` {r eval=TRUE, fig.width=6, fig.height=2}
library(ggplot2)
v <- num_var_names[i]
hp <- ggplot(na.omit(data), aes_string(x=v)) + geom_histogram( colour="grey", fill="grey", binwidth=diff(range(na.omit(data[[v]]))/100))
hp + theme(axis.title.x = element_blank(),axis.text.x = element_text(size=10)) + theme(axis.title.y = element_blank(),axis.text.y = element_text(size=10))
```
see my datamineR package on github
https://github.com/hugokoopmans/dataMineR
As an addition to Hugo's excellent answer, I believe that in 2016 you need to include a print command as well:
```{r run-numeric-md, include=FALSE}
out = NULL
for (i in c(1:num_vars)) {
out = c(out, knit_child('da-numeric.Rmd'))
}
`r paste(out, collapse = '\n')`
```
For knitting Rmd to HTML, I find it more convenient to have a list of figures. In this case I get the desirable output with results='hide' as follows:
---
title: "Make a list of figures and show it"
output:
html_document
---
```{r}
suppressPackageStartupMessages({
library(ggplot2)
library(dplyr)
requireNamespace("scater")
requireNamespace("SingleCellExperiment")
})
```
```{r}
plots <- function() {
print("print")
cat("cat")
message("message")
warning("warning")
# These calls generate unwanted text
scater::mockSCE(ngene = 77, ncells = 33) %>%
scater::logNormCounts() %>%
scater::runPCA() %>%
SingleCellExperiment::reducedDim("PCA") %>%
as.data.frame() %>%
{
list(
f12 = ggplot(., aes(x = PC1, y = PC2)) + geom_point(),
f22 = ggplot(., aes(x = PC2, y = PC3)) + geom_point()
)
}
}
```
```{r, message=FALSE, warning=TRUE, results='hide'}
plots()
```
Only the plots are shown and the warnings (which you can switch off, as well).