создание нового столбца на основе динамически изменяющихся пороговых условий Shiny


Я пытаюсь создать блестящее приложение, в котором пользователь выбирает переменную из выпадающего списка, например, доза или подпитка в наборе данных о зубном росте, затем доступен ползунок от 1 до 100 для каждого уникального элемента в переменной, например, 0,5, 1, 2, если доза выбрана. Основываясь на выбранной переменной и выбранных значениях на ползунке, я хочу создать другую двоичную переменную, например достаточную длину, то есть: 

    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 ее к гораздо большему набору данных, чем к 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)
rshiny

Всего 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 представляет первый ползунок ( "0.5" когда выбрана dose ), столбец 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 , мы можем использовать single [ для индексации нескольких значений, но это не работает со специальным объектом 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). Итак, теперь мы делаем outer сравнение $dose с доступными уровнями. 

    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 . Поэтому вы действительно должны использовать req для input$... или некоторые реактивные данные в вашем серверном компоненте.)