R中闪亮的反应选择输入

Posted

技术标签:

【中文标题】R中闪亮的反应选择输入【英文标题】:Shiny reactive selectInput in R 【发布时间】:2020-07-04 22:44:21 【问题描述】:

我有一个包含反应数据的闪亮应用程序。我希望应用程序只为 X 和 Y 轴选择非空列。目前我在colnames(TD[,3:7]) 之间进行选择,但列也有空值,所以我不希望这些列显示为变量选择。下面是一个例子和我的代码:

type <- as.character(c('summer','summer','summer','summer','winter','winter','winter','winter'))
country <- as.character(c('A','A','B','B','A','A','B','B'))
year <- c(2011,2012,2013,2014,2011,2012,2013,2014)
col1 <- c(33,7,NA,NA,5,11,NA,NA)
col2 <- c(10,3,NA,NA,8,15,NA,NA)
col3 <- c(NA,NA,10,15,NA,NA,20,25)
col4 <- c(NA,NA,8,5,NA,NA,22,16)

TD <- data.frame(type,country,year,col1,col2,col3,col4,stringsAsFactors=FALSE)

library(readxl)
library(shiny)
library(ggplot2)
library(shinythemes)
library(DT)

ui <-shinyUI(fluidPage(pageWithSidebar(
  headerPanel("Test App"),
  sidebarPanel(
    selectInput("type","Choose a type", choices = c("All",unique(TD$type))),
    selectInput("country","Choose an country", choices = c("All",unique(TD$country))),
    selectInput("yaxis", "Choose a y variable", choices = colnames(TD[,3:7])),
    selectInput("xaxis", "Choose a x variable", choices = colnames(TD[,3:7])),
    actionButton("goButton", "Update")
  ),
  mainPanel(
    tabsetPanel(
      tabPanel('Plot', plotOutput("plot1"))
    ))
)
))

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

  data1 <- reactive(
    if(input$type == "All")
      TD
    
    else
      TD[which(TD$type == input$type),]
    
  )
  data2 <- eventReactive(input$goButton,
    if (input$country == "All")
      TD
    else

      TD[which(TD$country == input$country),]
    
  )

  observe(
    if(input$type != "All")
      updateSelectInput(session,"country","Choose a country", choices = c("All",unique(data1()$country)))
    
    else if(input$country != 'All')
      updateSelectInput(session,"type","Choose a type", choices = c('All',unique(data2()$type)))
    
    else if (input$type == "All" & input$country == "All")
      updateSelectInput(session,"country","Choose a country", choices = c('All',unique(TD$country)))
      updateSelectInput(session,"type","Choose a type", choices = c('All',unique(TD$type)))
    
  )

  data3 <- eventReactive( input$goButton,
    req(input$goButton)
    req(input$goButton)
    if(input$country == "All")
      data1()
    
    else if (input$type == "All")
      data2()
    
    else if (input$country == "All" & input$type == "All")
      TD
    
    else
    
      TD[which(TD$country== input$country & TD$type == input$type),]
    
  )

  x_var<- eventReactive(input$goButton, 
    input$xaxis
  )
  y_var <- eventReactive(input$goButton,
    input$yaxis
  )

  output$plot1 <- renderPlot(
    x <- x_var()
    y <- y_var()
    p <- ggplot(data3(),aes(x=data3()[,x], y=data3()[,y])) + geom_line() + geom_point()
    p + labs(x = x_var(), y = y_var()) + theme(plot.title = element_text(hjust = 0.5, size=20))
  )
)

shinyApp(ui,server)

【问题讨论】:

col3col4 在你的例子中不是空的,所以我不明白你的意思。 “空”是什么意思? 啊,我想我现在明白了。 col3 仅缺少 Country A 的值。 【参考方案1】:

这是一种方法。它使用 selectize 插件 disable_options

下载插件here。将其保存在应用文件夹的 www 子文件夹中的名称 selectize-disable-options.js 下。

然后这里是应用程序:

library(shiny)
library(ggplot2)

CSS <- "
.selectize-dropdown [data-selectable].option-disabled 
  color: #aaa;
  cursor: default;
"

