Iterating to create tabs with gt in quarto - tidyverse

Something that is very handy is to iterate through a variable and then dynamically create tabs based on values of that variable (here homeworld). This works well with the results: asis chunk option. I can make that work but there is some strange interaction with the {gt} package whereby I can only make gt work with purrr::walk if I use gt::as_raw_html. However if I just produce a single table outside of purrr::walk I don't need gt::as_raw_html. Here is the error message I get {gt} does not work:
Error running filter
/Applications/quarto/share/filters/quarto-pre/quarto-pre.lua:
...lications/quarto/share/filters/quarto-pre/quarto-pre.lua:2410:
attempt to concatenate a nil value (local 'v') stack traceback:
...lications/quarto/share/filters/quarto-pre/quarto-pre.lua:2417: in
function
<...lications/quarto/share/filters/quarto-pre/quarto-pre.lua:2415>
Here is the quarto (quarto version 1.1.175) code to reproduce:
---
title: "Untitled"
format: html
execute:
warning: false
---
```{r r-pkgs}
library(dplyr)
library(glue)
library(gt)
library(purrr)
## just to simplify
starwars <- starwars %>%
filter(!is.na(sex))
```
# Does work
::: {.panel-tabset}
```{r}
#| results: asis
walk(
unique(starwars$sex), \(hw) {
cat(glue("## {hw} \n\n"))
starwars %>%
filter(sex == hw) %>%
count(homeworld) %>%
head() %>%
gt() %>%
as_raw_html() %>%
print()
cat("\n\n")
}
)
```
:::
# Does not work
::: {.panel-tabset}
```{r}
#| results: asis
#| eval: false
walk(
unique(starwars$sex), \(hw) {
cat(glue("## {hw} \n\n"))
starwars %>%
filter(sex == hw) %>%
count(homeworld) %>%
head() %>%
gt() %>%
print()
cat("\n\n")
}
)
```
:::
## single does work
```{r}
#| results: asis
starwars %>%
count(homeworld) %>%
head() %>%
gt()
```

