# Pizza App
#
# Authors:
# Claudia Glemser, Tuebingen
# Umberto Granziol, Padua
# Stefanie Jauk, Graz
# Richard Naar, Tartu
# Holly Scott, Glasgow
# Wilhemiina Toivo, Glasgow
#
# A thank you to Eric-Jan Wagenmaker and Quentin Gronau for their contribution!
library(shiny)
library(plotrix)
ui <- fluidPage(
includeScript("../../../Matomo-tquant.js"),
titlePanel(
title = HTML(
"<center><h2><strong>
Prior odds, Bayes Factor and posterior odds </strong></h2>
<h4><em> Enter your prior observations and new
observations to see how the prior odds and Bayes Factor
combine to get the posterior odds </em></h4>
<h5><br><em>The null hypothesis (H0) states that
successes and failures occur at the same frequency
</em></h5></center>"),
windowTitle = "An extremely shiny app"
),
fluidRow( # successes and failures
column(2, offset = 2, align = "center",
numericInput("prior_a", "Prior successes",
value = 1, min = 1, max = 10000) ),
column(2, align = "center",
numericInput("prior_b", "Prior failures",
value = 1, min = 1, max = 10000) ),
column(2, offset = 1, align = "center",
numericInput("obs_a", "Observed successes",
value = 1, min = 1, max = 10000) ),
column(2, align = "center",
numericInput("obs_b", "Observed failures",
value = 1, min = 1, max = 10000) )
),
fluidRow(
column(2,
textOutput("text1"), br(),
textOutput("text2"), br(),
textOutput("text3"), br(),
tags$head(tags$style("#text1{color: darkblue;}
#text2{color: blue;}
#text3{color: darkred;}"
)
)
),
column(3, align = "center",
plotOutput("prior", width = "200px", height = "200px")
),
column(3, align = "center",
br(), br(), br(),
img(src = "Figure.png", width = "350px")
),
column(3, align = "center",
plotOutput("pizza", width = "200px", height = "200px")
)
),
fluidRow(
column(2,
textOutput("text4"), br(),
textOutput("text5"), br(),
textOutput("text6"),
tags$head(tags$style("#text4{color: red;}
#text5{color: purple;}
#text6{color: darkorchid;}"
)
)
),
column(9, align = "center",
plotOutput("plot3", width = "200px", height = "200px")
)
)
)
server <- function(input, output){
# prior plot
priorPlot <- function(ratio){
inv_ratio <- 1 / ratio
radius <- 0.4 ## centre coloured area
A <- radius^2 * pi
alpha <- 2 / (inv_ratio + 1) * A / radius^2
startpos <- pi / 2 - alpha/2
plot(1, axes = FALSE, ann = FALSE)
title(main = "Prior odds\n\n", xlab = "H0\n", font.lab = 1,
cex.lab = 1)
title(main = "\nH1\n", font.main = 1, cex.main = 1)
op <- par(xpd = TRUE)
floating.pie(1, 1, c(ratio, 1),
radius = radius,
col = c("darkblue", "blue"),
lwd = 2, startpos = startpos)
par(op)
}
BF_calc <- reactive({
p.a <- input$prior_a
p.b <- input$prior_b
o.a <- input$obs_a
o.b <- input$obs_b
para1 <- p.a + o.a
para2 <- p.b + o.b
model0 <- dbeta(.5, p.a, p.b)
model1 <- dbeta(.5, para1, para2)
bayes01 <- model1/model0
bayes10 <- model0/model1
bayes10
})
# create the plot output
output$prior <- renderPlot({
a <- 0.000001 + input$prior_a
b <- 0.000001 + input$prior_b
if ((a-b) == 0)
{priorPlot(ratio = 1)}
else
{priorPlot(ratio = a/b)}
})
# BF plot function
BFpizzaPlot <- function(BF10){
BF01 <- 1 / BF10
radius <- 0.4 ## centre coloured area
A <- radius^2 * pi
alpha <- 2 / (BF01 + 1) * A / radius^2
startpos <- pi / 2 - alpha/2
plot(1, axes = FALSE, ann = FALSE)
title(main = "Bayes factor\n\n", xlab = "H0\n", font.lab = 1,
cex.lab = 1)
title(main = "\nH1\n", font.main = 1, cex.main = 1)
op <- par(xpd = TRUE)
floating.pie(1, 1, c(BF10, 1),
radius = radius,
col = c("darkred", "red"),
lwd = 2, startpos = startpos)
par(op)
}
# create the plot output
output$pizza <- renderPlot({
if(input$obs_a != 0 | input$obs_b != 0)
{BFpizzaPlot(BF10 = BF_calc())}
})
# posterior plot
PosteriorPlot <- function(ratio2){
inv_ratio <- 1 / ratio2
radius <- 0.4 ## centre coloured area
A <- radius^2 * pi
alpha <- 2 / (inv_ratio + 1) * A / radius^2
startpos <- pi / 2 - alpha/2
plot(1, axes = FALSE, xlab = "", ylab = "") ## draw probability wheel
title(main = "Posterior odds\n\n", xlab = "H0\n", font.lab = 1,
cex.lab = 1)
title(main = "\nH1\n", font.main = 1, cex.main = 1)
op <- par(xpd = TRUE)
floating.pie(1, 1, c(ratio2, 1),
radius = radius,
col = c("purple4", "purple"),
lwd = 2, startpos = startpos)
par(op)
}
p_ratio <- reactive({
a <- 0.000001 + input$prior_a
b <- 0.000001 + input$prior_b
p_ratio <- a/b
p_ratio
})
output$plot3 <- renderPlot({
if(input$obs_a != 0 | input$obs_b != 0)
{PosteriorPlot(ratio2=(p_ratio()*BF_calc()))}
})
# Reactive text output
Priortext1 <- reactive(round(input$prior_a/
sum(input$prior_b + input$prior_a),
digits = 2))
Priortext2 <- reactive(round(input$prior_b/
(input$prior_a + input$prior_b),
digits = 2))
Bayestext1 <- reactive(round(BF_calc(), digits = 2))
Bayestext2 <- reactive(round(1/BF_calc(), digits = 2))
Post_text1 <- reactive(round(p_ratio()*BF_calc(), digits = 2))
Post_text2 <- reactive(round(1/(p_ratio()*BF_calc()), digits = 2))
# create text output
output$text1 <- renderText({
paste("These are your prior odds in favour of the alternative hypothesis
(H1):", Priortext1())
})
output$text2 <- renderText({
paste("These are your prior odds in favour of the null hypothesis
(H0):", Priortext2())
})
output$text3 <- renderText({
if(input$obs_a != 0 | input$obs_b != 0)
{paste("This is your Bayes Factor in favour of H1:",
Bayestext1())}
})
output$text4 <- renderText({
if(input$obs_a != 0 | input$obs_b != 0)
{paste("This is your Bayes Factor in favour of H0:",
Bayestext2())}
})
output$text5 <- renderText({
if(input$obs_a != 0 | input$obs_b != 0)
{paste("This is your posterior odds in favour of H1:",
Post_text1())}
})
output$text6 <- renderText({
if(input$obs_a != 0 | input$obs_b != 0)
{paste("This is your posterior odds in favour of H0:",
Post_text2())}
})
}
shinyApp(ui = ui, server = server)
# when prior & posteriors 0,0 -> BF & PO make sense?
# -> insert sth other than NaN for prior?
#
# insert formula as an img() (screenshot, cut and paste LaTeX output)
#
# make slides
