在 Rmarkdown 中动态创建选项卡不适用于 ggplot,而它适用于 plotly

Posted

技术标签:

【中文标题】在 Rmarkdown 中动态创建选项卡不适用于 ggplot,而它适用于 plotly【英文标题】:Dynamic creation of tabs in Rmarkdown does not work for ggplot while it does for plotly 【发布时间】:2021-11-20 00:28:30 【问题描述】:

我一直愿意在rmarkdown 中动态创建tab 内容。

我创建了一个in_tabs,它似乎适用于除ggplot 情节之外的所有内容。

它的工作方式是创建在选项卡中显示嵌套列表所必需的Rmd 代码。

以下可重现的示例显示了该问题:

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

                                                        

我得到的输出是:

您可以看到第一个图实际上与第二个图相同的问题,但它不应该!!!

当使用plotly(或我测试过的任何其他东西)时,它会按图 3 和图 4 所示的预期工作

你能帮我解决它吗,我很高兴测试obj_to_rmd接收的对象的类。

PS:rmd 代码in_tabs 生成可以通过运行in_tabs(..., knit = FALSE) 看到。比如

in_tabs(lapply(l1, FUN = gplot), labels = names(l1), level = 1L, knit = FALSE)
## p1 
 ```r, echo = FALSE
 plot(l$`p1`)
 ```

【问题讨论】:

【参考方案1】:

正如 stefan 所提到的,问题出在 ggplot 的 id 上,因为它们在某种程度上具有相同的代码块,即使您以不同的方式命名这些块。我不知道这种行为的原因,但您可以通过设置绕过它

```r, include=FALSE
options(knitr.duplicate.label = "allow")
```

在文档的开头。这应该够了吧。它将为您的每个地块提供不同的块名称。您可以通过从 ggplots 中删除 results = "asis" 来验证这一点,以查看它们不再具有相同的 id。

## ## p1 
## 
## <img src="test_files/figure-html/unnamed-chunk-2-1.png"  />


## ## p2 
## 
## <img src="test_files/figure-html/unnamed-chunk-1-2-1.png"  />

您可以在bookdown.org阅读更多关于允许重复块的信息

【讨论】:

非常感谢,我在“创建”的块上添加了一个随机字符串【参考方案2】:

我不能 100% 确定所有细节,因此您必须记住,答案可能涉及一些猜测。

在编织文档knitr 时运行ggplot2 代码并将生成的绘图保存为png,其中文件名是块的名称。

据我检查knitr 生成的md 文件(通过将keep_md: true 添加到YAML),您的代码的问题是,“所有”图都保存在相同的文件名下@ 987654329@,即你的两个ggplot块在最终的md中看起来像这样:

![](bar1_files/figure-html/unnamed-chunk-1-1.png)<!-- -->

这也可以通过查看仅包含一个 pngfigure-html 文件夹来查看。

换一种说法,您的代码基本上可以正常工作,但是您会永久覆盖pngs,因此您最终会得到一个仅显示最后保存的绘图的文档。这也是您的代码适用于 ggplotly 的原因,因为在这种情况下,呈现图表所需的 HTML/JS 代码直接添加到 md 文件中。

在正常情况下knitr 确保所有绘图都保存在唯一的文件名下。我只能猜测为什么在你的情况下这会失败。我的猜测是,问题在于您在调用knitr::knit(text = unlist(rmd_code), quiet = TRUE) 时分别编织每个块,即每个未命名的块都具有相同的名称,并且每个 ggplot 都相应地保存在相同的文件名下。

话虽如此,为了达到您想要的结果,您可以为每个动态代码块添加一个唯一的名称,以便每个绘图都保存在一个唯一的文件名下。

作为一个快速的解决方案,我在in_tabsobj_to_rmd 函数中添加了一个id 参数。在in_tabs 的情况下,id 是主文档中块的简单标识符,而在obj_to_rmd 的情况下,我还通过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)
```    

【讨论】:

原来如此,非常感谢

以上是关于在 Rmarkdown 中动态创建选项卡不适用于 ggplot,而它适用于 plotly的主要内容,如果未能解决你的问题,请参考以下文章

Apache.org上的问题并不适用于Apache Cordova的创建问题选项卡

从选项卡注销,不适用于所有其他选项卡

单击事件不适用于以编程方式/动态创建的选项按钮

禁用的字段集内的引导选项卡不适用于Firefox

引导选项卡不适用于 history.back 选项

TabbedPage 选项卡图标不适用于字体真棒