基于动态变化的阈值条件创建一个新列 Shiny

Question

我正在尝试创建一个闪亮的应用程序，用户从下拉框中选择一个变量，例如牙齿生长数据集中的剂量或补充，然后变量中每个唯一元素的滑块从 1 到 100 可用，例如 0.5， 1, 2 如果选择了剂量。 基于滑块上的变量 selected 和 selected values 我想创建另一个二进制变量，例如足够的长度，即：

    if (input$group == "supp"){
      ToothGrowth$sufficient_length[which(ToothGrowth$supp=="VC" & ToothGrowth$len > input$VC)]<-1
      ToothGrowth$sufficient_length[which(ToothGrowth$supp=="VC" & ToothGrowth$len <= input$VC)]<-0
      ToothGrowth$sufficient_length[which(ToothGrowth$supp=="OJ" & ToothGrowth$len > input$OJ)]<-1
      ToothGrowth$sufficient_length[which(ToothGrowth$supp=="OJ" & ToothGrowth$len <= input$OJ)]<-0
    } else if (input$group == "dose"){
      ToothGrowth$sufficient_length[which(ToothGrowth$dose=="0.5" & ToothGrowth$len > input$"0.5")]<-1
      ToothGrowth$sufficient_length[which(ToothGrowth$dose=="0.5" & ToothGrowth$len <= input$"0.5")]<-0
      ToothGrowth$sufficient_length[which(ToothGrowth$dose=="1" & ToothGrowth$len > input$"1")]<-1
      ToothGrowth$sufficient_length[which(ToothGrowth$dose=="1" & ToothGrowth$len <= input$"1")]<-0
      ToothGrowth$sufficient_length[which(ToothGrowth$dose=="2" & ToothGrowth$len > input$"2")]<-1
      ToothGrowth$sufficient_length[which(ToothGrowth$dose=="2" & ToothGrowth$len <= input$"2")]<-0
    }

有没有办法做到这一点而不必对所有可能性进行硬编码，因为一旦我开始工作，我会将它应用于比toothgroup更大的数据集，其中有许多变量和这些变量中的更多独特元素？

到目前为止，shinny 应用程序的完整代码是：

library(shiny)
library(ggplot2)
data("ToothGrowth")

ui<-shinyUI(
  fluidPage(
    fluidRow(
      column(width = 4, 
             selectInput("group", "Group:", 
                         c("Supp" = "supp",
                           "Dose" = "dose")),
             uiOutput("sliders"),
             tableOutput("summary")
      ),
      mainPanel(

        # Output: Histogram ----
        plotOutput(outputId = "distPlot")

      )
    )
  )
)

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

  dat<-reactive({
    as.character(unique(ToothGrowth[,input$group]))
  })

  #reactive code for referrals based on the slider for threshold----
  dat2 <- reactive({
    req(ToothGrowth)
    ToothGrowth$sufficient_length<-rep(0,nrow(ToothGrowth))
    if (input$group == "supp"){
      ToothGrowth$sufficient_length[which(ToothGrowth$supp=="VC" & ToothGrowth$len > input$VC)]<-1
      ToothGrowth$sufficient_length[which(ToothGrowth$supp=="VC" & ToothGrowth$len <= input$VC)]<-0
      ToothGrowth$sufficient_length[which(ToothGrowth$supp=="OJ" & ToothGrowth$len > input$OJ)]<-1
      ToothGrowth$sufficient_length[which(ToothGrowth$supp=="OJ" & ToothGrowth$len <= input$OJ)]<-0
    } else if (input$group == "dose"){
      ToothGrowth$sufficient_length[which(ToothGrowth$dose=="0.5" & ToothGrowth$len > input$"0.5")]<-1
      ToothGrowth$sufficient_length[which(ToothGrowth$dose=="0.5" & ToothGrowth$len <= input$"0.5")]<-0
      ToothGrowth$sufficient_length[which(ToothGrowth$dose=="1" & ToothGrowth$len > input$"1")]<-1
      ToothGrowth$sufficient_length[which(ToothGrowth$dose=="1" & ToothGrowth$len <= input$"1")]<-0
      ToothGrowth$sufficient_length[which(ToothGrowth$dose=="2" & ToothGrowth$len > input$"2")]<-1
      ToothGrowth$sufficient_length[which(ToothGrowth$dose=="2" & ToothGrowth$len <= input$"2")]<-0
    }
    return(ToothGrowth)
  })


  #Render the sliders
  output$sliders <- renderUI({
    # First, create a list of sliders each with a different name
    sliders <- lapply(1:length(dat()), function(i) {
      inputName <- dat()[i]
      sliderInput(inputName, inputName, min=0, max=100, value=10)
    })
    # Create a tagList of sliders (this is important)
    do.call(tagList, sliders)
  })

  output$distPlot <- renderPlot({
    ggplot(dat2(),aes(len,fill = as.factor(sufficient_length)))+
      geom_histogram(bins=20)

  })
})

