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}
)
}
```
stephanGit/leistungstests documentation built on June 13, 2018, 8:24 p.m.