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

Question

I'm trying to create a shiny app where the user selects a variable from a drop down box, eg dose or supp in the toothgrowth dataset, then a slider from 1 to 100 for each unique element in the variable is available, eg 0.5, 1, 2 if dose is selected. Based on the variable selected and selected values on the slider I want to create another binary variable, eg sufficient_length, that is:

    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
    }

Is there a way of doing this without having to hard code all the possibilities as once I get this working I will apply it to a much larger dataset than toothgroup where there are many variables and more unique elements within those variables?

The full code for the shinny app so far is:

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

Try this trick, which (I think) is robust to the number of levels.

  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)
  })

Walk-through, assuming that dose is selected, and the sliders are set to 30, 20, and 10 for "0.5", "1" and "2", respectively.

1. Equivalent to the verbatim ToothGrowth$dose , this instead grabs the levels from the selected group programmatically.

    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. We want to see if $len is greater than all of the sliders' values , so the outer command gives us a matrix of nrow(ToothGrowth) rows and 3 columns (3 because dat() has three elements, the three levels of $dose ). Column 1 represents the first slider ( "0.5" when dose selected), column 2 represents the second slider ( "1" ), and column 3 represents the third slider ( "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

   The one TRUE there means that the second value of $len (11.5) is greater than the third slider value (which is 10, per my setup).

3. The mapply is a trick to get the values of multiple input$ elements. Normally, if we have a named list , we can use single [ for indexing multiple values, but that doesn't work with the special input$ object. While I'd like to use sapply(dat(), [[ , x = input) , but that doesn't work (not implemented within the shiny stuff, not a surprise as who would want/need to access it like that). So I use mapply to work around that.

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

4. Now that we have a matrix of 60x3 (from bullet 2), we need a similar matrix that indicates whether that row's $dose is equal to the column's levels. In the previous bullet, the TRUE indicates a value of 11.5 (row 2) and a $dose of "2" (column 3, slider 3). So now we do an outer comparison of $dose with the available levels.

    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. From here, we take the two 60x3 matrices and do an element-wise 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

   (Okay, not much interesting there, just thought I'd show both head and tail to demonstrate that some rows have a match.)

6. apply takes a matrix (the element-wise AND of the two matrices, and applies a function ( any ) to each row ( 1 , the margin on which the function is applied).

Verification that the values are the same:

## 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

(BTW: req(ToothGrowth) in this example is completely unnecessary, as ToothGrowth is a static data set. Typically, req is used on reactive values to ensure that it is "truthy" in its current reactive state. This happens frequently-enough, such as on startup when some inputs are not-yet defined completely and therefore might return as NULL . So you should really be using req on input$... or some reactive data in your server component.)