shinyApp(ui, server) 

Answer 1

试试这个技巧，它（我认为）对级别的数量很健壮。

  dat2 <- reactive({
    req(input$group)

    ToothGrowth$sufficient_length <- 
      +apply(
        outer(ToothGrowth$len, mapply(`[[`, list(input), dat()), FUN=`>`) &
          outer(ToothGrowth[[input$group]], dat(), `==`),
        1, any)

    return(ToothGrowth)
  })

走查，假设选择了dose ，并且滑块分别设置为 30、20 和 10，分别表示“0.5”、“1”和“2”。

1. 相当于逐字的ToothGrowth$dose ，而是以编程方式从所选group获取级别。

    ToothGrowth[[input$group]] # [1] 0.5 0.5 0.5 0.5 0.5 0.5 0.5 0.5 0.5 0.5 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 # [20] 1.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 0.5 0.5 0.5 0.5 0.5 0.5 0.5 0.5 # [39] 0.5 0.5 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 # [58] 2.0 2.0 2.0

2. 我们想看看$len是否大于所有滑块的值，所以outer命令给了我们一个nrow(ToothGrowth)行和 3 列的矩阵（3 因为dat()有三个元素， $dose的三个级别）。 第 1 列表示第一个滑块（选择dose时为"0.5" ），第 2 列表示第二个滑块（ "1" ），第 3 列表示第三个滑块（ "2" ）。

    ToothGrowth$len # [1] 4.2 11.5 7.3 5.8 6.4 10.0 11.2 11.2 5.2 7.0 16.5 16.5 15.2 17.3 22.5 # [16] 17.3 13.6 14.5 18.8 15.5 23.6 18.5 33.9 25.5 26.4 32.5 26.7 21.5 23.3 29.5 # [31] 15.2 21.5 17.6 9.7 14.5 10.0 8.2 9.4 16.5 9.7 19.7 23.3 23.6 26.4 20.0 # [46] 25.2 25.8 21.2 14.5 27.3 25.5 26.4 22.4 24.5 24.8 30.9 26.4 27.3 29.4 23.0 mapply(`[[`, list(input), dat()) # [1] 30 18 10 head(outer(ToothGrowth$len, mapply(`[[`, list(input), dat()), FUN=`>`)) # [,1] [,2] [,3] # [1,] FALSE FALSE FALSE # [2,] FALSE FALSE TRUE # [3,] FALSE FALSE FALSE # [4,] FALSE FALSE FALSE # [5,] FALSE FALSE FALSE # [6,] FALSE FALSE FALSE

   那里的一个TRUE意味着$len (11.5) 的第二个值大于第三个滑块值（根据我的设置为 10）。

