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

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

0 голосов
/ 15 января 2020

Я пытаюсь создать блестящее приложение, в котором пользователь выбирает переменную из выпадающего списка, например, доза или глоток в наборе данных о зубном росте, затем доступен ползунок от 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, где есть много переменных и больше уникальных элементов в этих переменных?

Полный код для пока еще не сложного приложения: 

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)

1 Ответ

1 голос
/ 16 января 2020

Попробуйте этот трюк, который (я думаю) является устойчивым к количеству уровней. 

  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, мы можем использовать один [ для индексации нескольких значений, но это не работает со специальным объектом 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 берет матрицу (поэлементное И двух матриц и применяет функцию (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 - это набор данных c stati. Как правило, req используется для реактивных значений, чтобы гарантировать, что оно является "правдивым" в своем текущем реактивном состоянии. Это происходит достаточно часто, например, при запуске, когда некоторые входные данные еще не определены полностью и, следовательно, могут возвращаться как NULL. Таким образом, вы действительно должны использовать req на input$... или некоторые реактивные данные в вашем ошибочный компонент.)

Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.

Нет похожих вопросов

...