library(shiny)
library(shinydashboard)
library(MASS)
ui <- dashboardPage(
### --------------------------------------------------------------------
### Layout and CSS
### --------------------------------------------------------------------
dashboardHeader(title = "Selection Decisions", titleWidth = 240),
dashboardSidebar(
width = 240,
sidebarMenu(
menuItem("Introduction", tabName = "intro", icon = icon("align-left")),
menuItem("Try it!", tabName = "try", icon = icon("location-arrow")),
menuItem("Test yourself!", tabName = "test", icon = icon("thumbs-up"))
)
),
dashboardBody(
tags$head(tags$style(HTML("
.main-header .logo {
font-weight: bold;
font-size: 22px;
}
"))),
tabItems(
### --------------------------------------------------------------------
### Introduction - Tab
### --------------------------------------------------------------------
tabItem(tabName = "intro",
HTML('
<b> <font size="5">Tests and Selection Decisions</font></b><br><br>
<p> Taking tests is often connected to some kind of
(dichotomous) decision.<br>
<i>Do I pass or fail the statistics exam?
Am I pregnant or not?
Am I qualified or unqualified for the position I\'m applying to?
Do I or don\'t I suffer from a certain illness?</i><br>
The real life criterion which is reflected through the test result
can also often be dichotomised (qualified versus unqualified,
pregnant versus not pregnant ...).<br><br>
Criterion and test result can be unanimous - Sarah passes the
statistics exam and is actually a good student in statistics,
or divergent - Jon passes the exam but only through
sheer luck, since he knows nothing about statistics.
The first
example is called a <b>hit</b> (being selected by the test and
fulfilling the criterion), the second a <b>false alarm</b>
(being selected but not fulfilling the criterion).
There are two more possible outcomes: <b>correct rejection</b>
(being rejected by test and not meeting the criterion) and a
<b>miss</b> (being rejected but in fact meeting the
criterion).<br><br>
The four different possibilities are visualised in the following
table:</p>
<center>
<table width="400" height="150">
<tr><td colspan="4"><center>     
  <b>Test result</b></center></td></tr>
<tr>
<td rowspan="3"><center><br><b>Criterion</b></center></td>
<td></td>
<td><center>selected</center></td>
<td><center>not selected </center></td>
</tr>
<tr>
<td><center>met</center></td>
<td bgcolor="white"><center><font color="green">hit</font></center></td>
<td bgcolor="white"><center><font color="red">miss</font></center></td>
</tr>
<tr>
<td><center>not met </center></td>
<td bgcolor="white"><center><font color="blue">false alarm
</font></center></td>
<td bgcolor="white"><center><font color="black">correct rejection
</font></center></td>
</tr>
</table>
</center>
<br>
<p> While talking about "getting selected" makes sense in a school or
job context, it\'s inappropriate in a medical context, for example
testing for HIV. In a medical context, we therefore talk
about a test being positive or negative and about being ill
or not being ill. This results in the following table:</p>
<center>
<table width="400" height="150">
<tr><td colspan="4"><center>     
  <b>Test result</b></center></td></tr>
<tr>
<td rowspan="3"><center><br><b>Illness</b></center></td>
<td></td>
<td><center>positive</center></td>
<td><center>negative </center></td>
</tr>
<tr>
<td><center>yes</center></td>
<td bgcolor="white"><center><font color="green">true positive</font></center></td>
<td bgcolor="white"><center><font color="red">false negative</font></center></td>
</tr>
<tr>
<td><center>no </center></td>
<td bgcolor="white"><center><font color="blue">false positive
</font></center></td>
<td bgcolor="white"><center><font color="black">true negative
</font></center></td>
</tr>
</table>
</center>
<br><br>
<b><font size="5">Validity of Selection Decisions</font></b><br><br>
<p> The validity of the selection decision is determined by several
factors which can also influence each other:
<ul>
<li><b>Validity of the test</b><br>
What proportion of the variance in the criterion is explained through the test result?
</li>
<li><b>Natural success rate (prevalence)</b><br>
What proportion of all participants would meet the criterion?</li>
<li><b>Selection quota</b><br>
What proportion of participants is selected?</li>
<li><b>Success rate (positive predictive value)</b><bR>
What proportion of selected participants is successfull/ does fulfill the criterion?</li>
<li><b>Sensitivity</b><br>
What is the probability of selection when one would meet the criterion?</li>
</li>
<li><b>Specifity</b><br>
What is the probability of rejection when one would not meet the criterion?</li></li>
</ul>
<bR>
Which measures should be taken into consideration to assess the
validity of a decision depends on the kind of test and the
criterion the test refers to. In a medical context, sensitivity is
important, as it can be essential for patient survival to detect
an illness. In a job screening, specifity should be given a
greater weight, since here the goal is to reject all inadequate
applicants.<br><br>
<b><font size="3">
To put these concepts into practice
use the <i>Try it!</i> tab and then <i>Test yourself!</i> :)
</font></b><br><br>
')
),
### --------------------------------------------------------------------
### Try It - Tab
### --------------------------------------------------------------------
tabItem(tabName = "try",
HTML('<b><font size="3">Use the sliders to change the value at which a
person passes the
test and meets the criterion. You can also change the validity of the
test.</font></b> <br>Notice how those changes affect the outcome of the
test decision
(visualized in the scatterplot) and the different measures which assess
the validity of the decision!
You can change the critical criterion and test value without changing
the data. However when you change the validity of a test the participants
have to retake it which leads to slightly different values.<br><br>'),
fluidRow(
### ------------- 1. Columnn to change selection quota
column(4,
HTML('At what value does a person pass the test?<br><br>'),
sliderInput("s", "Test",
50, 150, 100, step = .5),
checkboxInput("sColor", "Highlight selection quota in grey", FALSE),
HTML("<b>Selection Quota:</b>"),
htmlOutput("selectionQ"),
HTML("Proportion of selegates on the basis of their test result"),
br(),
br(),br(),br(),
HTML("<b>Sensitivity:</b>"),
htmlOutput("sens"),
HTML("Probability of selection when meeting the criterion?")
),
### ------------- 2. Columnn to change natural success rate
column(4,
HTML('At what value does a person meet the criterion?<br><br>'),
sliderInput("nb", "Criterion",
50, 150, 100, step = .5),
checkboxInput("nbColor", "Highlight natural success rate in grey", FALSE),
HTML("<b>Natural Success Rate:</b>"),
htmlOutput("natSucsRate"),
HTML(" Proportion of suitable candidates in the unselected sample
<bR>(in a medical context: prevalence)"),
br(),br(),br(),
HTML("<b>Specifity:</b>"),
htmlOutput("spec"),
HTML("Probability of rejection when not meeting the criterion?")
),
### ------------- 3. Columnn to change validity
column(4,
HTML('What is the validity of the test?<br><br>'),
sliderInput("v", "Validity", 0, 1, .5, step = .01),
br(),
br(),
HTML("<b>Success Rate:</b>"),
htmlOutput("SuccRate"),
HTML("Conditional probability of suitable candidates<br>
in selected sample")
)
),
br(),
fluidRow(
box(status = "primary",
title = "Scatterplot of Participants\' Test and Criterion Values",
solidHeader = TRUE,
plotOutput(outputId = "graph", width = "100%"), width = 12)
)
),
### --------------------------------------------------------------------
### Test Yourself - Tab
### --------------------------------------------------------------------
tabItem(tabName = "test",
### ------------- Questions regarding the defenitions of quotas
box(status = "primary",
title = "What are the defenitions of the following quotas?",
solidHeader = TRUE,
### 1. Question
radioButtons("a", "Success rate",
c("(P(False Alarm) + P(Hit)) / P(False Alarm)" = 'r',
"P(Hit) / (P(Hit) + P(False Alarm))" = 'LF',
"P(Hit) + P(False Alarm)" = 'RW',
"P(Hit) / P(False Alarm)" = 'f')
),
actionButton("aa", "Submit"), br(),
uiOutput("Formel1"),
br(),
### 2. Question
radioButtons("c", "Success rate in words",
c("Conditional probability of suitable candidates in selected sample" = 'LF',
"Probability of suitable candidates" = 'r',
"Conditional probability of suitable candidates in unselected sample" = 'RW',
"Probability of being selected" = 'f')
),
actionButton("cc", "Submit"),
br(),
uiOutput("Formel3"),
br(),
### 3. Question
radioButtons("b", "Natural success rate",
c("P(Hit) / (P(Hit) + P(Miss))" = 'r',
"P(Hit) + P(Miss)" = 'LF',
"P(Hit)" = 'RW',
"(P(Hit) + P(Miss)) / (P(Hit) + P(Miss) + P(False Alarm))" =
'f')
),
actionButton("bb", "Submit"), br(),
uiOutput("Formel2")
), ### box end
### ------------- Questions regarding the effects of variables
box(status = "primary",
title = "Effects of different variables",
solidHeader = TRUE,
### 1. Question
strong("The higher the validity, the higher the ..."), br(),
HTML("<select id='RW'>Lucky guess</option>
<option value='so'> </option>
<option value='beta'>selection quota</option>
<option value='Neta'>selection quota and success rate</option>
<option value='Nbeta'>natural success rate</option>
<option value='eta'>sucess rate</option>
</select>"
),
uiOutput("RW"), br(),
### 2. Question
strong("The smaller the selection quota, the ..."), br(),
HTML("<select id='AB'>Lucky guess</option>
<option value='so'> </option>
<option value='eta'>higher the success rate</option>
<option value='Neta'>smaller the success rate</option>
<option value='Nbeta'>higher the natural success rate</option>
<option value='beta'>smaller the natural success rate</option>
</select>"
),
uiOutput("AB"), br(),
### 3. Question
strong("The higher the natural success rate, the ..."), br(),
HTML("<select id='CD'>Lucky guess</option>
<option value='so'> </option>
<option value='beta'>higher the selection quota</option>
<option value='Neta'>smaller the selection quota</option>
<option value='eta'>more unnecessary the testing</option>
<option value='Nbeta'>more important the testing</option>
</select>"
),
uiOutput("CD")
) ## box end
)
)
)
)
server <- function(input, output){
### --------------------------------------------------------------------
### Selection Decision Plot
### --------------------------------------------------------------------
validity <- reactive(input$v)
## joint distribution of observed values
n <- 1000
mu.x <- 100
mu.y <- 100
var.x <- 15^2
var.y <- 10^2
covar <- reactive(validity() * sqrt(var.x * var.y))
Sigma <- reactive(matrix(c(var.x, covar(), covar(), var.y), 2, 2))
## simulation
dat <- reactive(as.data.frame(mvrnorm(n, c(100,100), Sigma())))
#colnames(dat) <- c("x", "y")
#xlim <- extendrange(dat$x, f = 0.05)
#ylim <- extendrange(dat$y, f = 0.05)
xlim <- c(40, 160)
ylim <- c(50, 150)
output$graph <- renderPlot({
plot(dat()$V1, dat()$V2, pch = 16, cex = 1,
xlim = xlim, ylim = ylim, type = "n",
xlab = "Test", ylab = "Criterion"
)
## highlight background grey
if(input$sColor == TRUE){
rect(input$s, 0, 200, 200, border = rgb(0, 0, 0, alpha = 0.1),
col = rgb(0, 0, 0, alpha = 0.1))
text(input$s + 6, 55, "Selection Quota", col = "grey35")
}
if(input$nbColor == TRUE){
rect(0, input$nb, 200, 200, border = rgb(0, 0, 0, alpha = 0.1),
col = rgb(0, 0, 0, alpha = 0.1))
text(50, input$nb + 5, "Natural Success Rate", col = "grey35")
}
## draw data points, colored according to where selection quota and natural
## success rate
points(dat()$V1, dat()$V2, pch = 16,
col = ifelse(dat()[,2] >= input$nb & dat()[,1] <= input$s, "red",
ifelse(dat()[,2] >= input$nb & dat()[,1] >= input$s, "darkgreen",
ifelse(dat()[,2] <= input$nb & dat()[,1] >= input$s, "blue",
"black"))))
abline(v = input$s) # show Selection Quota
abline(h = input$nb) # show Natural Success Rate
## mark plot quarters
legend("topleft", paste0("Miss = ", mean(dat()[,2] >= input$nb & dat()[,1] <= input$s)),
text.col = "red", cex = 0.8, bty="n")
legend("topright", paste0("Hit = ", mean(dat()[,2] >= input$nb & dat()[,1] >= input$s)),
text.col = "darkgreen", cex = 0.8, bty="n")
legend("bottomright", paste0("False Alarm = ", mean(dat()[,2] <= input$nb &
dat()[,1] >= input$s)),
text.col = "blue", cex = 0.8, bty="n")
legend("bottomleft", paste0("Correct Rejection = ", mean(dat()[,2] <= input$nb &
dat()[,1] <= input$s)),
text.col = "black", cex = 0.8, bty="n")
})
## shows P(hit) + P(False Alarm) = selection quota (in colors)
output$selectionQ <- renderText({paste(
'<span style=\"color:green\">',
mean(dat()[,2] >= input$nb & dat()[,1] >= input$s), # P(hit)
'<span style=\"color:black\"> + ',
'<span style=\"color:blue\">',
mean(dat()[,2] <= input$nb & dat()[,1] >= input$s), # P(False Alarm)
'<span style=\"color:black\"> = ',
'<span style=\"color:black\"><b>',
mean(dat()[, 1] >= input$s), # Selektionsquote
'</b></p></p></p></p></p>'
)})
## shows P(Miss) + P(Hit) = natural success rate
output$natSucsRate <- renderText({paste(
'<span style=\"color:red\">',
mean(dat()[,2] >= input$nb & dat()[,1] <= input$s), # P(Miss)
'<span style=\"color:black\"> + ',
'<span style=\"color:green\">',
mean(dat()[,2] >= input$nb & dat()[,1] >= input$s), # P(Hit)
'<span style=\"color:black\"> = ',
'<span style=\"color:black\"><b>',
mean(dat()[, 2] >= input$nb), # Nat. Bewaehrungsquote
'</b></p></p></p></p></p>'
)})
## shows P(Hit) / (P(Hit) + P(False Alarm))
## = success rate
output$SuccRate <- renderText({paste(
'<span style=\"color:green\">',
mean(dat()[,2] >= input$nb & dat()[,1] >= input$s),
'<span style=\"color:black\"> / (',
'<span style=\"color:green\">',
mean(dat()[,2] >= input$nb & dat()[,1] >= input$s),
'<span style=\"color:black\"> + ',
'<span style=\"color:blue\">',
mean(dat()[,2] <= input$nb & dat()[,1] >= input$s),
'<span style=\"color:black\">) = ',
'<span style=\"color:black\"><b>',
round(mean(dat()[,2] >= input$nb & dat()[,1] >= input$s)/
mean(dat()[, 1] >= input$s),3),
'</b></p></p></p></p></p>'
)})
output$sens <- renderText({paste(
'<span style=\"color:green\">',
mean(dat()[,2] >= input$nb & dat()[,1] >= input$s),
'<span style=\"color:black\"> / (',
'<span style=\"color:green\">',
mean(dat()[,2] >= input$nb & dat()[,1] >= input$s),
'<span style=\"color:black\"> + ',
'<span style=\"color:red\">',
mean(dat()[,2] >= input$nb & dat()[,1] <= input$s),
'<span style=\"color:black\">) = ',
'<span style=\"color:black\"><b>',
round(mean(dat()[,2] >= input$nb & dat()[,1] >= input$s)/
(mean(dat()[,2] >= input$nb & dat()[,1] >= input$s) +
mean(dat()[,2] >= input$nb & dat()[,1] <= input$s)), 3),
'</b></p></p></p></p></p>'
)})
output$spec <- renderText({paste(
'<span style=\"color:black\">',
mean(dat()[,2] <= input$nb &
dat()[,1] <= input$s),
'<span style=\"color:black\"> / (',
'<span style=\"color:black\">',
mean(dat()[,2] <= input$nb &
dat()[,1] <= input$s),
'<span style=\"color:black\"> + ',
'<span style=\"color:blue\">',
mean(dat()[,2] <= input$nb & dat()[,1] >= input$s),
'<span style=\"color:black\">) = ',
'<span style=\"color:black\"><b>',
round(mean(dat()[,2] <= input$nb &
dat()[,1] <= input$s)/
(mean(dat()[,2] <= input$nb & dat()[,1] <= input$s)+
mean(dat()[,2] <= input$nb & dat()[,1] >= input$s))
,3),
'</b></p></p></p></p></p>'
)})
### --------------------------------------------------------------------
### Test Yourself Answers
### --------------------------------------------------------------------
output$RW <- renderText({
if(input$RW == "eta"){
#pro$data[1] <- 1
#pro$work[1] <- 1
HTML("<h5 style='color:green' align='left'><b>Great!</b></h5> ")
}
# right
else if(input$RW == 'so'){
#pro$data[1] <- 0
#pro$work[1] <- 0
HTML("<br>")}
# nothing chosen
else{
#pro$data[1] <- 0
# pro$work[1] <- 1
HTML("<h5 style ='color:red' align='left'>
<b>Wrong! Try again!</b></h5>")
}
# wrong
})
output$AB<- renderText({
if(input$AB == "eta"){
#pro$data[1] <- 1
#pro$work[1] <- 1
HTML("<h5 style='color:green' align='left'><b>Great!</b></h5> ")
}
# right
else if(input$AB == 'so'){
#pro$data[1] <- 0
#pro$work[1] <- 0
HTML("<br>")}
# nothing chosen
else{
#pro$data[1] <- 0
# pro$work[1] <- 1
HTML("<h5 style ='color:red' align='left'>
<b>Wrong! Try again!</b></h5>")
}
# wrong
})
output$CD<- renderText({
if(input$CD == "eta"){
#pro$data[1] <- 1
#pro$work[1] <- 1
HTML("<h5 style='color:green' align='left'><b>Great!</b></h5> ")
}
# right
else if(input$CD == 'so'){
#pro$data[1] <- 0
#pro$work[1] <- 0
HTML("<br>")}
# nothing chosen
else{
#pro$data[1] <- 0
# pro$work[1] <- 1
HTML("<h5 style ='color:red' align='left'>
<b>Wrong! Try again!</b></h5>")
}
# wrong
})
# ----------- Success Rate
observeEvent(input$aa, {
output$Formel1 <- renderUI({
isolate(
Fa <- if(input$a == "LF"){
HTML("<h5 style='color:green' align='left'><b>Great!</b></h5>")
}else{
HTML("<h5 style ='color:red' align='left'>
<b>Wrong! Try again!</b></h5>")}
)
})
})
# ----------- Natural Success Rate
observeEvent(input$bb, {
output$Formel2 <- renderUI({
isolate(
Fa <- if(input$b == "LF"){
HTML("<h5 style='color:green' align='left'><b>Great!</b></h5>")
}else{
HTML("<h5 style ='color:red' align='left'>
<b>Wrong! Try again!</b></h5>")}
)
})
})
# ----------- Success Rate in words
observeEvent(input$cc, {
output$Formel3 <- renderUI({
isolate(
Fa <- if(input$c == "LF"){
HTML("<h5 style='color:green' align='left'><b>Great!</b></h5>")
}else{
HTML("<h5 style ='color:red' align='left'>
<b>Wrong! Try again!</b></h5>")}
)
})
})
}
shinyApp(ui = ui, server = server)