3. mapply是一种获取多个input$元素值的技巧。 通常，如果我们有一个命名list ，我们可以使用单个[来索引多个值，但这不适用于特殊的input$对象。 虽然我想使用sapply(dat(), [[ , x = input) ，但这不起作用（没有在shiny东西中实现，这并不奇怪谁想要/需要像那样访问它） . 所以我使用mapply来解决这个问题。

    mapply(`[[`, list(input), dat()) # [1] 30 20 10

4. 现在我们有一个 60x3 的矩阵（来自第 2 项），我们需要一个类似的矩阵来指示该行的$dose是否等于列的级别。 在上一个项目符号中， TRUE表示值 11.5（第 2 行）和$dose为"2" （第 3 列，滑块 3）。 所以现在我们对$dose与可用水平进行outer比较。

    dat() # [1] "0.5" "1" "2" head(outer(ToothGrowth[[input$group]], dat(), `==`)) # [,1] [,2] [,3] # [1,] TRUE FALSE FALSE # [2,] TRUE FALSE FALSE # [3,] TRUE FALSE FALSE # [4,] TRUE FALSE FALSE # [5,] TRUE FALSE FALSE # [6,] TRUE FALSE FALSE

5. 从这里开始，我们取两个 60x3 矩阵并进行元素级 AND 运算：

    head(outer(ToothGrowth[[input$group]], dat(), `==`) & outer(ToothGrowth$len, mapply(`[[`, list(input), dat()), FUN=`>`)) # [,1] [,2] [,3] # [1,] FALSE FALSE FALSE # [2,] FALSE FALSE FALSE # [3,] FALSE FALSE FALSE # [4,] FALSE FALSE FALSE # [5,] FALSE FALSE FALSE # [6,] FALSE FALSE FALSE tail(outer(ToothGrowth[[input$group]], dat(), `==`) & outer(ToothGrowth$len, mapply(`[[`, list(input), dat()), FUN=`>`)) # [,1] [,2] [,3] # [55,] FALSE FALSE TRUE # [56,] FALSE FALSE TRUE # [57,] FALSE FALSE TRUE # [58,] FALSE FALSE TRUE # [59,] FALSE FALSE TRUE # [60,] FALSE FALSE TRUE

   （好吧，那里没什么有趣的，只是想我会同时显示头部和尾部以证明某些行匹配。）

6. apply采用一个矩阵（两个矩阵的元素 AND ，并将函数（ any ）应用于每一行（ 1 ，应用该函数的边距）。

验证值是否相同：

## my code, assigned elsewhere for now
ind <- +apply(
  outer(ToothGrowth$len, mapply(`[[`, list(input), dat()), FUN=`>`) &
    outer(ToothGrowth[[input$group]], dat(), `==`),
  1, any)
## your code
ToothGrowth$sufficient_length[which(ToothGrowth$dose=="0.5" & ToothGrowth$len > input$"0.5")]<-1
ToothGrowth$sufficient_length[which(ToothGrowth$dose=="0.5" & ToothGrowth$len <= input$"0.5")]<-0
ToothGrowth$sufficient_length[which(ToothGrowth$dose=="1" & ToothGrowth$len > input$"1")]<-1
ToothGrowth$sufficient_length[which(ToothGrowth$dose=="1" & ToothGrowth$len <= input$"1")]<-0
ToothGrowth$sufficient_length[which(ToothGrowth$dose=="2" & ToothGrowth$len > input$"2")]<-1
ToothGrowth$sufficient_length[which(ToothGrowth$dose=="2" & ToothGrowth$len <= input$"2")]<-0

all(ind == ToothGrowth$sufficient_length)
# [1] TRUE

（顺便说一句：在这个例子中req(ToothGrowth)是完全没有必要的，因为ToothGrowth是一个静态数据集。通常， req用于反应值以确保它在当前反应状态下是“真实的”。这种情况经常发生，例如在启动时，某些输入尚未完全定义，因此可能返回为NULL 。所以你真的应该在input$...上使用req input$...或你的服务器组件中的一些反应数据。）