type <- as.character(c('summer','summer','summer','summer','winter','winter','winter','winter'))
country <- as.character(c('A','A','B','B','A','A','B','B'))
year <- c(2011,2012,2013,2014,2011,2012,2013,2014)
col1 <- c(33,7,NA,NA,5,11,NA,NA)
col2 <- c(10,3,NA,NA,8,15,NA,NA)
col3 <- c(NA,NA,10,15,NA,NA,20,25)
col4 <- c(NA,NA,8,5,NA,NA,22,16)

TD <- data.frame(type,country,year,col1,col2,col3,col4,stringsAsFactors=FALSE)


ui <- fluidPage(
  tags$head(
    tags$script(src = "selectize-disable-options.js"),
    tags$style(html(CSS))
  ),
  titlePanel("Test App"),
  sidebarLayout(
    sidebarPanel(
      selectInput("type","Choose a type", choices = c("All",unique(TD$type))),
      selectInput("country","Choose an country", choices = c("All",unique(TD$country))),
      selectizeInput("yaxis", "Choose a y variable", choices = colnames(TD[,3:7])),
      selectInput("xaxis", "Choose a x variable", choices = colnames(TD[,3:7])),
      actionButton("goButton", "Update")
    ),
    mainPanel(
      tabsetPanel(
        tabPanel('Plot', plotOutput("plot1"))
      )
    )
  )
)


server <- function(input, output, session)
  
  data1 <- reactive(
    if(input$type == "All")
      TD
    else
      TD[TD$type == input$type,]
    
  )
  
  data2 <- reactive(
    if(input$country == "All")
      TD
    else
      TD[TD$country == input$country,]
    
  )
  
  observe(
    if(input$type != "All")
      selected_country <- isolate(input$country)
      countries <- unique(data1()$country)
      updateSelectInput(
        session, "country", 
        choices = c("All", countries),
        selected = ifelse(selected_country %in% countries, selected_country, "All")
      )
    else if(input$country != 'All')
      selected_type <- isolate(input$type)
      types <- unique(data2()$type)
      updateSelectInput(
        session, "type", 
        choices = c('All', types),
        selected = ifelse(selected_type %in% types, selected_type, "All")
      )
    else if(input$type == "All" && input$country == "All")
      updateSelectInput(
        session, "country", 
        choices = c('All', unique(TD$country))
      )
      updateSelectInput(
        session, "type", 
        choices = c('All', unique(TD$type))
      )
    
  )
  
  data3 <- reactive(
    if(input$country == "All")
      data1()
    else if(input$type == "All")
      data2()
    else if(input$country == "All" && input$type == "All")
      TD
    else
      TD[which(TD$country== input$country & TD$type == input$type),]
    
  )
  
  observeEvent(data3(), 
    emptyColumns <- sapply(data3()[,3:7], function(x)
      all(is.na(x))
    )
    choices <- colnames(TD[,3:7])
    choices[emptyColumns] <- paste(choices[emptyColumns], "(no data)")
    updateSelectizeInput(
      session, "yaxis", choices = choices,
      options = list(
        plugins = list(
          disable_options = list(
            disableOptions = as.list(choices[emptyColumns])
          )
        )
      )
    )
  )
  
  data4 <- eventReactive(input$goButton, 
    data3()
  )
  
  x_var<- eventReactive(input$goButton, 
    input$xaxis
  )
  y_var <- eventReactive(input$goButton,
    input$yaxis
  )
  
  output$plot1 <- renderPlot(
    x <- x_var()
    y <- y_var()
    p <- ggplot(data4(), aes_string(x=x, y=y)) + geom_line() + geom_point()
    p + labs(x = x, y = y) + theme(plot.title = element_text(hjust = 0.5, size=20))
  )
  


shinyApp(ui,server)

选择输入中的空列被禁用:

【讨论】:

以上是关于R中闪亮的反应选择输入的主要内容,如果未能解决你的问题,请参考以下文章

R闪亮的选择输入反应性

删除后如何将旧的反应输入存储在R闪亮中

R 用 updateSelectInput 反应闪亮

如何在ui中使用使用反应函数作为输入的结果? -r 闪亮

R 闪亮的反应单选按钮

将反应输入传递到 R Shiny 中的绘图轴