Объединение renderUI, dataTableOutput, renderDataTable и реактивного

Question

Это что-то вроде расширения этого поста :

Я хотел бы иметь DT::renderDataTable внутри renderUI, а затем иметь output из renderUI используется в reactive.

Вот что я делаю:

suppressPackageStartupMessages(library(dplyr))
suppressPackageStartupMessages(library(plotly))
suppressPackageStartupMessages(library(shiny))


#data.frames to be used in the server
set.seed(1)
coordinate.df <- data.frame(coordinate_id = paste0("c", 1:1000),x = rnorm(1000), y = rnorm(1000), stringsAsFactors = F)
feature.df <- data.frame(coordinate_id = rep(paste0("c", 1:1000), 10), feature_id = rep(paste0("f", 1:10), 1000), value = rnorm(10*1000), stringsAsFactors = F)
feature.rank.df <- feature.df %>% dplyr::select(feature_id) %>% unique() %>% dplyr::mutate(rank=sample(1:10,10,replace = F)) %>% dplyr::arrange(rank)

feature.color.vec <- c("lightgray","darkred")

server <- function(input, output)
{

  output$feature.idx <- renderUI({
    output$feature.table <- DT::renderDataTable(feature.rank.df, server = FALSE, selection = "single")
    DT::dataTableOutput("feature.table")
  })

  feature.plot <- reactive({
    if(!is.null(input$feature.idx)){
      feature.id <- feature.rank.df$feature_id[input$feature.idx]
      plot.title <- feature.id
      plot.df <- suppressWarnings(feature.df %>%
                                    dplyr::filter(feature_id == feature.id) %>%
                                    dplyr::left_join(coordinate.df,by = c("coordinate_id"="coordinate_id")))
      feature.plot <- suppressWarnings(plotly::plot_ly(marker=list(size=3),type='scatter',mode="markers",color=plot.df$value,x=plot.df$x,y=plot.df$y,showlegend=F,colors=colorRamp(feature.color.vec)) %>%
                                        plotly::layout(title=plot.title,xaxis=list(zeroline=F,showticklabels=F,showgrid=F),yaxis=list(zeroline=F,showticklabels=F,showgrid=F)) %>%
                                        plotly::colorbar(limits=c(min(plot.df$value,na.rm=T),max(plot.df$value,na.rm=T)),len=0.4,title="Value"))
    }
    feature.plot
  })

  output$outPlot <- plotly::renderPlotly({
    feature.plot()
  })
}


ui <- fluidPage(
  titlePanel("Results Explorer"),
  sidebarLayout(
    sidebarPanel(
      uiOutput("feature.idx")
    ),

    mainPanel(
      plotly::plotlyOutput("outPlot")
    )
  )
)

shinyApp(ui = ui, server = server)

Он загружает feature.rank.df data.frame, но затем печатает это сообщение об ошибке на главная панель:

Error: no applicable method for 'plotly_build' applied to an object of class "c('reactiveExpr', 'reactive')"

И при выборе строки в таблице на боковой панели ничего не отображается на графике.

Есть идеи, каково решение?

Answer 1

Это можно исправить, заменив серверную функцию приведенным ниже кодом.

• см. Выбранную функцию с помощью input$feature.table_rows_selected
• . Сохраните код реактивной функции. renderPlotly функция

server <- function(input, output)
{
    output$feature.idx <- renderUI({
        output$feature.table <-
            DT::renderDataTable(feature.rank.df,
                                server = FALSE,
                                selection = "single")
        DT::dataTableOutput("feature.table")
    })

    output$outPlot <- plotly::renderPlotly({
        if (!is.null(input$feature.table_rows_selected)) {
            feature.id <-
                feature.rank.df$feature_id[input$feature.table_rows_selected]
            plot.title <- feature.id
            plot.df <- suppressWarnings(
                feature.df %>%
                    dplyr::filter(feature_id == feature.id) %>%
                    dplyr::left_join(
                        coordinate.df,
                        by = c("coordinate_id" = "coordinate_id")
                    )
            )
            feature.plot <-
                suppressWarnings(
                    plotly::plot_ly(
                        marker = list(size = 3),
                        type = 'scatter',
                        mode = "markers",
                        color = plot.df$value,
                        x = plot.df$x,
                        y = plot.df$y,
                        showlegend = F,
                        colors = colorRamp(feature.color.vec)
                    ) %>%
                        plotly::layout(
                            title = plot.title,
                            xaxis = list(
                                zeroline = F,
                                showticklabels = F,
                                showgrid = F
                            ),
                            yaxis = list(
                                zeroline = F,
                                showticklabels = F,
                                showgrid = F
                            )
                        ) %>%
                        plotly::colorbar(
                            limits = c(
                                min(plot.df$value, na.rm = T),
                                max(plot.df$value, na.rm = T)
                            ),
                            len = 0.4,
                            title = "Value"
                        )
                )
            feature.plot
        }

    })
}

Редактировать:

В качестве альтернативы, вы можете сохранить файл feature.plot как реактивный, например:

server <- function(input, output)
{

    output$feature.idx <- renderUI({
        output$feature.table <- DT::renderDataTable(feature.rank.df, server = FALSE, selection = "single")
        DT::dataTableOutput("feature.table")
    })

    feature.plot <- reactive({
        if (!is.null(input$feature.table_rows_selected)) {
            feature.id <-
                feature.rank.df$feature_id[input$feature.table_rows_selected]
            plot.df <- suppressWarnings(
                feature.df %>%
                    dplyr::filter(feature_id == feature.id) %>%
                    dplyr::left_join(coordinate.df, by = c("coordinate_id" =
                                                               "coordinate_id"))
            )
            feature.plot <-
                suppressWarnings(
                    plotly::plot_ly(
                        marker = list(size = 3),
                        type = 'scatter',
                        mode = "markers",
                        color = plot.df$value,
                        x = plot.df$x,
                        y = plot.df$y,
                        showlegend = F,
                        colors = colorRamp(feature.color.vec)
                    ) %>%
                        plotly::layout(
                            title = plot.df$feature_id[1],
                            xaxis = list(
                                zeroline = F,
                                showticklabels = F,
                                showgrid = F
                            ),
                            yaxis = list(
                                zeroline = F,
                                showticklabels = F,
                                showgrid = F
                            )
                        ) %>%
                        plotly::colorbar(
                            limits = c(
                                min(plot.df$value, na.rm = T),
                                max(plot.df$value, na.rm = T)
                            ),
                            len = 0.4,
                            title = "Value"
                        )
                )
        }
        return(feature.plot)
    })

    output$outPlot <- plotly::renderPlotly({
        req(feature.plot(), input$feature.table_rows_selected)
        feature.plot()
    })
}