结合renderUI、dataTableOutput、renderDataTable和reactive，允许用户从列表或DT中选择。

问题描述 投票：0回答：1

以下 此职位我在这里的目的是为了扩展 shiny app 因此，它提供了选择从一个 DT (通过 DT::renderDataTable, DT::dataTableOutput和 renderUI)或从一个列表中获取（通过 renderUI 和 selectInput)

所以我目前的情况是这样的。

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")
plot.types <- c("list","table")

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

  #select a feature from the list
  output$feature.id <- renderUI({
    if(input$plotType == "list"){
      selectInput("feature.id", "Select Feature", choices = feature.rank.df$feature_id)
    }
  })


  #plot the feature selected from the 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
    }
  })

  #plot the feature selected from the list
  output$outPlot <- plotly::renderPlotly({
    if(!is.null(input$feature.id)){
      feature.id <- input$feature.id
      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
    }
  })
}


ui <- fluidPage(
  titlePanel("Results Explorer"),
  sidebarLayout(
    sidebarPanel(
      selectInput("plotType", "Plot Type", choices = plot.types),
      uiOutput("feature.idx"),
      uiOutput("feature.id")
    ),
    mainPanel(
      plotly::plotlyOutput("outPlot")
    )
  )
)

shinyApp(ui = ui, server = server)

结果是，当选择 table 的侧栏面板确实显示了表格，但在选择行时没有发生任何事情。另一方面，在 list 选项工作正常。

有什么办法可以解决这个问题吗？

r datatable shiny plotly dt
1个回答
0
投票

这似乎是可行的。

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")
plot.types <- c("list","table")

server <- function(input, output)
{

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

  output$feature.id <- renderUI({
    if(input$plotType == "list"){
      selectInput("feature.id", "Select Feature", choices = feature.rank.df$feature_id)
    }
  })


  feature.idx.plot <- reactive({
    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.idx.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"))
    } else{
      feature.idx.plot <- NULL
    }
    return(feature.idx.plot)
  })

  feature.id.plot <- reactive({
    if(!is.null(input$feature.id)){
      feature.id <- input$feature.id
      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.id.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"))
    } else{
      feature.id.plot <- NULL
    }
    return(feature.id.plot)
  })


  output$outPlot <- plotly::renderPlotly({
    if(input$plotType == "table"){
      feature.idx.plot()
    } else if(input$plotType == "list"){
      feature.id.plot()
    }
  })
}


ui <- fluidPage(
  titlePanel("Results Explorer"),
  sidebarLayout(
    sidebarPanel(
      selectInput("plotType", "Plot Type", choices = plot.types),
      uiOutput("feature.idx"),
      uiOutput("feature.id")
    ),
    mainPanel(
      plotly::plotlyOutput("outPlot")
    )
  )
)

shinyApp(ui = ui, server = server)
最新问题
© www.soinside.com 2019 - 2024. All rights reserved.