#Content for Marker Popups
Popcontent1 <- paste(sep = "<br/>",
img(src = "MainBuilding.png"),
"<style> div.leaflet-popup-content {width:auto !important;}</style>",
actionLink("?url=inTabset", "Go to Home", onclick = 'Shiny.onInputChange(\"link_click\", Math.random())'),
"University",
"Main Building")
Popcontent2 <- paste(sep = "<br/>",
img(src = "Law.png"),
"<style> div.leaflet-popup-content {width:auto !important;}</style>",
actionLink("?url=inTabset", "Learn about Simple Examples", onclick = 'Shiny.onInputChange(\"link2_click\", Math.random())'),
"Sir Alexander Stone Building",
"School of Law")
Popcontent3 <- paste(sep = "<br/>",
img(src = "Wolfson.png"),
"<style> div.leaflet-popup-content {width:auto !important;}</style>",
actionLink("?url=inTabset", "Learn about Changing d' and Criterion", onclick = 'Shiny.onInputChange(\"link3_click\", Math.random())'),
"Wolfson Medical Building",
"School of Medicine")
Popcontent4 <- paste(sep = "<br/>",
img(src = "Psychology.png"),
"<style> div.leaflet-popup-content {width:auto !important;}</style>",
actionLink("?url=inTabset", "Learn about Changing Base Rates", onclick = 'Shiny.onInputChange(\"link4_click\", Math.random())'),
"Psychology Department",
"Institute of Neuroscience and Psycology")
Popcontent5 <- paste(sep = "<br/>",
img(src = "Sundial.png"),
"<style> div.leaflet-popup-content {width:auto !important;}</style>",
actionLink("?url=inTabset", "Learn about Hypothesis Testing", onclick = 'Shiny.onInputChange(\"link5_click\", Math.random())'),
"Rankine Building",
"School of Engineering")
Popcontent6 <- paste(sep = "<br/>",
img(src = "GrahamKerr.png"),
"<style> div.leaflet-popup-content {width:auto !important;}</style>",
actionLink("?url=inTabset", "Simple Examples - One Step Further", onclick = 'Shiny.onInputChange(\"link6_click\", Math.random())'),
"Graham Kerr Building",
"School of Zoology")
Popcontent7 <- paste(sep = "<br/>",
img(src = "Kelvingrove.png"),
"<style> div.leaflet-popup-content {width:auto !important;}</style>",
actionLink("?url=inTabset", "Glossary", onclick = 'Shiny.onInputChange(\"link7_click\", Math.random())'),
"Kelvingrove Park",
"Public Park")
shinyServer(function(input, output, session){
## University of Glasgow Campus Map
output$UofG <- renderLeaflet({
UofG <- leaflet(options = leafletOptions(zoomControl = FALSE, minZoom = 16, maxZoom = 16)) %>%
setView(lng = -4.28951, lat =55.87187, zoom = 16)%>%
addTiles(options = providerTileOptions(opacity = 0.45)) %>% # Default Tile Set
#different map color pallets
## addProviderTiles(providers$Stamen.Toner) %>%
## addProviderTiles(providers$CartoDB.Positron) %>%
## Map Markers added to mark out building options
addCircleMarkers(lng=-4.28841, lat=55.87177, radius = 15, opacity = 0.5, color = "#008B45", #MainBuilding
popup=Popcontent1)%>%
addCircleMarkers(lng=-4.29101, lat=55.87350, radius = 13, color = "#00CD66", #LawBuilding
popup=Popcontent2)%>%
addCircleMarkers(lng=-4.29291, lat=55.87297, radius = 13, color = "#48D1CC", #MedicalBuilding
popup=Popcontent3)%>%
addCircleMarkers(lng=-4.28799, lat=55.87397, radius = 13, color = "#4F94CD", #Psychology
popup=Popcontent4)%>%
addCircleMarkers(lng=-4.28571, lat=55.87257, radius = 13, color = "#3A5FCD", #Engineering
popup=Popcontent5)%>%
addCircleMarkers(lng=-4.29291, lat=55.87141, radius = 13, color = "#8B0000", #Zoology
popup=Popcontent6)%>%
addCircleMarkers(lng=-4.28591, lat=55.86961, radius = 13, color = "#8B0000", #Kelvingrove Park
popup=Popcontent7)
## PopTEST <- addCircleMarkers(UofG, lng=-4.28871, lat=55.87137, color = "#9400D3", #Test Marker
# popup=Popcontent1)
})
##Event Director for Mouse Clicks
observeEvent(input$link_click,{
updateTabsetPanel(session, "inTabset", "Home")
})
observeEvent(input$link2_click,{
updateTabsetPanel(session, "inTabset", "A")
})
observeEvent(input$link3_click,{
updateTabsetPanel(session, "inTabset", "B")
})
observeEvent(input$link4_click,{
updateTabsetPanel(session, "inTabset", "C")
})
observeEvent(input$link5_click,{
updateTabsetPanel(session, "inTabset", "D")
})
observeEvent(input$link6_click,{
updateTabsetPanel(session, "inTabset", "E")
})
####Disabled while there are no corresponding tabs####
observeEvent(input$link7_click,{
updateTabsetPanel(session, "inTabset", "F")
})
############################HOME####################################################
#Plot Liberal
output$liberal<- renderPlot({
Liberal<-data.frame(Measure=c('Hits', 'Correct Rejections'), Score=c(100,0),num=c(1,2))
Liberal$Measure <- factor(Liberal$Measure, levels = Liberal$Measure[order(Liberal$num)])
ggplot(Liberal, aes(Measure, Score)) + geom_bar(stat='identity',aes(fill= Measure)) +
scale_fill_manual(values=c("#7B1DAB", "#E58BEE") )+ #, , "#0092CD", "#87F4FF"))+
ggtitle('dPrime (d\'): 0') +
xlab('') +
ylab('Accuracy in %')
})
#Plot Conservative
output$cons<- renderPlot({
Conservative<-data.frame(Measure=c('Hits', 'COrrect Rejections'), Score=c(0,100),num=c(1,2))
Conservative$Measure <- factor(Conservative$Measure, levels = Conservative$Measure[order(Conservative$num)])
ggplot(Conservative, aes(Measure, Score)) + geom_bar(stat='identity',aes(fill= Measure)) +
scale_fill_manual(values=c("#FF8B00", "#FFF44E")) + #, "#FF8B00", "#FFF44E", "#0092CD", "#87F4FF"))+
ggtitle('dPrime (d\'): 0') +
xlab('') +
ylab('Accuracy in %')
})
#Plot Ideal
output$ideal<- renderPlot({
Ideal<-data.frame(Measure=c('Hits', 'Correct Rejections'), Score=c(input$accHR,input$accCR),num=c(1,2))
Ideal$Measure <- factor(Ideal$Measure, levels = Ideal$Measure[order(Ideal$num)])
ACCHR<- input$accHR/100
ACCFA<- (100 - input$accCR)/100
if (ACCHR == 1) {
ACCHR <- 0.99
} else if (ACCHR == 0) {
ACCHR <- 0.001
} else {
ACCHR <- (100 - input$accHR)/100
}
if (ACCFA == 0) {
ACCFA <- 0.001
} else if (ACCFA == 1) {
ACCFA <- 0.99
} else {
ACCFA <- (100 - input$accCR)/100
}
zACCHR <- qnorm(ACCHR)
zACCFA <- qnorm(ACCFA)
THED <- zACCHR - zACCFA
#plot
ggplot(Ideal, aes(Measure, Score)) + geom_bar(stat='identity',aes(fill= Measure)) +
scale_fill_manual(values=c("#0092CD", "#87F4FF") )+
ggtitle(paste('dPrime (d\'):',round(THED, digits = 2))) +
xlab('')+
ylab('Accuracy in %') +
theme(
axis.text.x = element_blank(),
axis.ticks = element_blank()) +
ylim(0,100)
})
############################ Tab 1A ######################################################################
# create table with rates from absolute values
output$rate2<-renderTable({
#calculate the rates (probability) from the entered absolute values
hitrate<- input$hit/(input$hit+input$miss)
missrate <- input$miss/(input$hit+input$miss)
farate <- input$FA/(input$FA+input$cr)
crrate<- input$cr/(input$FA+input$cr)
#add them to seperate lists and create dataframe
Rainy <- c(hitrate, missrate)
Sunny <- c(farate, crrate)
Weather <-c("Umbrella","No Umbrella")
rates <- data.frame(Weather, Rainy, Sunny)
colnames(rates) <- c("", "Rainy", "Sunny")
rates},
options= list(searching = F, paging = F), include.rownames=FALSE)
# create table with z scores from proportions values
output$zrate<-renderTable({
#calculate the rates (probability) from the entered absolute values
hitrate <- input$hit/(input$hit+input$miss)
farate <- input$FA/(input$FA+input$cr)
if (hitrate == 1) {
hitrate <- 1 - 1/(2*(input$hit+input$miss))
} else if (hitrate == 0) {
hitrate <- 0 + 1/(2*(input$hit+input$miss))
} else {
hitrate <- input$hit/(input$hit+input$miss)
}
if (farate == 0) {
farate <- 0 + 1/(2*(input$FA+input$cr))
} else if (farate == 1) {
farate <- 1 - 1/(2*(input$FA+input$cr))
} else {
farate <- input$FA/(input$FA+input$cr)
}
zHit <- qnorm(hitrate)
zFA <- qnorm(farate)
dPrime <- zHit - zFA
Crit = -0.5*(zHit + zFA)
#add them to seperate lists and create dataframe
zrate <- data.frame(zHit, zFA, dPrime, Crit)})
output$text <- renderText({
hitrate <- input$hit/(input$hit+input$miss)
farate <- input$FA/(input$FA+input$cr)
if (hitrate == 1) {
hitrate <- 1 - 1/(2*(input$hit+input$miss))
} else if (hitrate == 0) {
hitrate <- 0 + 1/(2*(input$hit+input$miss))
} else {
hitrate <- input$hit/(input$hit+input$miss)
}
if (farate == 0) {
farate <- 0 + 1/(2*(input$FA+input$cr))
} else if (farate == 1) {
farate <- 1 - 1/(2*(input$FA+input$cr))
} else {
farate <- input$FA/(input$FA+input$cr)
}
zHit <- qnorm(hitrate)
zFA <- qnorm(farate)
dPrime <- zHit - zFA
Crit = -0.5*(zHit + zFA)
paste("The dPrime (d') score for this example is: ",round(dPrime, digits = 2), "and the Criterion (c) is at: ",round(Crit, digits = 2))
})
#Epic WafflePlot
output$DistWaffle <- renderPlot({
WaffleRates <- data.frame('No Umbrella on a Sunny Day'= round(0.5*(input$cr/(input$FA+input$cr)), digits = 2),
'Umbrella on a Sunny Day'= round(0.5*(input$FA/(input$FA+input$cr)), digits = 2),
'No Umbrella on a Rainy Day'= round(0.5*(input$miss/(input$hit+input$miss)), digits = 2),
'Umbrella on a Rainy Day'= round(0.5*(input$hit/(input$hit+input$miss)), digits = 2))
waffle(round(WaffleRates*100, digits = 2),rows=10, size=2, glyph_size = 20,
colors=c("#009fbf", "#8000bf", "#bf2100", "#00bf80"),
title="Probability Outcomes",
flip=TRUE,
xlab="Outcomes")
})
############################ Tab 1B ######################################################################
# create table with rates from absolute values
output$rate21B<-renderTable({
#calculate the rates (probability) from the entered absolute values
hitrate1B<- input$hit1B/(input$hit1B+input$miss1B)
missrate1B <- input$miss1B/(input$hit1B+input$miss1B)
farate1B <- input$FA1B/(input$FA1B+input$cr1B)
crrate1B<- input$cr1B/(input$FA1B+input$cr1B)
#add them to seperate lists and create dataframe
Rainy1B <- c(hitrate1B, missrate1B)
Sunny1B <- c(farate1B, crrate1B)
Weather1B <-c("Umbrella","No Umbrella")
rates1B <- data.frame(Weather1B, Rainy1B, Sunny1B)
colnames(rates1B) <- c("", "Rainy", "Sunny")
rates1B},
options= list(searching = F, paging = F), include.rownames=FALSE)
# create table with z scores from proportions values
output$zrate1B<-renderTable({
#calculate the rates (probability) from the entered absolute values
hitrate1B<- input$hit1B/(input$hit1B+input$miss1B)
farate1B <- input$FA1B/(input$FA1B+input$cr1B)
if (hitrate1B == 1) {
hitrate1B <- 1 - 1/(2*(input$hit1B+input$miss1B))
} else if (hitrate1B == 0) {
hitrate1B <- 0 + 1/(2*(input$hit1B+input$miss1B))
} else {
hitrate1B <- input$hit1B/(input$hit1B+input$miss1B)
}
if (farate1B == 0) {
farate1B <- 0 + 1/(2*(input$FA1B+input$cr1B))
} else if (farate1B == 1) {
farate1B <- 1 - 1/(2*(input$FA1B+input$cr1B))
} else {
farate1B <- input$FA1B/(input$FA1B+input$cr1B)
}
zHit1B <- qnorm(hitrate1B)
zFA1B <- qnorm(farate1B)
dPrime1B <- zHit1B - zFA1B
Crit1B = -0.5*(zHit1B + zFA1B)
#add them to seperate lists and create dataframe
zrate1B <- data.frame(zHit1B, zFA1B, dPrime1B, Crit1B)
colnames(zrate1B) <- c("z Hit", "z False Alarm", "dPrime", "Criterion")
zrate1B},include.rownames=FALSE)
# PLOTS
output$Dist1B <- renderPlot({
#Pre-calculations
hitrate1B<- input$hit1B/(input$hit1B+input$miss1B)
farate1B <- input$FA1B/(input$FA1B+input$cr1B)
if (hitrate1B == 1) {
hitrate1B <- 1 - 1/(2*(input$hit1B+input$miss1B))
} else if (hitrate1B == 0) {
hitrate1B <- 0 + 1/(2*(input$hit1B+input$miss1B))
} else {
hitrate1B <- input$hit1B/(input$hit1B+input$miss1B)
}
if (farate1B == 0) {
farate1B <- 0 + 1/(2*(input$FA1B+input$cr1B))
} else {
farate1B <- input$FA1B/(input$FA1B+input$cr1B)
}
zHit1B <- qnorm(hitrate1B)
zFA1B <- qnorm(farate1B)
dPrime1B <- zHit1B - zFA1B
Crit1B = -0.5*(zHit1B + zFA1B)
FAR1B <- seq(-5,10,length=1000)
HR1B <- seq(-5,10,length=1000)
# get normal probability density functions
dFAR1B <- dnorm(FAR1B,mean=0,sd=1)
dHR1B <- dnorm(HR1B,mean=dPrime1B,sd=1) # sd=1 for equal variance SD
# draw the density function + line for criterion
bg = "Grey"
plot(FAR1B, dFAR1B, type="l", col='blue', xlab="", ylab="", ylim=c(0,.5), lwd=2) # FAR distribution
par(new=T)
plot(HR1B, dHR1B, type="l", col='red', axes=F, xlab="x", ylab="Normal probability density function", ylim=c(0,.5), lwd=2) # HR distribution
abline(v=Crit1B,lty=3, lwd=2) # dotted line for criterion
legend("topright",legend=c("False Alarm Rate (noise only)","Hit Rate (signal + noise)"),col=c("blue","red"),lty=1)
par(new=F)
},height=400,width=400)
#ROC Curve
output$ROC <- renderPlot({
#Pre-calculations
hitrate1B<- input$hit1B/(input$hit1B+input$miss1B)
farate1B <- input$FA1B/(input$FA1B+input$cr1B)
hitrate1B<- input$hit1B/(input$hit1B+input$miss1B)
farate1B <- input$FA1B/(input$FA1B+input$cr1B)
if (hitrate1B == 1) {
hitrate1B <- 1 - 1/(2*(input$hit1B+input$miss1B))
} else if (hitrate1B == 0) {
hitrate1B <- 0 + 1/(2*(input$hit1B+input$miss1B))
} else {
hitrate1B <- input$hit1B/(input$hit1B+input$miss1B)
}
if (farate1B == 0) {
farate1B <- 0 + 1/(2*(input$FA1B+input$cr1B))
} else {
farate1B <- input$FA1B/(input$FA1B+input$cr1B)
}
zHit1B <- qnorm(hitrate1B)
zFA1B <- qnorm(farate1B)
dPrime1B <- zHit1B - zFA1B
Crit1B = -0.5*(zHit1B + zFA1B)
FAR1B <- seq(-5,10,length=1000)
HR1B <- seq(-5,10,length=1000)
# get response probabilities for each distribution
pFAR <- 1-pnorm(FAR1B,mean=0,sd=1)
pHR <- 1-pnorm(HR1B,mean=dPrime1B,sd=1)
# get response probabilities at criterion
pFAR.crit <- 1-pnorm(Crit1B,mean=0,sd=1)
pHR.crit <- 1-pnorm(Crit1B,mean=dPrime1B,sd=1)
# draw the ROC + dot for criterion + chance line
plot(pFAR,pHR, type="l", col='black', xlim=c(0,1), ylim=c(0,1), xlab="", ylab="")
par(new=T)
plot(pFAR.crit, pHR.crit, col='black', pch=19, xlim=c(0,1), ylim=c(0,1), axes=F, , xlab="FA Rate", ylab="Hit Rate")
abline(a=0,b=1,lty=3)
par(new=F)
},height=400,width=400)
output$zROC <- renderPlot({
#Pre-calculations
hitrate1B<- input$hit1B/(input$hit1B+input$miss1B)
farate1B <- input$FA1B/(input$FA1B+input$cr1B)
if (hitrate1B == 1) {
hitrate1B <- 1 - 1/(2*(input$hit1B+input$miss1B))
} else if (hitrate1B == 0) {
hitrate1B <- 0 + 1/(2*(input$hit1B+input$miss1B))
} else {
hitrate1B <- input$hit1B/(input$hit1B+input$miss1B)
}
if (farate1B == 0) {
farate1B <- 0 + 1/(2*(input$FA1B+input$cr1B))
} else {
farate1B <- input$FA1B/(input$FA1B+input$cr1B)
}
zHit1B <- qnorm(hitrate1B)
zFA1B <- qnorm(farate1B)
dPrime1B <- zHit1B - zFA1B
Crit1B = -0.5*(zHit1B + zFA1B)
FAR1B <- seq(-5,10,length=1000)
HR1B <- seq(-5,10,length=1000)
# get response probabilities for each distribution
pFAR <- 1 - pnorm(FAR1B,mean=0,sd=1)
pHR <- 1-pnorm(HR1B,mean=dPrime1B,sd=1)
qFAR <- qnorm(pFAR[pFAR>.001 & pFAR<.999 & pHR>.001 & pHR<.999]) # drop endpoints (0 & 1 go to Inf)
qHR <- qnorm(pHR[pFAR>.001 & pFAR<.999 & pHR>.001 & pHR<.999])
# get response probabilities at criterion
pFAR.crit <- 1 - pnorm(Crit1B,mean=0,sd=1)
pHR.crit <- 1-pnorm(Crit1B,mean=dPrime1B,sd=1)
qFAR.crit <- qnorm(pFAR.crit)
qHR.crit <- qnorm(pHR.crit)
# draw the zROC + dot for criterion
plot(qFAR,qHR, type="l", col='black', xlim=c(-3.1,3.1), ylim=c(-3.1,3.1),xlab="z FA Rate", ylab="z Hit Rate")
par(new=T)
plot(qFAR.crit, qHR.crit, col='black', pch=19, xlim=c(-3.1,3.1), ylim=c(-3.1,3.1), axes=F, xlab="z FA Rate", ylab="z Hit Rate")
abline(a=0,b=1,lty=3)
par(new=F)
},height=400,width=400)
############################Tab 2######################################################################
#Lie Detector table
output$data<-renderTable({
zFA <-input$criterion*(-1)- 0.5*input$dprime
zH <- input$dprime + zFA
Hits <-pnorm(zH)
FalseAlarm <-pnorm(zFA)
Rainy <-c(Hits,1-Hits)
Sunny <-c(FalseAlarm, 1-FalseAlarm)
Weather <- c("Umbrella","No Umbrella")
prob <- data.frame(Weather, Rainy, Sunny)
colnames(prob) <- c("", "Rainy", "Sunny")
prob},
options= list(searching = F, paging = F), include.rownames=FALSE)
### Z table
output$zdata<-renderTable({
zFA <-input$criterion*(-1)- 0.5*input$dprime
zH <- input$dprime + zFA
zrate <- data.frame(zH, zFA)
colnames(zrate) <- c("z Hit", "z False Alarm")
zrate
}, include.rownames=FALSE)
###Plots
FAR <- seq(-5,10,length=1000)
HR <- seq(-5,10,length=1000)
output$distPlot <- renderPlot({
# get normal probability density functions
dFAR <- dnorm(FAR,mean=0,sd=1)
dHR <- dnorm(HR,mean=input$dprime,sd=input$SD) # sd=1 for equal variance SD
# draw the density function + line for criterion
plot(FAR, dFAR, type="l", col='blue', xlab="", ylab="", ylim=c(0,.5), lwd=2) # FAR distribution
par(new=T)
plot(HR, dHR, type="l", col='red', axes=F, xlab="x", ylab="Normal probability density function", ylim=c(0,.5), lwd=2) # target distribution
abline(v=input$criterion,lty=3, lwd=2) # dotted line for criterion
legend("topright",legend=c("False Alarm Rate (noise only)","Hit Rate (signal + noise)"),col=c("blue","red"),lty=1)
par(new=F)
},height=400,width=400)
output$rocPlot <- renderPlot({
# get response probabilities for each distribution
pFAR <- 1-pnorm(FAR,mean=0,sd=1)
pHR <- 1-pnorm(HR,mean=input$dprime,sd=input$SD)
# get response probabilities at criterion
pFAR.crit <- 1-pnorm(input$criterion,mean=0,sd=1)
pHR.crit <- 1-pnorm(input$criterion,mean=input$dprime,sd=input$SD)
# draw the ROC + dot for criterion + chance line
plot(pFAR,pHR, type="l", col='black', xlim=c(0,1), ylim=c(0,1), xlab="", ylab="")
par(new=T)
plot(pFAR.crit, pHR.crit, col='black', pch=19, xlim=c(0,1), ylim=c(0,1), axes=F, , xlab="FA Rate", ylab="Hit Rate")
abline(a=0,b=1,lty=3)
par(new=F)
},height=400,width=400)
output$zrocPlot <- renderPlot({
# get response probabilities for each distribution
pFAR <- 1 - pnorm(FAR,mean=0,sd=1)
pHR <- 1-pnorm(HR,mean=input$dprime,sd=input$SD)
qFAR <- qnorm(pFAR[pFAR>.001 & pFAR<.999 & pHR>.001 & pHR<.999]) # drop endpoints (0 & 1 go to Inf)
qHR <- qnorm(pHR[pFAR>.001 & pFAR<.999 & pHR>.001 & pHR<.999])
# get response probabilities at criterion
pFAR.crit <- 1 - pnorm(input$criterion,mean=0,sd=1)
pHR.crit <- 1-pnorm(input$criterion,mean=input$dprime,sd=input$SD)
qFAR.crit <- qnorm(pFAR.crit)
qHR.crit <- qnorm(pHR.crit)
# draw the zROC + dot for criterion
plot(qFAR,qHR, type="l", col='black', xlim=c(-3.1,3.1), ylim=c(-3.1,3.1),xlab="z FA Rate", ylab="z Hit Rate")
par(new=T)
plot(qFAR.crit, qHR.crit, col='black', pch=19, xlim=c(-3.1,3.1), ylim=c(-3.1,3.1), axes=F, xlab="z FA Rate", ylab="z Hit Rate")
abline(a=0,b=1,lty=3)
par(new=F)
},height=400,width=400)
output$AUC <- renderText({
zFA <-input$criterion*(-1)- 0.5*input$dprime
zH <- input$dprime + zFA
Hitrate <-pnorm(zH)
FalseAlarmRate <- 1-pnorm(zFA)
sequence <- seq(-5,10,length=1000)
# get response probabilities for each distribution
pFAR <- 1-pnorm(sequence,mean=0,sd=1)
pHR <- 1-pnorm(sequence,mean=input$dprime,sd=input$SD)
AUC <- auc(x = pFAR, y = pHR, thresh = 0.001)
qFAR <- qnorm(pFAR[pFAR>.001 & pFAR<.999 & pHR>.001 & pHR<.999]) # drop endpoints (0 & 1 go to Inf)
qHR <- qnorm(pHR[pFAR>.001 & pFAR<.999 & pHR>.001 & pHR<.999])
x <- qFAR[2]
x1 <- qFAR[3]
y <- qHR[2]
y1 <- qHR[3]
m <- (y-y1)/(x-x1)
b <- y-m*x
y2 <- b
x2 <- b/m
ZAUC <- (x2*y2)/2
#paste(zFA, zH, Hits, FalseAlarm, Sensitivity, Specificity) #, AUC_Sens, AUC_Spec)
paste("The Area Under the Curve (AUC) in this example is: ",round(AUC, digits = 2), ". The Z-transformed area under the curve (zAUC) is:", round(ZAUC, digits =2))
})
######################################## Tab 3 ##########################################################
output$WafflePlotBase <- renderPlot({
base<-input$base_rate
data_base<-c('Rainy Days'=base,'Sunny Days'=100-base)
waffle(data_base, rows=10, size=2, glyph_size = 20,
colors=c("#009fbf", "#D3D3D3"),
title="",
xlab="")
})
output$WafflePlotPow <- renderPlot({
base<-input$base_rate
pow<-input$PowerBase
if (pow<0.1) {
pow=0
} else {
pow<-input$PowerBase
}
data_power<-c('Umbrella on a Rainy Day'=round(pow*base),
'No Umbrella on a Rainy Day'=base-round(pow*base),
'Sunny Days'=100-base)
waffle(data_power,rows=10, size=2, glyph_size = 20,
colors=c("#FF0000", "#009fbf", "#D3D3D3"),
title="",
xlab="")
})
output$WafflePlotAlp <- renderPlot({
base<-input$base_rate
pow<-input$PowerBase
alp<-input$AlphaBase
# if (100*alp>(100-base)) {
# alp=(100-base)/100
# } else {
# alp<-input$AlphaBase
# }
data_power<-c('Umbrella on a Rainy Day'=round(pow*base),
'No Umbrella on a Rainy Day'=base-round(pow*base),
'Umbrella on a Sunny Day'=round(alp*(100-base)),
'No Umbrella on a Sunny Day'=100-base-round(alp*(100-base)))
waffle(data_power,rows=10, size=2, glyph_size = 20,
colors=c("#FF0000", "#009fbf", "#008000", "#D3D3D3"),
title="",
xlab="")
})
######################################## Tab 4 ##########################################################
#NHST table
output$nhst<-renderTable({
beta <- 1-input$power
alpha <- 1-input$type1
#add them to seperate lists and create dataframe
Decision_Retain_H0 <- c(input$type1, alpha)
Decison_Reject_H0 <- c(beta, input$power)
Test_Outcome <- c("Retain H0","Reject H0")
rates <- data.frame(Test_Outcome,Decision_Retain_H0,Decison_Reject_H0)
colnames(rates) <- c("Population state","Decision: Retain H0","Decison: Reject H0")
rates},
options= list(searching = F, paging = F),include.rownames=FALSE)
#Base rate table when changing CI but assuming power
output$nhst.br.ci <- renderTable({
br.sens <- input$baserate1
br.spec <- 1-input$baserate1
#calculate true alpha level
trueCI <- round((input$type11*br.sens)/br.spec, digits = 2)
true.alpha <- 1-trueCI
#Create data table
Decision_Retain_H0 <- c(trueCI, true.alpha)
Decison_Reject_H0 <- c(0.10, 0.9)
Test_Outcome <- c("Retain H0","Reject H0")
rates <- data.frame(Test_Outcome,Decision_Retain_H0,Decison_Reject_H0)
colnames(rates) <- c("Population state","Decision: Retain H0","Decison: Reject H0")
rates},
options= list(searching = F, paging = F),include.rownames=FALSE)
#Base rate table when changing CI but assuming power
output$nhst.br.power <- renderTable({
br.sens <- input$baserate2
br.spec <- 1-input$baserate2
#calculate true beta level
truepower <- round((input$type2*br.sens)/br.spec, digits = 2)
true.beta <- 1-truepower
#Create data table
Decision_Retain_H0 <- c(0.95,0.05 )
Decison_Reject_H0 <- c(true.beta,truepower)
Test_Outcome <- c("Retain H0","Reject H0")
rates <- data.frame(Test_Outcome,Decision_Retain_H0,Decison_Reject_H0)
colnames(rates) <- c("Population state","Decision: Retain H0","Decison: Reject H0")
rates},
options= list(searching = F, paging = F), include.rownames=FALSE)
})
######################################## Glossary ##########################################################
#install.packages("leaflet")
#install.packages("waffle")
#install.packages("shinyBS")
#install.packages("flux")
library(shiny)
library(leaflet)
library(dplyr)
library(waffle)
library(shinyBS)
library(ggplot2)
library(flux)
shinyUI(fluidPage(
includeScript("../../../Matomo-tquant.js"),
tags$style(HTML(".js-irs-0 .irs-single, .js-irs-0 .irs-bar-edge, .js-irs-0 .irs-bar {background: #0092CD}")),
tags$style(HTML(".js-irs-1 .irs-single, .js-irs-1 .irs-bar-edge, .js-irs-1 .irs-bar {background: #87F4FF}")),
tags$style(HTML(".js-irs-2 .irs-single, .js-irs-2 .irs-bar-edge, .js-irs-2 .irs-bar {background: purple}")),
tags$style(HTML(".js-irs-3 .irs-single, .js-irs-3 .irs-bar-edge, .js-irs-3 .irs-bar {background: orange}")),
tags$style(HTML(".js-irs-4 .irs-single, .js-irs-4 .irs-bar-edge, .js-irs-4 .irs-bar {background: red}")),
tags$style(HTML(".js-irs-5 .irs-single, .js-irs-5 .irs-bar-edge, .js-irs-5 .irs-bar {background: #009fbf}")),
tags$style(HTML(".js-irs-6 .irs-single, .js-irs-6 .irs-bar-edge, .js-irs-6 .irs-bar {background: red}")),
tags$style(HTML(".js-irs-7 .irs-single, .js-irs-7 .irs-bar-edge, .js-irs-7 .irs-bar {background: green}")),
tags$style(HTML(".js-irs-8 .irs-single, .js-irs-8 .irs-bar-edge, .js-irs-8 .irs-bar {background: green}")),
tags$style(HTML(".js-irs-9 .irs-single, .js-irs-9 .irs-bar-edge, .js-irs-9 .irs-bar {background: #009fbf}")),
tags$style(HTML(".js-irs-10 .irs-single, .js-irs-10 .irs-bar-edge, .js-irs-10 .irs-bar {background: red}")),
tags$style(HTML(".js-irs-11 .irs-single, .js-irs-11 .irs-bar-edge, .js-irs-11 .irs-bar {background: green}")),
tags$style(HTML(".js-irs-12 .irs-single, .js-irs-12 .irs-bar-edge, .js-irs-12 .irs-bar {background: red}")),
tags$style(HTML(".js-irs-13 .irs-single, .js-irs-13 .irs-bar-edge, .js-irs-13 .irs-bar {background: #009fbf}")),
titlePanel(
fluidRow(
column(4,
img(src = "UofGLogo100.png", align = "left")),
column(4,
img(src = "Lisboa100.png")),
column(4,
img(src = "tquant100.png", align = "right"))
)
),
leafletOutput("UofG", width = "100%", height = 500),
######################################## Tab HOME #########################################
tabsetPanel(id = "inTabset",
tabPanel("Home", value = "Home",
br(),
h4("Signal Detection"),
br(),
mainPanel(),
fluidRow(
column(12,
p("Signal-Detection Theory (SDT) provides a general framework to describe and study decisions that are made in uncertain or ambiguous situations."),
p("As an example, let us consider the decision of whether or not you should take your umbrella with you when you leave your house in case it rains. On the one hand you do not want to risk getting wet by not bringing it with you; on the other hand, you already have to carry so many things that you do not want to be dragging around an umbrella the whole day unless it is absolutely necessary."),
p("Realistically there are only two possible scenarios: it either rains or it doesn't. In SDT we call the occasions where something of interest (the rain, in our example) is present, the signal, and the ones where it is not, the noise. If it does rain and you brought your umbrella with you, you were able to detect the signal, and we call this scenario a hit. If, however, it did rain but you did not bring an umbrella, we say that you missed the signal, and you are soaked."),
p("As such, the proportion of hits is calculated as:"),
br(),
img(src = "Hitrate130.png"),
br(),
br(),
p("with the Number of times the signal was present being the number of hits plus the number of misses."),
p("Unfortunately, the hit rate is incomplete as a summary of our overall skill in predicting information. Getting back to our umbrella example, if you were always taking it with you, you would be able to detect the signal 100% of the time. However, your ability to predict the weather in general would probably be less than that since it usually does not rain every day. This type of tactic would mean that you would also wrongly detect the signal when it was not present, a phenomenon known as a false alarm.
The proportion of false alarms is calculated as:"),
br(),
img(src = "FArate130.png"),
br(),
br(),
p("with the Number of times the signal was not present being the number of false alarms plus the number of correct rejections."),
p("A different strategy would be to never bring it with you, which would mean you were able to detect the noise 100% of the time (correctly detecting the noise is known as a correct rejection). However, using this approach would also mean that your hit rate would be 0 and your miss rate 100%."),
p("A good measure of performance should then be independent of any strategic effects. As such, we should consider all possible scenarios, as illustrated bellow:"),
br(),
img(src ="SDT800.png"),
br(),
br(),
p("The sensitivity index d' is an index used in Signal-Detection Theory. Simply put, it measures discriminability, or the ability to distinguish between signal and noise. It can be easily calculated from the converted z-scores (since they are from different normal distributions) of hits and false alarms rates:"),
img(src ="dPrime.png"),
p("Using d' we have a much more accurate representation of our ability to detect an event under weak, uncertain or even ambiguous conditions. With it, we can distinguish between a good performance that is due to actual skill and one that is a mere product of random guessing."),
br(),
hr(),
br()
)),
fluidRow(
column(12,
p("Bellow you can see a representation of the two extreme cases described before: someone who always brings the umbrella and someone who never brings the umbrella."),
p("The graph on the far right shows a perfect prediction: someone who detects the signal 100% of the time, and who also detects the noise 100% of the time. Compare its d' to the extreme cases and try to change the values for the hits and the correct rejections and see how the d' varies with the changes."))
),
br(),
fluidRow(
column(4,
h4('Always takes an Umbrella'),
plotOutput('liberal')),
column(4,
h4('Never takes an Umbrella'),
plotOutput('cons')),
column(4,
h4('The perfect Weather Guesser'),
plotOutput('ideal'),
sliderInput('accHR', 'Choose the Accuracy on Hits',value=100, min=0, max=100),
sliderInput('accCR', 'Choose the Accuracy on Correct Rejections',value=100, min=0, max=100)))
), #end of tab panel Home
######################################## Tab 1A #########################################
tabPanel("Simple Example 1A", value = "A",
br(),
#Description (Includes Vlada's polygraph example)
fluidRow(
column(12,
p("Here we are continuiung with our rainy example."),
br(),
p("Lets consider that our person correctly bringes an umbrella on 95 of the rainy days and on 10 days he brings the umbrella but it was sunny.
Additionally, the umbrella person correctly leaves his umbrella when it is sunny on 90 days
but he also incorrectly leaves his umbrella at home on 5 days when it wa sactually raining and he gets soaked. This information, once transformed
into relative probabilities, can be used to calculate d\'."),
br(),
br())
),
splitLayout(cellWidths = c("60%", "40%"),
verticalLayout(
splitLayout(
verticalLayout( #create the input space for absolute values
h4("Absolute Values"),
br(),
fluidRow(
column(6,
numericInput("hit", label = "Umrella on Rainy Day (Hits)", value=95)),
column(6,
numericInput("FA", "Umbrella on Sunny Day (False Alarm)",value=10 ))
),
fluidRow(
column(6,
numericInput("miss", label = "No Umbrella on Rainy Day (Miss)", value=5)),
column(6,
numericInput("cr", "No Umbrella on Sunny Day (Correct Rejection)",value=90 ))
)
#br(),
#hr(),
),
#Create rate table
fluidRow(
column(11, offset = 1,
h4("Probability table"),
br(),
tableOutput("rate2")
)
)),
# Text Summary
fluidRow(
column(12,
br(),
br(),
verbatimTextOutput("text"),
tags$style(type='text/css',
'#text {background-color: rgba(255,125,0,0.79); color: black;
font-size: 18px;
font-style: italic;}')
)
)),
fluidRow(
column(12,
plotOutput("DistWaffle")
))
)),
######################################## Tab 1B #########################################
tabPanel("Simple Example 1B", value = "E",
br(),
#Description (Includes Vlada's polygraph example)
fluidRow(
column(12,
p("Here we are continuiung with our rainy example."),
br()
)
),
br(),
br(),
splitLayout(cellWidths = c("30%", "40%", "30%"),
verticalLayout( #create the input space for absolute values
h4("Absolute Values"),
br(),
fluidRow(
column(6,
numericInput("hit1B", label = "Hits", value=95)),
column(6,
numericInput("FA1B", "False Alarm",value=10 ))
),
fluidRow(
column(6,
numericInput("miss1B", label = "Miss", value=5)),
column(6,
numericInput("cr1B", "Correct Rejection",value=90 ))
)),
#Create rate table
fluidRow(
column(11, offset = 1,
h4("Probability table"),
br(),
tableOutput("rate21B"))),
# z score table w/ criterion
fluidRow(
column(11, offset = 1,
h4("z scores"),
br(),
tableOutput("zrate1B")
)
)
),
hr(),
# Plots
fluidRow(
column(4,
h4('Density Plot'),
plotOutput("Dist1B"),
bsPopover("Dist1B", title = 'Density Plot',
content = 'This is a density plot',
placement = 'top', trigger = 'hover')
),
column(4,
h4('ROC'),
plotOutput("ROC"),
bsPopover("ROC", title = 'ROC',
content = 'Receiver Operating Characteristic (ROC) curves visualize the tradeoffs between sensitivitiy and specificity in a binary classifier.',
placement = 'top', trigger = 'hover')
),
column(4,
h4('zROC'),
plotOutput("zROC"),
bsPopover("zROC", title = 'Z-ROC',
content = 'This is a zROC plot',
placement = 'top', trigger = 'hover'))
)
),
######################################## Tab 2 #########################################
tabPanel("Changing d' and Criterion", value = "B",
br(),
fluidRow(
column(4,
sliderInput("dprime",
"Discriminability (d'):",
min = 0,
max = 4,
value = 2.92,
step = .10),
sliderInput("criterion",
"Decision criterion (C):",
min = -5,
max = 5,
value = -0.18,
step = .10),
sliderInput("SD",
"Standard Deviation of the Signal:",
min = 0,
max = 6,
value = 1,
step = .25)),
column(8,
p("Here we will explore the effect of manipulating the criterion on the sensetivity and false alarm rate of the polygraph. Additionally, here you can see how the date would
change if d' prime is changed.")
)),
fluidRow(
column(4,
h4("Data"),
br(),
tableOutput("data")),
column(4,
h4("z data"),
br(),
tableOutput("zdata")
)),
# Plots
fluidRow(
column(4,
h4('Density plot'),
plotOutput("distPlot"),
bsPopover("distPlot", title = 'Density Plot',
content = 'This is a density plot',
placement = 'top', trigger = 'hover')
),
column(4,
h4('ROC'),
plotOutput("rocPlot"),
bsPopover("rocPlot", title = 'ROC',
content = 'Receiver Operating Characteristic (ROC) curves visualize the tradeoffs between sensitivitiy and specificity in a binary classifier.',
placement = 'top', trigger = 'hover')
),
column(4,
h4('zROC'),
plotOutput("zrocPlot"),
bsPopover("zrocPlot", title = 'Z-ROC',
content = 'This is a zROC plot',
placement = 'top', trigger = 'hover')
)
),
# Text for AUC
fluidRow(
column(12,
br(),
br(),
verbatimTextOutput("AUC")
)
)
),
######################################## Tab 3 #########################################
tabPanel("NHST and the Base rate fallacy", value = "C",
br(),
fluidRow(
column(12,
p("Now lets consider what happens if the base rate changes, in our case if our person moves to a sunnier place but expects the same ammount of rain.
In the previous example we have made an assumption that the base rate is at chance level,
that is the chances of rain or sun are 50%.
This is an important thing to consider as base rates can have a significant effect on the possibility of getting pneumonia and/or unnecessarily carrying a heavy umbrella.
In the more general example of hypothesis testing the effect of base rates on d' is further
exaccerbated by the fact that base rates are very rarely known and rely on assumptions."))
),
br(),
br(),
br(),
p("For example, suppose the umbrella person is going out on 100 days.
Only ten of them are actually rainy, but you DO NOT know which. So he tries to guess it along.
To illustrate, each square in this grid represents a day, The blue squares are the
rainy days."),
#splitLayout(cellWidths = c("23%", "80%"),
fluidRow(
column(3,
sliderInput("base_rate",
"Base Rate",
min=1,
max=100,
value=10)),
column(6, plotOutput("WafflePlotBase"))),
p("He assumes a probability of rain
of 0.8.In the initial example of 10 rainy days he would have correctly brought his umbrella on 8 of them, as shown in red:"),
# splitLayout(cellWidths = c("23%", "80%", "40%"),
fluidRow(
column(3,
sliderInput("PowerBase",
"Specificity (1-Beta)",
min=0,
max=1,
value=0.8)),
column(6,plotOutput("WafflePlotPow"))),
p("Of the 90 sunny days, he will conclude that about on 4 it will rain. Why? Remember that p-values are
calculated under the assumption of no effect, so p=0.05 means a 5% chance of falsely concluding that it will
rain when it is actually sunny.So, our umbrella guy will perform hid experiments and conclude that there are 15 rainy days: 8 that
have indeed been rainy and he brought an umbrella, 2 days that he got soaked in because he didn't take the umbrella and 5 you have erroneously brought an umbrella, shown in green:"),
#splitLayout(cellWidths = c("23%", "80%"),
fluidRow(
column(3,
sliderInput("AlphaBase",
"1-Sensitivity (Alpha)",
min=0,
max=1,
value=0.05)),
column(6,
plotOutput("WafflePlotAlp")))
),
######################################## Tab 4 #########################################
tabPanel("Hypothesis Testing", value = "D",
br(),
h4("Hypothesis testing as Signal Detection"),
br(),
fluidRow(
column(12, p("In hypothesis testhing you can see that both 2x2 tables look simmilar to each other.
You can see that the all familiar alpha and beta errors now represent our
False Alarms and Misses that we have been working with so far. We have displayed the
formula for Sensitivity (also called Hitrate, or True Positive Rate) as well as
Specificity (also called Correct Reject Rate, or True Negative Rate) as a reminder."))),
fluidRow(
column(4, img(src = "SDT.png", align = "left")),
column(4, img(src = "NullHyp.png", align = "left")),
column(4, img(src = "formula.png", align = "left"))),
br(),
hr(),
br(),
fluidRow(column(12,
p("Now change the test sensitivity and power, to see how
your error rates - alpha and beta, change with them."))),
br(),
#splitLayout(
fluidRow(
column(6,
verticalLayout(
fluidRow(
column(12,
sliderInput("type1", "Sensitivity", min=0, max = 1, value = 0.95, step = 0.05),
sliderInput("power", "1-Beta (Power)", min=0, max = 1, value = 0.9, step = 0.05))))),
column(6,
fluidRow(
column(6,
h4("Hypothesis testing values."),
br(),
tableOutput("nhst"))))),
br(),
hr(),
br(),
h4("Influence of Base Rate"),
br(),
fluidRow(column(12,
p("So far we have seen how changing the sensitivity of our test changes how
our probability of a Type 1 error increases. Additionally,
we have seen that changing Power(Or our probability to detect and existing effect)
leads to changes in the chance of detecting an effect when it is there.
In signal detection terms, we have changed our Hit rate and our
Correct rejection rate.") ,
br(),
p("However, in reality we do not know what is the rate of one hypothesis against the other.
We do not know whether the null or the alternative hypothesis are more likely.
This is why when hypothesis testing we rely on power calculations from previous research
and we assume that our test should be highly sensitive in detecting an effect.")
)),
br(),
hr(),
br(),
p("In the previous example we have made an assumption that the base rate is at 50% - equal probability of each
hypothesis. However, when this assumption is violated it can lead to changes in your interpretations.
Lets see how assuming the Power of our test, but changing the Base Rate affects your alpha and beta, a.k.a.
your error rates."),
br(),
fluidRow(
column(6,
fluidRow(
column(12,
sliderInput("baserate1", "Base Rate", min=0, max = 0.5, value = 0.5, step = 0.001),
sliderInput("type11", "Sensitivity", min=0, max = 1, value = 0.95, step = 0.05))
)),
column(6,
fluidRow(
column(6,
h4("Hypothesis testing with changing base rate and assuming power."),
br(),
tableOutput("nhst.br.ci"))))),
br(),
p("You can now see that even by assuming the power of your test, i.e. your ability to detect an effect which is actually there
and setting it to 90, if we change the base rate, that changes your actual error rates.
In other terms just because we have a very powerful test, but a the ratio between the two
hypotheses is not equal, then your sensitivity to that effect will change and your alpha error,
or your Type I error will change. The same basically happens when you change your sensitivity level
but keep the base rate the same."),
br(),
hr(),
br(),
p("Now we are assuming that our test is highly sensitive i.e 95%, and our alpha is 0.05.
This time however we are going to vary Power and Base rate. The effect should be similar
to the previous one, but now what is changing is our probability of detecting an existing effect"),
br(),
fluidRow(
column(6,
fluidRow(
column(12,
sliderInput("baserate2", "Base Rate", min=0, max = 0.5, value = 0.5, step = 0.001),
sliderInput("type2", "Power", min=0, max = 1, value = 0.95, step = 0.05))
)),
column(6,
fluidRow(
column(6,
h4("Hypothesis testing with changing base rate, and assuming Sensitivity"),
br(),
tableOutput("nhst.br.power"))))),
br(),
p("You can see that even with a highly sensitive test, with only a 5% chance of incorrectly rejecting th Null hypothesis,
if your base rate changes the probability of detecting that effect also changes.")
),
######################################## Glossary #########################################
tabPanel("Glossary", value = "F",
fluidRow(
column(2,
h4("Sensitivity")),
column(10,
h4("Also called True Positive Rate, or Hitrate. In Nullhypothesis testing this would be equally to 1-alpha"))
)
)
)))
