How can I modify my existing R Markdown flexdashboard code to generate a dashboard with pages and tabs corresponding to subgroups and data in a dataframe, using purrr loops and htmlwidgets?
Currently, my code uses purrr loops to create tabs for each subgroup (Species) with a connected flextable and ggplotly plot using crosstalk. However, I want to modify the code so that it generates pages for each Species in the dataset, and within each page, display pairwise comparisons using htmlwidgets.
The current code generates two pages for comparison (not in a loop, hardcoded) and tabs for each species. I would appreciate some guidance on modifying the syntax to generate pages for each Iris Species, and within each page, several tabs that contain an x y plot each for pairs of dimensions of this species.
I hope the answer may be useful to those analysts, who have no infrastructure to start a shiny server but would like to provide a comprehensive and interactive report, cross-secting groups and subgroups.
Thank you for your help!
---
title: "Flexdashboard"
output: flexdashboard::flex_dashboard
---
```{r setup}
pacman::p_load(tidyverse, flexdashboard, crosstalk, plotly, reactable, reactablefmtr, htmltools)
labels <- unique(as.character(iris$Species))
fn_plot <- function(df = iris, x, y, grp ) {
df <- df %>% filter(Species == {{grp}})
df_reactive <- highlight_key(df)
pl <- df_reactive %>%
ggplot(aes(x = get(x), y =get(y))) +
geom_point()
pl <-
ggplotly(pl)
t <- df_reactive %>% reactable()
output <-
bscols(widths = c(6, NA),
div(style = css(width = "100%", height = "100%"),
list( t)),
div(style = css(width = "100%", height = "700px"),
list(pl)))
return(output)
}
hcs <-
map(.x = labels, ~ fn_plot(iris, x = "Sepal.Length", y = "Sepal.Width", grp = .x )) %>%
setNames(labels)
hcs2 <-
map(.x = labels, ~ fn_plot(iris, x = "Petal.Length", y = "Petal.Width", grp = .x )) %>%
setNames(labels)
```
Page 1
====================
Column {.tabset .tabset-fade}
-----------------------------
```{r chunkA}
out <- map(seq_along(hcs), function(i) {
a1 <- knitr::knit_expand(text = sprintf("### %s\n", names(hcs)[i]))
a2 <- knitr::knit_expand(text = "\n```{r}")
a3 <- knitr::knit_expand(text = sprintf("\nhcs[[%d]]", i))
a4 <- knitr::knit_expand(text = "\n```\n")
paste(a1, a2, a3, a4, collapse = '\n')
})
```
`r paste(knitr::knit(text = paste(out, collapse = '\n')))`
Page 2
====================
Column {.tabset .tabset-fade}
-----------------------------
```{r chunkB}
out2 <- map(seq_along(hcs2), function(i) {
a1 <- knitr::knit_expand(text = sprintf("### %s\n", names(hcs2)[i]))
a2 <- knitr::knit_expand(text = "\n```{r}")
a3 <- knitr::knit_expand(text = sprintf("\nhcs2[[%d]]", i))
a4 <- knitr::knit_expand(text = "\n```\n")
paste(a1, a2, a3, a4, collapse = '\n')
})
```
`r paste(knitr::knit(text = paste(out2, collapse = '\n')))`
I haven't played around with flexdashboard, but I've done similar things in R Markdown to generate a flexible number of PowerPoint slides, so here's my attempt.
The general idea is that we use one (& only one) chunk of R code with results = "asis" to generate any number of pages, controlled by a function (creatively named create.page) that prints out the necessary markdown syntax for each page.
I also made minor changes to the fn_plot function, for more intuitive x/y axis labels and kept only relevant columns in each table.
---
title: "Flexdashboard"
output: flexdashboard::flex_dashboard
---
```{r setup}
pacman::p_load(tidyverse, flexdashboard, crosstalk, plotly, reactable, reactablefmtr, htmltools)
iris.list <- split(iris, ~Species) %>% lapply(function(d) d %>% select(-Species))
fn_plot <- function(df, x, y) {
df <- df[, c(x, y)] %>% highlight_key()
pl <- ggplotly(ggplot(df, aes(x = get(x), y = get(y))) +
geom_point() +
labs(x = x, y = y))
t <- reactable(df)
output <-
bscols(widths = c(6, NA),
div(style = css(width = "100%", height = "100%"),
list(t)),
div(style = css(width = "100%", height = "700px"),
list(pl)))
return(output)
}
create.page <- function(df.list, i) {
df.label <- names(df.list)[[i]]
df <- df.list[[i]]
df.cols <- colnames(df)
# define unique pair combinations
pair.combinations <- expand.grid(seq.int(length(df.cols)), seq.int(length(df.cols))) %>%
filter(Var1 < Var2) %>%
mutate(Var1 = df.cols[Var1],
Var2 = df.cols[Var2],
label = paste(Var1, Var2, sep = " vs. "))
hcs <- map(.x = seq.int(nrow(pair.combinations)),
~ fn_plot(df,
x = pair.combinations$Var1[.x],
y = pair.combinations$Var2[.x])) %>%
setNames(pair.combinations$label)
out <- map(seq_along(hcs), function(i) {
a1 <- knitr::knit_expand(text = sprintf("### %s\n", names(hcs)[i]))
a2 <- knitr::knit_expand(text = "\n```{r}")
a3 <- knitr::knit_expand(text = sprintf("\nhcs[[%d]]", i))
a4 <- knitr::knit_expand(text = "\n```\n")
paste(a1, a2, a3, a4, collapse = '\n')
})
cat("Page", i, "-", df.label, "\n")
cat("====================\n")
cat("Column {.tabset .tabset-fade}\n")
cat("-----------------------------\n")
cat(knitr::knit(text = paste(out, collapse = '\n'),
quiet = TRUE))
}
```
```{r iterate, results='asis'}
# wrapping with invisible() to suppress the NULL returns
invisible(lapply(seq_along(iris.list), function(i) create.page(iris.list, i)))
```
Thanks for giving me a reason to learn about flexdashboard :)