Posting back answer from the duplicate issue in quarto-dev/quarto-cli#2370
About the issue
The behavior you see has to do with the print method used, and the iteration with walk()
When you use print() after gt() or after gt() %>% as_raw_html() it will not have the same effect, as the print method used will not be the same. In the context of knitr, this matters.
Using as_raw_html() makes sense to include table as raw HTML in such document, and it probably will have the same result as when gt object are printing in knitting to HTML table (though the use of htmltools). When you use gt() %>% print(), it will not use the correct printing method that is used when just gt() is in a chunk (the knit_print() method more on that here for advanced understanding.
More on how to create content dynamically with knitr
Let me add some context about knitr and dynamically created content.
Iterating to dynamically create content in knitr require to use the correct print method (usually knit_print()), and it is better to iterate on child content with knitr::knit_child() function that will correctly handle the printed output specific to sewing result in the document. We have some resource about that in R Markdown Cookbook that would apply to Quarto as well.
About knit_child() : https://bookdown.org/yihui/rmarkdown-cookbook/child-document.html
About knit_expand() also : https://bookdown.org/yihui/rmarkdown-cookbook/knit-expand.html
As an example, this is how we recommend to dynamically create content when using knitr content so that R code result is correctly mixed with other content, specifically when the content to dynamically create is a mix of raw markdown, and R code results.
---
title: "Untitled"
format: html
execute:
warning: false
keep-md: true
---
```{r r-pkgs}
library(dplyr)
library(glue)
library(gt)
library(purrr)
## just to simplify
starwars <- starwars %>%
filter(!is.na(sex))
```
# Tables
::: {.panel-tabset}
```{r}
#| output: asis
res <- purrr::map_chr(unique(starwars$sex), \(hw) {
knitr::knit_child(text = c(
"## `r hw`",
"",
"```{r}",
"#| echo: false",
"starwars %>%",
" filter(sex == hw) %>%",
" count(homeworld) %>%",
" head() %>%",
" gt()",
"```",
"",
""
), envir = environment(), quiet = TRUE)
})
cat(res, sep = '\n')
```
:::
You could also put the child content in a separate file for easier writing as in the Cookbook, by writing what you would need as document for one value you are iterating
## `r hw`
```{r}
#| echo: false
starwars %>%
filter(sex == hw) %>%
count(homeworld) %>%
head() %>%
gt()
```
This is the safest way to mix markdown content (like ##) with R code output ( like Tables or Htmlwidgets) which are content you can't easily just cat() into the file.
See more in the issue

Related

How to modify ggboxplot (ggpubr) to suppress whiskers, but retain access to other boxplot customisations?

Originally I asked this question about suppressing the whiskers on a boxplot made by ggboxplot. (The expected way of setting a geom_boxplot option was not available.) A nice solution appeared which suited the original question. However, the broader question to address is how to suppress whiskers on the boxplot but still retain access to the nice additions in ggpubr, such as being able to automatically compute statistical test results and place these on a boxplot.
I tinkered with the solution from #Julian_Hn to get something like what I want.
There are two issues that someone more knowledgeable might be able to help with, now that I've asked the broader question:
Are there ways to make the solution more efficient?
How can I add in the ability to change the range of x-values? (I tried various methods using ggpar and coord_cartesian, with no effect. I might be lacking knowledge of how to use commands like ggplot_build effectively.)
Here's an example where I suppress whiskers and use stat_kruskal_test to label the boxplot:
ggboxplot_whisker_opt <- function(...)
{
opts <- list(...) # Modification of original question solution to include the original labelled ggboxplot with whiskers and stat info added
# Check if user specified a whiskers arg and set options accordingly
if("whisker" %in% names(opts))
{
whisk <- opts$whisker
opts$whisker <- NULL
} else {
whisk <- TRUE
}
# Additional arguments that might need generalising so that other statistical tests can be used in other applications
if ("kruskal" %in% names(opts))
{ kruskal<-opts$kruskal
opts$kruskal <- NULL
opt.group <- opts$kruskal.options[[1]]
opt.label<- opts$kruskal.options[[2]]
opt.y <- opts$kruskal.options[[3]]
opt.x <- opts$kruskal.options[[4]]
opts$kruskal.options <- NULL
}
pl <- do.call(ggboxplot,opts) # create plot by calling ggboxplot with all user options
if (kruskal){ pl <- pl + stat_kruskal_test(group.by=opt.group,label=opt.label, label.y.npc=opt.y,label.x.npc=opt.x) }
if(!whisk)
{ pl_list <- ggplot_build(pl) # get listed version of ggboxplot object to modify
pl_list$data[[1]]$ymin <- NA # remove the ymin/max that specify the whiskers
pl_list$data[[1]]$ymax <- NA
pl <- ggplot_gtable(pl_list) # convert back to ggplot object
}
# return
pl
}
Here's the application:
set.seed(123)
x <-rnorm(100)
labels <- round(runif(100,1,2))
df <- data.frame(labels=labels, value=x)
# Define the options for the stat_kruskal_test label
KO <- list("group"="labels","label"="as_detailed_italic", "label.y.npc"=0.5,"label.x.npc"=0.5,ylim=c(-1.2, 1.2))
# call the function
output.plot <- ggboxplot_whisker_opt(df, "labels","value", col="labels", legend="none", whisker=FALSE,add=c("mean"), orientation="horizontal" kruskal=TRUE,kruskal.options=KO)
# Plot the result
plot(output.plot)
the issue with modifying was that the returned object was not a ggplot object anymore (wrong comment on my side) but a plot object. I have thought about it and instead of modifying the ggbuilt object, it's also possible to directly pass the coef=0 through to the geom_boxplot layer inside the object returned by ggboxplot:
ggboxplot_whisker_opt <- function(...)
{
opts <- list(...)
# check if user specified a whiskers argument and set options accordingly
if("whisker" %in% names(opts))
{
whisk <- opts$whisker
opts$whisker <- NULL
} else {
whisk <- TRUE
}
pl <- do.call(ggpubr::ggboxplot, opts) # create plot by calling ggboxplot with all user options
if(!whisk)
{
pl$layers[[1]]$stat_params$coef <- 0 # modify coef param of geom_boxplot layer
}
# plot the ggplot and return so other ggplot parts can be added via `+`
pl
}
This function now returns an object compatible with ggpar or adding other ggplot modifiers via +
library(ggplot2)
library(ggpubr)
set.seed(123)
x <- rnorm(100)
labels <- round(runif(100,1,2))
df <- data.frame(labels=labels,
value=x)
testplot <- ggboxplot_whisker_opt(df,"labels","value",whisker=FALSE)
ggpar(testplot,xlim=c(0.5,1.5),
ylim=c(-0.5,0.5))
testplot +
geom_line(data=data.frame(x=c(1,2),y=c(0,0)),aes(x=x,y=y),color="red",lwd=2)

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')
```

