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)
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.
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
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).
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
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
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.)
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.)
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.