inst/apps/VisualizeBinomHypTest/server/callbacks.R

In stephanGit/leistungstests: Supplies Functions to calculate 'leistungstests'

# set up app.env (accessible from functions in this script)
app.env <- new.env()

app.env$data.design <- data.frame(x=NA,y=NA)
app.env$dataCounter <- 0
app.env$go <- 0

visualizePropTest <- function(output, input){

  n <- input$n
  alpha <- input$alpha/100
  p0 <- input$p0/100
  pA <- input$pA/100
  meaningfull.diff <- pA-p0

  criticalValue <-
    tryCatch(
      {floor(
        uniroot(
          function(c){pbinom(c, size = n, prob = p0) - (1 - alpha)},
          interval = c(0, n)
          )$root
        )
      },
       error=function(e){return(0)}
      )

  binomProb <- union(
    mutate(# cdf and pdf for nullhyp
      data.frame(success = 0:n, hyp = factor("p0",levels=c("p0","pA"))),
      p = pbinom(q = success, size = n, prob = p0),
      d = dbinom(x = success, size = n, prob = p0)/max(dbinom(x = success, size = n, prob = p0))
    ),
    mutate(# cdf and pdf for alt-hyp
      data.frame(success = 0:n, hyp = factor("pA",levels=c("p0","pA"))),
      p = pbinom(q = success,size = n,prob = pA),
      d = dbinom(x = success,size = n,prob = pA)/max(dbinom(x = success, size = n, prob = pA))
    )
  )

  print(
    binomProb %>%
    ggplot(aes(x = success, y = d,color = hyp)) +
      expand_limits(y = 0) +

    geom_line(aes(y = p), linetype="dashed") + # cdf
    geom_line(aes(y = d)) + # pdf

    geom_vline(xintercept = criticalValue, color = "red") +
    annotate("text",
             x = criticalValue, y = min(0.95,2*max(binomProb$d)),
             color="red",
             label=paste("Krit. Wert:", criticalValue)) +

    scale_y_continuous(breaks = seq(0,1,0.05)) +

    xlim(min(subset(binomProb, d > 0.005)$success),
         max(subset(binomProb, d > 0.005)$success)) +

    scale_color_manual("Hypothesis",
                       values = c("darkgreen","blue"),
                       labels=c(paste("p0=",p0,"/E=",round(p0*n,1),sep=""),
                                paste("pA=",pA,"/E=",round(pA*n,1),sep=""))) +

    geom_ribbon(
      data = subset(binomProb, success <= criticalValue & hyp=="p0"),
      aes(x = success, ymin = 0, ymax = d),
      fill = "darkgreen",
      alpha = 0.2
      ) +
    annotate("text", color = "darkgreen",
             x = max(0+1, criticalValue - 1),
             y = dbinom(x = criticalValue, size = n, prob = p0),
             label=round(pbinom(q = criticalValue, size = n, prob = p0, lower.tail = TRUE)*100, 1)) +

    geom_ribbon(data=subset(binomProb,success>=criticalValue+1 & hyp=="pA"),aes(x=success,ymin=0,ymax=d),fill="blue",alpha=0.2) +
    annotate("text",color="blue",
             x=criticalValue+2,
             y=dbinom(x=criticalValue,size=n,prob=pA),
             label=round(pbinom(q=criticalValue,size=n,prob=pA,lower.tail = FALSE)*100,1)) +

    ggtitle(paste("Calculated Power\nwith binom.power: ",
                  round(binom.power(p=p0,p.alt=pA,n=n,alpha = alpha, alternative ="greater",method="exact")*100,
                        1),
                  "with pwr.p.test: ",
                  round(pwr.p.test(h=meaningfull.diff,sig.level=alpha, n=n, alternative = "greater")$power*100,
                        1),
                  "\n exact confint (binom.confint) for succes=",round(n*p0,1),"(=expactation under H0):",
                  "[",
                  round(binom.confint(x=round(n*p0),n=n,conf.level = 1-alpha,methods = "exact")$lower*n,1),
                  ",",
                  round(binom.confint(x=round(n*p0),n=n,conf.level = 1-alpha,methods = "exact")$upper*n,1),
                  "]")
            ) +
    theme(axis.title.y = element_blank())
  )
}

calcPowerTest <- function(output,input){
  p0 <- input$p0/100
  pA <- input$pA/100
  alpha <- input$alpha/100
  n <- input$n

  print(
    pwr.p.test(
      h = (pA - p0),
      sig.level = alpha,
      n = n,
      alternative = "greater")
  )

  print(
    binom.confint(
      x = max(0, (round(n * p0) - 2)):min(n, round(n * pA) + 2),
      n = n,
      conf.level = 1 - alpha,
      methods = c("exact", "asymptotic", "lrt")
      ),
      digits=c(2)
    )

  binom.power(
    p.alt = pA,
    p = p0,
    n = n,
    alpha = alpha,
    alternative = "greater",
    method="exact"
    )

}

updateAndDisplayData <- function(output,input){
   #browser()
  x <- input$x
  y <- input$y

  if (app.env$dataCounter==0) {
    app.env$df <- data.frame(x=x,y=y)
    app.env$dataCounter <- app.env$dataCounter + 1
  } else{
    app.env$df <- bind_rows(app.env$df,data.frame(x=x,y=y))
  }

  output$table <- renderTable({
    print(app.env$df)
  }, 'include.rownames' = FALSE
  , 'include.colnames' = TRUE
  , 'sanitize.text.function' = function(x){x}
  )
}