R Shiny: Build an interactive SQL query and copy data into global environment

I try to build a shiny app that enables users to query data. Users are supposed to provide a list of values of interest that are used to filter data stored in a database. Unfortunately, dplyr's translation does not appear to be the most efficient/performant solution such that I have to build a string and pass it to the database via sql(). The string manipulations are also a crude fail safe to handle entry errors/varieties. The following code illustrates this string building and data query process:
library(tibble)
library(dplyr)
library(dbplyr)
library(shiny)
library(RSQLite)
library(DBI)
library(stringr)
# Create string variables to experiment
mtcars1 <- tibble::rownames_to_column(mtcars, var = "model") %>% # Create column based on row names
dplyr::mutate(carmaker = stringr::word(model, 1)) # Create column with first word of column with row names
# Establish example database
con <- DBI::dbConnect(RSQLite::SQLite(), path = ":memory:")
copy_to(con, mtcars1, "mtcars1", temporary = FALSE)
# Query example
# Input
string_input <- "Mazda, Merc"
# Prepare input string to be used in SQL
string_filter <- string_input %>%
base::gsub("[,]+", " ", .) %>% # remove commas
stringr::str_squish(.) %>% # remove multiple blanks
base::gsub(" ", ",", .) %>% # substitute blanks for commas
base::gsub("(\\w+)", "'\\1'", .) %>% # enclose words with single quotation marks
base::paste0("carmaker in (", ., ")") # create sql where statement
# Data query
data <- tbl(con, "mtcars1") %>%
filter(sql(string_filter)) %>%
show_query() %>%
collect()
I'd like to implement this code in a shiny app:
# Shiny user interface
ui <- fluidPage(
textInput(inputId = "string_input", label = "Input", value = "", placeholder = "Enter list of car models without commas"),
actionButton(inputId = "go", label = "Go"),
textOutput(outputId = "string_output")
)
# Shiny server function
server <- function(input, output){
observeEvent(input$go, {
output$string_output <- reactive({input$string_input %>%
base::gsub("[,]+", " ", .) %>% # remove commas
stringr::str_squish(.) %>% # remove multiple blanks
base::gsub(" ", ",", .) %>% # substitute blanks for commas
base::gsub("(\\w+)", "'\\1'", .) %>% # enclose words with single quotation marks
base::paste0("carmaker in (", ., ")") # create sql where statement
})
})
}
# Launch shiny app
shinyApp(ui, server)
The app takes to list of values supplied by the user as input, transforms it and shows the transformed list as output.
Here is what I want to do:
I would like store the transformed string_input in an extra local object for further use in the app, that is, I want to pass the string_input to the data query similar to the non-shiny example above.
I would like to copy the data query result to R's global environment such that I can use it, even after closing the app.
Regarding the my second point: I read that one can use <- and <<-, but I could not make it work in a reactive context.
I figured out the solution:
library(tibble)
library(dplyr)
library(dbplyr)
library(shiny)
library(RSQLite)
library(DBI)
library(stringr)
# Create string variables to experiment
mtcars1 <- tibble::rownames_to_column(mtcars, var = "model") %>% # Create column based on row names
dplyr::mutate(carmaker = stringr::word(model, 1)) # Create column with first word of column with row names
# Establish example database
con <- DBI::dbConnect(RSQLite::SQLite(), path = ":memory:")
copy_to(con, mtcars1, "mtcars1", temporary = FALSE)
# Shiny user interface
ui <- fluidPage(
textInput(inputId = "string_input",
label = "Input",
value = "",
placeholder = "Enter a list of car makers (e.g. Mazda, Merc)"),
textOutput(outputId = "string_output"),
actionButton(inputId = "go", label = "Go"),
tableOutput(outputId = "data_output")
)
# Custom function to save reactive object to global environment
saveData <- function(x) {
export <<- x
}
# Shiny server function
server <- function(input, output){
list <- reactive({
input$string_input %>%
base::gsub("[,]+", " ", .) %>% # remove commas
stringr::str_squish(.) %>% # remove multiple blanks
base::gsub(" ", ",", .) %>% # substitute blanks for commas
base::gsub("(\\w+)", "'\\1'", .) %>% # enclose words with single quotation marks
base::paste0("carmaker in (", ., ")") # create sql where statement
})
output$string_output <- reactive({list()})
data <- eventReactive(input$go, {
tbl(con, "mtcars1") %>%
dplyr::filter(sql(!!list())) %>%
dplyr::collect()
})
output$data_output <- renderTable(data())
observeEvent(input$go, {
saveData(data())
})
}
# Launch shiny app
shinyApp(ui, server)
The trick was to define the function saveData, pass the reactive data object to it and assign it to export via <<-.
Honestly, I do not understand all of the fundamentals so any suggestions for improvement are welcome. However, it works.
For your first question:
# Shiny server function
server <- function(input, output){
string_output <- eventReactive(input$go, {
input$string_input %>%
base::gsub("[,]+", " ", .) %>% # remove commas
stringr::str_squish(.) %>% # remove multiple blanks
base::gsub(" ", ",", .) %>% # substitute blanks for commas
base::gsub("(\\w+)", "'\\1'", .) %>% # enclose words with single quotation marks
base::paste0("carmaker in (", ., ")") # create sql where statement
})
output$string_output <-renderText(string_output())
}
string_output() reactive function is now available for output as well as for data query.
Note that you could also use input$string_input instead of input$goas trigger to update the output while you type the criteria.
You can then use input$go to query the data:
data <- eventReactive(input$go, { dbGetQuery(yourConnection,YourQuery(string_output())})
output$data <- renderTable(data())
Not sure you can directly write from Shiny to R's environment, but you can for sure save data() as a file on the server.

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))
})
```

Can we bind three plots using rbind_gtable in shiny dashboard to download all the plots together?

Trouble combining multiple shiny plots and downloading through a single click.
Code below is from the answer here: Solution
I tried this solution. It works fine for two plots but as soon as I add another plot it only returns the graph information but not the graph themselves.
Combining two plots works fine.
I also tried other solutions but both of the solutions when implemented returns a text file instead of pdf or pdf file that is corrupted.
Solution1
Solution2
Any suggestion would be really appreciated. Thank you!
Code
library(ggplot2)
ui <- shinyUI(fluidPage(
titlePanel("Test app"),
fluidRow(
column(4,
wellPanel(
downloadButton('download',label="Download plot as png")
)
),
column(8,
plotOutput("plot")
)
)
))
server <- function(input,output) {
plotting<- reactive({
data1=data.frame(x=rnorm(50),y=rnorm(50))
data2=data.frame(x=rexp(50),y=rexp(50))
data3=data.frame(x=rexp(50),y=rexp(50))
plot1=ggplot(data1,aes(x,y))+geom_point()
plot2=ggplot(data2,aes(x,y))+geom_point()
plot3=ggplot(data3,aes(x,y))+geom_point()
gb1=ggplot_build(plot1)
gb2=ggplot_build(plot2)
gb3=ggplot_build(plot3)
gA <- ggplot_gtable(gb1)
gB <- ggplot_gtable(gb2)
gC <- ggplot_gtable(gb3)
both <- gtable:::rbind_gtable(gA, gB, "last")
all <- gtable:::rbind_gtable(both, gC, "last")
return(all)
})
output$plot <- renderPlot({
grid.newpage()
grid.draw(plotting())
})
output$download <- downloadHandler(
filename <- "shinytestplot.png",
# Changes:
content <- function(file){ ## file = NULL --> file
png(file) # filename --> file
grid.newpage()
grid.draw(plotting())
dev.off()
}
)
}
shinyApp(server=server,ui=ui)
Your example works just fine for me. However, I'd recommend against rbinding plots. Use the patchwork package instead.
library(ggplot2)
library(shiny)
library(patchwork)
ui <- shinyUI(fluidPage(
titlePanel("Test app"),
fluidRow(
column(4,
wellPanel(
downloadButton('download',label="Download plot as png")
)
),
column(8,
plotOutput("plot")
)
)
))
server <- function(input,output) {
plotting<- reactive({
data1=data.frame(x=rnorm(50),y=rnorm(50))
data2=data.frame(x=rexp(50),y=rexp(50))
data3=data.frame(x=rexp(50),y=rexp(50))
plot1=ggplot(data1,aes(x,y))+geom_point()
plot2=ggplot(data2,aes(x,y))+geom_point()
plot3=ggplot(data3,aes(x,y))+geom_point()
# stack the plots on top of one another with patchwork
plot1 / plot2 / plot3
})
output$plot <- renderPlot({
print(plotting())
})
output$download <- downloadHandler(
filename <- "shinytestplot.png",
# Changes:
content <- function(file){
ggsave(file, plotting())
}
)
}
shinyApp(server=server,ui=ui)