Plotly 无法正确渲染绘图

Question

我正在尝试使用 ggplotly 函数来交互地使用 buraR 包中的trace_explorer 函数创建一个绘图，但生成的绘图不是预期的。

这是代码：

library(ggplot2)
library(bupaR)

patients <- eventdataR::patients # dataset from bupaR

df <- eventlog(patients,
               case_id = "patient",
               activity_id = "handling",
               activity_instance_id = "handling_id",
               lifecycle_id = "registration_type",
               timestamp = "time",
               resource_id = "employee")




tr <- df %>% processmapR::trace_explorer(type = "frequent", coverage = 1.0)

# tr # print the ggplot to see the expected output!
ggplotly(tr)

以及结果图

我尝试使用ggplot2中的主题选项，然后使用布局功能，但结果仍然相同，没有图例。

ggtrace <- trace_explorer(df,
                          type = "frequent", 
                          coverage = 1.0)

ggtrace <- ggtrace + 
  theme (legend.position="none") +
  theme(axis.text.x=element_blank(),
        axis.ticks.x=element_blank(),
        axis.text.y=element_blank(),
        axis.ticks.y=element_blank()
  )

plotly_trace <- ggplotly(ggtrace)

layout(plotly_trace, 
                    margin=list(l=50, b=50), 
                    legend=list(x=1.05)
)

预期的输出应该与原始的 ggplot 类似，但具有来自plotly 的交互式选项。

注意我正在使用以前版本的软件包并希望保留这些版本。

> packageVersion('ggplot2')
[1] ‘3.3.0’
> packageVersion('bupaR')
[1] ‘0.5.2’

Answer 1

你问这个问题已经有一段时间了，但我才发现你的问题。从

ggplot

到

plotly

的转换过程中发生了很多奇怪的事情。

我编写了一个 UDF 来解决所提出的 3 个主要问题：

annotations

、

shapes

和 y 轴网格。

注释：

这是右侧灰色框中的文本。在

ggplotly

对象中，这变成了

"xx.x%<br />xxx<br />xx.x%"

，这很奇怪！前两个注释实际上是轴标题，这也有点奇怪。我将轴标签保留为原样。其余注释是在灰色框中找到的注释。这就是为什么您会在第一次调用

3:length(plt$x$layout$annotations)

时看到

lapply

。在这些修复中，我获取每个注释，拆分值字符串 (“xx.x%
xxx
xx.x%”)，并为每个值创建注释。我将文本更改为居中，而不是左对齐。最后，我将文本位置更改为根据字符串数量递增（以便数字不会彼此重叠）。

形状：

这些是每个水平行周围的形状和矩形的灰色背景。形状交替：长方形、灰块、长方形等。因此，为了捕获修改所需的形状，if 函数会查找 1 和图中形状数量之间的偶数索引值。如果甚至的话，形状大小会更改为动态大小，而不是固定大小（因此，如果您的绘图确实会增大或缩小），文本会居中，并且起始位置会在 3 个块之间增加，因此它们不会位于顶部彼此的。最后，宽度从起始位置开始设置为 0.19（绘图大小的 19%）。 （之所以选择 0.19，是因为我使用 0.20 来增加块位置，留下 0.1，其中 0.1 是块之间的白线。）

y 轴网格：

每行数据出现如此混乱的线条的原因是使用了 y 轴网格，无论您是否在

ggplot

中指定了这一点。因此，UDF 的最后一步是将每个 y 轴（图中的每一行一个）更改为

showgrid = F

。

这使用您问题中提出的对象

plotly_trace

。 （您提供的

layout

参数未得到利用。）代码中的注释可帮助解释发生的情况。它可以进一步巩固，但我认为它可能更容易理解，因为它是写的。

我已经包含了您在我的答案中使用的代码。

library(tidyverse)
library(bupaR)
library(plotly)

patients <- eventdataR::patients # dataset from bupaR

df <- eventlog(patients,
               case_id = "patient",
               activity_id = "handling",
               activity_instance_id = "handling_id",
               lifecycle_id = "registration_type",
               timestamp = "time",
               resource_id = "employee")

tr <- df %>% processmapR::trace_explorer(type = "frequent", coverage = 1.0)

# tr # print the ggplot to see the expected output!
ggplotly(tr)

ggtrace <- trace_explorer(df,
                          type = "frequent", 
                          coverage = 1.0)

(ggtrace <- ggtrace + 
  theme (legend.position="none") +
  theme(axis.text.x = element_blank(),
        axis.ticks.x = element_blank(),
        axis.text.y = element_blank(),
        axis.ticks.y = element_blank()
  ))

plotly_trace <- ggplotly(ggtrace)

buParFix <- function(plt) {
  # annotations 1 & 2 are actually the axis labels (odd)
  repAnn <- invisible(lapply(3:length(plt$x$layout$annotations), function(k) {
    # get text, create separate annot for each text
    tx <- plt$x$layout$annotations[[k]]$text
    trs <- strsplit(tx, "<br />")[[1]] %>% imap(., function(i, j) {
      otr <- plt$x$layout$annotations[[k]]         # collect & copy annot
      otr$text <- i
      otr$xanchor <- "center"                      # horizontal alignment
      otr$x <- 1.1 + ((j - 1) * .2)                # move to the right each iter
      otr
    }) 
    trs
  })) %>% unlist(recursive = F)                    # remove one list of lists level
                                                   # fix text in end caps
  plt$x$layout$annotations <- append(plt$x$layout$annotations[1:2], repAnn)  
  
  shps <- invisible(lapply(1:length(plotly_trace$x$layout$shapes), function(q) {
    if(q %% 2 == 0) {
      tr <- plotly_trace$x$layout$shapes[[q]]      # collect & copy shape
      tr$xsizemode = "scaled"                      # make width dynamic
      tr$xref = "paper"                            # use paper space
      trts <- map(1:3, function(k) {               # three columns to the right
        tr$x0 <- 1 + ((k - 1) * .2)                # set x0 and x1
        tr$x1 <- tr$x0 + .19                       # move to the right each iter
        tr
      })
      return(append(plotly_trace$x$layout$shapes[q - 1], trts)) # return updated shapes
    }
  })) %>% unlist(recursive = F)                    # remove one list of lists level
  
  plt$x$layout$shapes <- shps                      # fix gray background end caps
  
  # fix grid for y-axes
  ys <- length(which(startsWith(names(plt$x$layout), "yaxi"))) # count of y-axes
  lapply(paste0("yaxis", c("", 2:ys)), function(i) {     # hide grid for each
    plt$x$layout[[i]]$showgrid <<- F
  })
  plt %>% layout(margin = list(r = 200))                 # return modified plot
}
buParFix(plotly_trace)