Я пытаюсь создать блестящее приложение, в котором пользователь выбирает переменную из выпадающего списка, например, доза или подпитка в наборе данных о зубном росте, затем доступен ползунок от 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)
Всего 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», соответственно.
Эквивалентно дословной 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
Мы хотим увидеть, превышает ли $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).
mapply
- это трюк для получения значений нескольких input$
элементов. Обычно, если у нас есть именованный list
, мы можем использовать single [
для индексации нескольких значений, но это не работает со специальным объектом input$
. Хотя я хотел бы использовать sapply(dat(),
[[ , x = input)
, но это не работает (не реализовано в shiny
материале, не удивительно, если кто захочет / должен получить к нему доступ таким образом) , Поэтому я использую mapply
чтобы обойти это.
mapply(`[[`, list(input), dat())
# [1] 30 20 10
Теперь, когда у нас есть матрица 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
Отсюда мы берем две матрицы 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
(Ладно, там не так много интересного, просто подумал, что я покажу как голову, так и хвост, чтобы продемонстрировать совпадение некоторых рядов.)
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$...
или некоторые реактивные данные в вашем серверном компоненте.)