Plotly Heatmap & Scatter, связанный в блестящем не работает в модуле

Question

Следуя примеру: https://plot.ly/r/shinyapp-linked-click/ Я смог в чистом блестящем проекте получить эту работу (корреляционная матрица, связанная с графом рассеяния). Тем не менее, когда я делаю то же самое в блестящем модуле, действие действия click_data на основе событий не работает (разброс остается пустым, а не то, что происходит, похоже, что клик не подключается).

Мой воспроизводимый пример ниже, любые идеи или решения будут высоко оценены.

library(plotly) 

#### Define Modules #### 
correlation_matrix_shinyUI <- function(id) { 
    ns <- NS(id) 

    mainPanel(
    plotlyOutput(ns("corr_matrix"), height = '650px'), 
    plotlyOutput(ns("scatterplot"), height = '550px') 
) 
} 

correlation_matrix_shiny <- function(input, output, session) { 

    data_df <- reactive({ 
    mtcars 
    }) 

    corr_data <- reactive({ 
    if (is.null(data_df())) 
     return() 

    corr_data <- cor(data_df()) 
    diag(corr_data) <- NA 
    corr_data <- round(corr_data, 4) 
    corr_data 
    }) 

    corr_names <- reactive({ 
    if (is.null(data_df())) 
     return() 

    corr_names <- colnames(data_df()) 
    corr_names 
    }) 

    output$corr_matrix <- renderPlotly({ 
    if (is.null(corr_names())) 
     return() 
    if (is.null(corr_data())) 
     return() 


    g <- plot_ly(x = corr_names(), y = corr_names(), z = corr_data(), 
     key = corr_data(), type = "heatmap", source = "CORR_MATRIX", zmax = 1, zmin = -1) 
    g 
    }) 

    output$scatterplot <- renderPlotly({ 
    if (is.null(data_df())) 
     return() 

    data_use <- data_df() 

    s <- event_data("plotly_click", source = "CORR_MATRIX") 

    if (length(s)) { 
     vars <- c(s[["x"]], s[["y"]]) 
     d <- setNames(data_use[vars], c("x", "y")) 
     yhat <- fitted(lm(y ~ x, data = d)) 
     plot_ly(d, x = x, y = y, mode = "markers") %>% 
     plotly::add_trace(x = x, y = yhat, mode = "lines") %>% 
     plotly::layout(xaxis = list(title = s[["x"]]), 
      yaxis = list(title = s[["y"]]), 
      showlegend = FALSE) 
    } else { 
     plot_ly() 
    } 
    }) 

} 
############ End Module Definition ###### 

ui <- fluidPage(
    sidebarLayout(
    sidebarPanel(
    ), 
    correlation_matrix_shinyUI(id = "cor_module") 
) 
) 

server <- function(input, output, session) { 
    callModule(correlation_matrix_shiny, id = "cor_module") 
} 

shinyApp(ui = ui, server = server) 

Answer 1

Ваш вопрос действительно интересный. Я отвечу с некоторыми текстовыми отрывками из shiny modules page.

Прежде всего, ваша проблема - обзорный вопрос. Более подробно:

[...] input, output и session не может быть использован для входов/выходов, которые находятся вне пространства имен доступа, они не могут получить доступ непосредственно реакционноспособные выражения и реактивных значения из других районов применение [...]

в модуле, вы пытаетесь получить доступ к plotly собственности и, следовательно, на уровне сервера переменной event_data, который используется для хранения нажмите (или другие) события. Участки реагируют нормально, так как вы могли бы добавить, добавили бы вы

observe({print(event_data("plotly_click", source = "CORR_MATRIX"))}) 

внутри вашей серверной функции (и вне модуля). Но этот тип ввода не определялся непосредственно в пространстве имен correlation_matrix_shinyUI, и поэтому он остается недоступным.

Эти ограничения по дизайну, и они важны. Цель состоит не в том, чтобы блокировать взаимодействие модулей с их содержащими приложениями, а в том, чтобы сделать эти взаимодействия явными.

Это хорошо говорит, но в вашем случае, вы действительно не дали возможность присвоить имя этой переменной, так как plotly обрабатывает все под его крышкой. К счастью, есть способ:

Если модуль должен получить доступ к входу, который не является частью модуля, содержащее приложение должно передать входное значение, завернутое в реактивное выражение (то есть реактивное (...)):

callModule(myModule, "myModule1", reactive(input$checkbox1))

Это, конечно, идет немного вопреки всем модульности ...

Итак, путь это может быть исправлено, чтобы принести событие щелчка вне модуля а затем отправить его как extr вход в функцию callModule. Эта часть кода может выглядеть немного избыточной, но я нашел, что это единственный способ ее работы.

Ну, остальное лучше всего объяснить самим кодом. Изменения были внесены только в функцию server и внутри correlation_matrix_shiny, где определена переменная s.

Надеюсь, это поможет! С наилучшими пожеланиями

---

Код:

library(plotly) 

#### Define Modules #### 
correlation_matrix_shinyUI <- function(id) { 
    ns <- NS(id) 

    mainPanel(
    plotlyOutput(ns("corr_matrix"), height = '650px'), 
    plotlyOutput(ns("scatterplot"), height = '550px') 
) 
} 

correlation_matrix_shiny <- function(input, output, session, plotlyEvent) { 

    data_df <- reactive({ 
    mtcars 
    }) 

    corr_data <- reactive({ 
    if (is.null(data_df())) 
     return() 

    corr_data <- cor(data_df()) 
    diag(corr_data) <- NA 
    corr_data <- round(corr_data, 4) 
    corr_data 
    }) 

    corr_names <- reactive({ 
    if (is.null(data_df())) 
     return() 

    corr_names <- colnames(data_df()) 
    corr_names 
    }) 

    output$corr_matrix <- renderPlotly({ 
    if (is.null(corr_names())) 
     return() 
    if (is.null(corr_data())) 
     return() 


    g <- plot_ly(x = corr_names(), y = corr_names(), z = corr_data(), 
     key = corr_data(), type = "heatmap", source = "CORR_MATRIX", zmax = 1, zmin = -1) 
    g 
    }) 

    output$scatterplot <- renderPlotly({ 
    if (is.null(data_df())) 
     return() 

    data_use <- data_df() 

    s <- plotlyEvent() 

    if (length(s)) { 
     vars <- c(s[["x"]], s[["y"]]) 
     d <- setNames(data_use[vars], c("x", "y")) 
     yhat <- fitted(lm(y ~ x, data = d)) 
     plot_ly(d, x = x, y = y, mode = "markers") %>% 
     plotly::add_trace(x = x, y = yhat, mode = "lines") %>% 
     plotly::layout(xaxis = list(title = s[["x"]]), 
      yaxis = list(title = s[["y"]]), 
      showlegend = FALSE) 
    } else { 
     plot_ly() 
    } 
    }) 

} 
############ End Module Definition ###### 

ui <- shinyUI(fluidPage(
    sidebarLayout(
    sidebarPanel(
    ), 
    correlation_matrix_shinyUI(id = "cor_module") 
) 
)) 

server <- function(input, output, session) { 

    plotlyEvent <- reactive(event_data("plotly_click", source = "CORR_MATRIX")) 

    callModule(correlation_matrix_shiny, id = "cor_module", reactive(plotlyEvent())) 
} 

shinyApp(ui = ui, server = server)