Menu
I've been willing to dynamically create tab contents in rmarkdown.
I've created an in_tabs that seems to work for everything but ggplot plots.
The way it works is that it creates the Rmd code necessary to display nested lists in tabs.
The following reproducible example shows the issue:
---
title: "test"
output: html_document
---
```{r setup, include = FALSE}
library(ggplot2)
library(plotly)
l1 <- list(p1 = data.frame(x=1:10, y=1:10))
l2 <- list(p2 = data.frame(x=100:110, y=100:110))
gplot <- function(data) {
p <- ggplot(data) + aes(x=x, y=y) + geom_point() + geom_line()
return(p)
}
gplotly <- function(data) {
p <- ggplot(data) + aes(x=x, y=y) + geom_point() + geom_line()
return(ggplotly(p))
}
```
```{r, code, include = FALSE}
in_tabs <- function(l, labels = names(l), level, knit = TRUE, close_tabset = FALSE) {
if(is.null(labels)) {
stop("labels are NULL, it is required not to be so that the tabs have proper names")
}
names(l) <- labels
rmd_code <- lapply(seq_along(l), FUN = function(i) obj_to_rmd(l[[i]], name = names(l)[i], level = level + 1L))
if(isTRUE(getOption("knitr.in.progress"))) {
res <- knitr::knit(text = unlist(rmd_code), quiet = TRUE)
cat(res)
} else {
if(!knit) {
cat(unlist(rmd_code))
} else {
return(l)
}
}
if(close_tabset) {
cat(paste(get_section(level), "{.unlisted .unnumbered .toc-ignore .tabset}", "\n"))
}
}
get_section <- function(level) {
paste(rep("#", times = level), collapse = "")
}
get_tabset <- function(obj) {
ifelse(inherits(obj, "list"), "{.tabset}", "")
}
obj_to_rmd <- function(obj, parent_name = "l", name, level) {
section_code <- sprintf("%s %s %s\n", get_section(level), name, get_tabset(obj))
if(!inherits(obj, "list")) {
rmd_code <- c("```{r, echo = FALSE}\n",
sprintf("%s$`%s`\n", parent_name, name),
"```\n",
"\n")
} else {
rmd_code <- c("\n",
lapply(X = seq_along(obj),
FUN = function(i) obj_to_rmd(obj[[i]], sprintf("%s$`%s`", parent_name, name), names(obj)[i], level + 1L)))
}
return(c(section_code, rmd_code))
}
```
# plot 1 {.tabset}
```{r, plot-01, results = "asis"}
in_tabs(lapply(l1, FUN = gplot), labels = names(l1), level = 1L)
```
# plot 2 {.tabset}
```{r, plot-02, results = "asis"}
in_tabs(lapply(l2, FUN = gplot), labels = names(l2), level = 1L)
```
# plot 3 {.tabset}
```{r, plot-03, results = "asis"}
in_tabs(lapply(l1, FUN = gplotly), labels = names(l1), level = 1L)
```
# plot 4 {.tabset}
```{r, plot-04, results = "asis"}
in_tabs(lapply(l2, FUN = gplotly), labels = names(l2), level = 1L)
```
The output I get is:
You can see the issue that the first plot is actually identical the the second plot while it should not !!!
When using plotly (or anything else I have tested) it works as expected as shown on plots 3 and 4
Could you help me fix it, I am happy with testing for the class of the object obj_to_rmd receives.
PS: rmd code in_tabs generates can be seen by running in_tabs(..., knit = FALSE). For instance
in_tabs(lapply(l1, FUN = gplot), labels = names(l1), level = 1L, knit = FALSE)
## p1
```{r, echo = FALSE}
plot(l$`p1`)
```
300
As stefan mentioned, the issue is with the ggplot's id, since they somehow have the same code chunk, even though you named the chunks differently.I don't know the reason for this behaviour, but you can bypass it by setting
```{r, include=FALSE}
options(knitr.duplicate.label = "allow")
```
at the beginning of your document. That should do the trick. It will give different chunk names to each of your plots. You can verify that by removing results = "asis"from your ggplots to see that they no longer have the same id.
## ## p1
##
## <img src="test_files/figure-html/unnamed-chunk-2-1.png" width="672" />
## ## p2
##
## <img src="test_files/figure-html/unnamed-chunk-1-2-1.png" width="672" />
You can read more about allowing duplicated chunks at bookdown.org
168
I'm not 100% sure about all the details so you have to keep in mind that may answer involves some guessing.
When knitting the document knitr runs the ggplot2 code and saves the resulting plot as a png where the filename is the name of the chunk.
As far as I got it from inspecting the md file generated by knitr (by adding keep_md: true to the YAML) the issue with your code is, that "all" plots are saved under the same filename unnamed-chunk-1-1.png, i.e. both of your ggplot chunks look like this in the final md:
<!-- -->
This could also be seen by having a look the the figure-html folder which includes only one png.
Put differently your code basically works fine, but you are permanently overwriting the pngs so you end up with a document where only the last saved plot shows up. That's also the reason why your code works for ggplotly as in that case the HTML/JS code necessary to render the chart is directly added to the md file.
Under normal circumstances knitr ensures that all plots are saved under unique filenames. I can only guess why this fails in your case. My guess is that the issue is that you knit each chunk separately when calling knitr::knit(text = unlist(rmd_code), quiet = TRUE), i.e. each unnamed chunk gets the same name and each is ggplot is accordingly saved under the same filename.
Having said that, to achieve your desired result you could add a unique name to each of the dynamic code chunks so that each plot is saved under a unique filename.
As a quick solution I added an id argument to your in_tabs and obj_to_rmd functions. In case of in_tabs the id is simple the identifier of the chunk in your main document, while in case of obj_to_rmd I additionally add an identifier for the list element via id = paste(id, i, sep = "-"):
---
title: "test"
output:
html_document:
keep_md: true
---
```{r setup, include = FALSE}
library(ggplot2)
library(plotly)
d1 <- data.frame(x = 1:10, y = 1:10)
d2 <- data.frame(x = 100:110, y = 100:110)
l1 <- list(p1 = d1)
l2 <- list(p1 = d2, p2 = d1)
gplot <- function(data) {
ggplot(data) +
aes(x = x, y = y) +
geom_point() +
geom_line()
}
```
```{r, code, include = FALSE}
in_tabs <- function(l, labels = names(l), level, knit = TRUE, close_tabset = FALSE, id) {
if (is.null(labels)) {
stop("labels are NULL, it is required not to be so that the tabs have proper names")
}
names(l) <- labels
rmd_code <- lapply(seq_along(l), FUN = function(i) obj_to_rmd(l[[i]], name = names(l)[i], level = level + 1L, id = paste(id, i, sep = "-")))
if (isTRUE(getOption("knitr.in.progress"))) {
res <- knitr::knit(text = unlist(rmd_code), quiet = TRUE)
cat(res)
} else {
if (!knit) {
cat(unlist(rmd_code))
} else {
return(l)
}
}
if (close_tabset) {
cat(paste(get_section(level), "{.unlisted .unnumbered .toc-ignore .tabset}", "\n"))
}
}
get_section <- function(level) {
paste(rep("#", times = level), collapse = "")
}
get_tabset <- function(obj) {
if (inherits(obj, "list")) "{.tabset}" else ""
}
obj_to_rmd <- function(obj, parent_name = "l", name, level, id) {
section_code <- sprintf("%s %s %s\n", get_section(level), name, get_tabset(obj))
if (!inherits(obj, "list")) {
rmd_code <- c(
sprintf("```{r plot-%s, echo = FALSE}\n", id),
sprintf("%s$`%s`\n", parent_name, name),
"```\n",
"\n"
)
} else {
rmd_code <- c(
"\n",
lapply(
X = seq_along(obj),
FUN = function(i) obj_to_rmd(obj[[i]], sprintf("%s$`%s`", parent_name, name), names(obj)[i], level + 1L)
)
)
}
return(c(section_code, rmd_code))
}
```
# plot 1 {.tabset}
```{r, plot-01, results = "asis"}
p1 <- lapply(l1, FUN = gplot)
in_tabs(p1, labels = names(l1), level = 1L, id = 1)
```
# plot 2 {.tabset}
```{r, plot-02, results = "asis"}
p2 <- lapply(l2, FUN = gplot)
in_tabs(p2, labels = names(l2), level = 1L, id = 2)
```
34
If you love us? You can donate to us via Paypal or buy me a coffee so we can maintain and grow! Thank you!
Donate Us With
