Question

我有一些要使用design.df R应用程序浏览的数据（以下为shiny）

set.seed(1)
library(dplyr)
samples <- paste0("s",1:5)
clusters <- paste0("c",1:10)
groups <- paste0("g",1:20)

design.df <- expand.grid(samples,clusters,groups) %>%
    dplyr::rename(sample=Var1,cluster=Var2,group=Var3) %>%
    dplyr::mutate(value=rnorm(nrow(.)))

我想允许用户能够通过任何列（保留design.df列）来对value进行子集设置。在此示例中，它们将是sample，cluster和group，但实际上，这是一个应用程序，不同的用户将使用不同的列加载data.frame（离开所有人都拥有的value列。

我正在尝试根据自己的情况改编10.3.2 Dynamic filtering示例，但还不够。

这是我的代码：

library(shiny)
library(dplyr)

make_ui <- function(x, var) {
  if (is.numeric(x)) {
    rng <- range(x, na.rm = TRUE)
    sliderInput(var, var, min = rng[1], max = rng[2], value = rng)
  } else if (is.factor(x)) {
    levs <- levels(x)
    selectInput(var, var, choices = levs, selected = levs, multiple = TRUE)
  } else {
    # Not supported
    NULL
  }
}

filter_var <- function(x, val) {
  if (is.numeric(x)) {
    !is.na(x) & x >= val[1] & x <= val[2]
  } else if (is.factor(x)) {
    x %in% val
  } else {
    # No control, so don't filter
    TRUE
  }
}

server <- function(input, output)
{
  data <- reactive({
    get(input$dataset, data.frame(dplyr::select(design.df,-value)))
  })
  
  vars <- reactive(names(data()))
  
  output$filter <- renderUI(
    purrr::map(vars, ~ make_ui(data()[[.x]], .x))
  )
  
  selected <- reactive({
    each_var <- purrr::map(vars, ~ filter_var(data()[[.x]], input[[.x]]))
    purrr::reduce(each_var, `&`)
  })
  
  scatter.plot <- reactive({
    scatter.plot <- NULL
    if(!is.null(data()[selected(),]){
      plot.df <- suppressWarnings(data()[selected(), ])
      scatter.plot <- suppressWarnings(plotly::plot_ly(marker=list(size=3),type='scatter',mode="markers",color=plot.df$sample,x=plot.df$group,y=plot.df$value) %>%
                                         plotly::layout(xaxis=list(title="group",showgrid=F),yaxis=list(title="value",showgrid=F)))
    }
    return(scatter.plot)
  })
    
  output$out.plot <- plotly::renderPlotly({
    scatter.plot()
  })  
}

ui <- fluidPage(
  titlePanel("Data Explorer"),
  sidebarLayout(
    sidebarPanel(
      tags$head(
        tags$style(HTML(".multicol {-webkit-column-count: 3; /* Chrome, Safari, Opera */-moz-column-count: 3; /* Firefox */column-count: 3;}")),
        tags$style(type="text/css", "#loadmessage {position: fixed;top: 0px;left: 0px;width: 100%;padding: 5px 0px 5px 0px;text-align: center;font-weight: bold;font-size: 100%;color: #000000;background-color: #CCFF66;z-index: 105;}"),
        tags$style(type="text/css",".shiny-output-error { visibility: hidden; }",".shiny-output-error:before { visibility: hidden; }")),
      conditionalPanel(condition="$('html').hasClass('shiny-busy')",tags$div("In Progress...",id="loadmessage")),
      selectInput("dataset", label = "Dataset", choices = colnames(dplyr::select(design.df,-value))),
      uiOutput("filter"),
    ),
    mainPanel(
      plotly::plotlyOutput("out.plot")
    )
  )
)

shinyApp(ui = ui, server = server)

哪个提供此界面：

它接近我想要的，但是仍然存在一些问题：

它显示design.df的所有列，而不是对选定的列做出反应。
它未显示散点图，可能是由于我在scatter.plot reactive中设置的情况所致。

有什么想法吗？

这些问题解决之后，我还需要更新scatter.plot reactive中的绘图代码，以便它不会从design.df中显式选择列名，而是从中选择列名，但这不是对于这篇文章至关重要。

Answer 1

这对我来说是一个足够的解决方案。

数据：

set.seed(1)
library(dplyr)
samples <- paste0("s",1:5)
clusters <- paste0("c",1:10)
groups <- paste0("g",1:20)

design.df <- expand.grid(samples,clusters,groups) %>%
    dplyr::rename(sample=Var1,cluster=Var2,group=Var3) %>%
    dplyr::mutate(value=rnorm(nrow(.)))

发光的代码：

library(shiny)
library(dplyr)

make_ui <- function(x, var) {
  if (is.numeric(x)) {
    rng <- range(x, na.rm = TRUE)
    sliderInput(var, var, min = rng[1], max = rng[2], value = rng)
  } else if (is.factor(x)) {
    levs <- levels(x)
    selectInput(var, var, choices = levs, selected = levs, multiple = TRUE)
  } else {
    # Not supported
    NULL
  }
}

filter_var <- function(x, val) {
  if (is.numeric(x)) {
    !is.na(x) & x >= val[1] & x <= val[2]
  } else if (is.factor(x)) {
    x %in% val
  } else {
    # No control, so don't filter
    TRUE
  }
}

server <- function(input, output)
{
  output$filter <- renderUI(
    purrr::map(colnames(data.frame(dplyr::select(design.df,-value))), ~ make_ui(data.frame(dplyr::select(design.df,-value))[[.x]], .x))
  )
  
  selected <- reactive({
    each_var <- purrr::map(colnames(data.frame(dplyr::select(design.df,-value))), ~ filter_var(data.frame(dplyr::select(design.df,-value))[[.x]], input[[.x]]))
    purrr::reduce(each_var, `&`)
  })
  
  scatter.plot <- reactive({
    scatter.plot <- NULL
    if(!is.null(data.frame(dplyr::select(design.df,-value))[selected(),])){
      plot.df <- suppressWarnings(data.frame(dplyr::select(design.df,-value))[selected(), ])
      scatter.plot <- suppressWarnings(plotly::plot_ly(marker=list(size=3),type='scatter',mode="markers",color=plot.df$sample,x=plot.df$group,y=plot.df$value) %>%
                                       plotly::layout(xaxis=list(title="group",showgrid=F),yaxis=list(title="value",showgrid=F)))
    }
    return(scatter.plot)
  })
    
  output$out.plot <- plotly::renderPlotly({
    scatter.plot()
  })  
}

ui <- fluidPage(
  titlePanel("Data Explorer"),
  sidebarLayout(
    sidebarPanel(
      tags$head(
        tags$style(HTML(".multicol {-webkit-column-count: 3; /* Chrome, Safari, Opera */-moz-column-count: 3; /* Firefox */column-count: 3;}")),
        tags$style(type="text/css", "#loadmessage {position: fixed;top: 0px;left: 0px;width: 100%;padding: 5px 0px 5px 0px;text-align: center;font-weight: bold;font-size: 100%;color: #000000;background-color: #CCFF66;z-index: 105;}"),
        tags$style(type="text/css",".shiny-output-error { visibility: hidden; }",".shiny-output-error:before { visibility: hidden; }")),
      conditionalPanel(condition="$('html').hasClass('shiny-busy')",tags$div("In Progress...",id="loadmessage")),
      uiOutput("filter"),
    ),
    mainPanel(
      plotly::plotlyOutput("out.plot")
    )
  )
)

shinyApp(ui = ui, server = server)

哪个给：

从R闪亮的应用程序中美观地显示长数据帧以子集

1 个答案: