Question is based on the code proposed by @z-lin : Modifying R Markdown Flexdashboard to Generate Pages and Tabs for comparisons between pairs of vars using Purrr Loops and HTMLWidgets
In the original code, a flexdashboard is generated where each species has a page, and each pair of dimensions has a tab.
I would like to modify it so that it so that for data consisting of group/subgroup/numeric x/y columns it generates corresponding pages/tabs/plots
Here is the data generator that produces a dataframe with group, subgroup and x and y values:
library(tidyverse)
num_groups <- 3
num_subgroups <- 2
# generate group and subgroup names
group_names <- paste0("Group_", 1:num_groups)
subgroup_names <- paste0("Subgroup_", 1:num_subgroups)
groupings <- crossing(group_names, subgroup_names)
# generate x, y data for each subgroup
generate_data <- function(group_name, subgroup_name) {
x <- runif(10)
y <- rnorm(10)
data.frame(x = x, y = y, group = group_name, subgroup = subgroup_name)
}
# iterate through group and subgroup names, generating data for each
df_source<- map2_df(groupings$group_names, groupings$subgroup_names, generate_data)
It returns the table
head(df_source)
x y group subgroup
1 0.2875775 1.7150650 Group_1 Subgroup_1
2 0.7883051 0.4609162 Group_1 Subgroup_1
3 0.4089769 -1.2650612 Group_1 Subgroup_1
4 0.8830174 -0.6868529 Group_1 Subgroup_1
5 0.9404673 -0.4456620 Group_1 Subgroup_1
6 0.0455565 1.2240818 Group_1 Subgroup_1
I modified the code in the link so as instead of pairs of variables, the tabs should refer to subgroups in the new data. My code returns an error that the plotting function misses x and y variables, but they are present in the data. I must be doing some very basic mistake.
---
title: "Flexdashboard"
output: flexdashboard::flex_dashboard
---
```{r setup}
pacman::p_load(tidyverse, flexdashboard, crosstalk, plotly, reactable, reactablefmtr, htmltools)
# set seed for reproducibility
set.seed(123)
# specify number of groups and subgroups to generate
num_groups <- 3
num_subgroups <- 2
# generate group and subgroup names
group_names <- paste0("Group_", 1:num_groups)
subgroup_names <- paste0("Subgroup_", 1:num_subgroups)
groupings <- crossing(group_names, subgroup_names)
# generate x, y data for each subgroup
generate_data <- function(group_name, subgroup_name) {
x <- runif(10)
y <- rnorm(10)
data.frame(x = x, y = y, group = group_name, subgroup = subgroup_name)
}
# iterate through group and subgroup names, generating data for each
df_source<- map2_df(groupings$group_names, groupings$subgroup_names, generate_data)
View(df_source)
df_source.list <- split(df_source, ~group) %>% lapply(function(d) d %>% select(-group))
fn_plot <- function(df, x, y) {
df_reactive <- df[, c(x, y)] %>% highlight_key()
pl <- ggplotly(ggplot(df_reactive, aes(x = get(x), y = get(y))) +
geom_point() +
labs(x = x, y = y))
t <- reactable(df_reactive)
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_source.list, i) {
df.label <- names(df_source.list)[[i]]
df <- df_source.list[[i]]
df.cols <- colnames(df)
# define unique pair combinations
subgroup_names <-
tibble(subgroup = unique(df$subgroup),
label = paste(subgroup))
hcs <- map(.x = seq.int(nrow(subgroup_names)),
~ fn_plot(df,
x = x,
y = y)) %>%
setNames(subgroup_names$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(df_source.list ), function(i) create.page(df_source.list , i)))
````
Please help me correct the error. The code is intended to produce htmlwidgets (a table and a plot) and then produce a flexdashboard html with pages corresponding to groups, tabs corresponding to subgroups and x ~ y scatterplots. Similar to the original question linked in the beginning.
I made some simplifications:
Based on your description, it sounds like the columns x and y are not going to change on the fly; if so, there's actually little need to specify them as part of the parameters to be passed into fn_plot.
Likewise, subgroup_names can simply be a vector instead of a tibble, as we are using the group names themselves as labels.
Making the following changes to the functions (indicated inline with # change here) ran for me without throwing any obvious error. See if it works for you?
fn_plot <- function(df) { # change here
df_reactive <- df[, c("x", "y")] %>% highlight_key() # change here
pl <- ggplotly(ggplot(df, aes(x = x, y = y)) + # change here
geom_point())
t <- reactable(df_reactive)
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_source.list, i) {
df.label <- names(df_source.list)[[i]]
df <- df_source.list[[i]]
df.cols <- colnames(df)
# define unique pair combinations
subgroup_names <- sort(unique(df$subgroup)) # change here
hcs <- map(.x = subgroup_names, # change here
~ fn_plot(df %>% filter(subgroup == .x))) %>% # change here
setNames(subgroup_names) # change here
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))
}