#This code is designed to calculate optimal alpha levels for regression and correlation tests (two-tailed only), authored by Joe Mudge (joe.mudge@unb.ca).
#The function used to calculate optimal alphas is: optab.r(n=NULL,r=NULL,T1T2cratio=1,HaHopratio=1)
#The argument 'n'is the sample size
#The argument 'r' is the critical effect size in terms of a correlation coefficient. 
#The argument 'T1T2cratio' is the cost ratio of Type I errors relative to Type II errors. T1T2cratio is set at 1 as a default, making Type I and Type II errors equally serious.
#The argument 'HaHopratio' is the prior probability of the alternate hypothesis relative to the prior probability of the null hypothesis.  HaHopratio is set at 1 as a default, to not weight alpha and beta by their prior probabilities (assuming they are unknown).
#This code is partially based on code modified from the R package 'pwr'(Champely 2009)


beta.r.test<- function (n = NULL, r = NULL, sig.level = 0.05, power = NULL) 
{
    if (sum(sapply(list(n, r, power, sig.level), is.null)) != 
        1) 
        stop("exactly one of n, r, power, and sig.level must be NULL")
    if (!is.null(sig.level) && !is.numeric(sig.level) || any(0 > 
        sig.level | sig.level > 1)) 
        stop(sQuote("sig.level"), " must be numeric in [0, 1]")
    if (!is.null(power) && !is.numeric(power) || any(0 > power | 
        power > 1)) 
        stop(sQuote("power"), " must be numeric in [0, 1]")
    if (!is.null(n) && n < 4) 
        stop("number of observations must be at least 4")
   
        r <- abs(r)
      
        p.body <- quote({
            ttt <- qt(sig.level/2, df = n - 2, lower = FALSE)
            rc <- sqrt(ttt^2/(ttt^2 + n - 2))
            zr <- atanh(r) + r/(2 * (n - 1))
            zrc <- atanh(rc) + rc/(2 * (n - 1))
            pnorm((zr - zrc) * sqrt(n - 3)) + pnorm((-zr - zrc) * 
                sqrt(n - 3))
        })
    
    if (is.null(power)) 
        power <- eval(p.body)
    else if (is.null(n)) 
        n <- uniroot(function(n) eval(p.body) - power, c(4 + 
            1e-10, 1e+07))$root
    else if (is.null(r)) {
        if (tside == 2) {
            r <- uniroot(function(r) eval(p.body) - power, c(1e-10, 
                1 - 1e-10))$root
        }
        else {
            r <- uniroot(function(r) eval(p.body) - power, c(-1 + 
                1e-10, 1 - 1e-10))$root
        }
    }
    else if (is.null(sig.level)) 
        sig.level <- uniroot(function(sig.level) eval(p.body) - 
            power, c(1e-10, 1 - 1e-10))$root
    else stop("internal error")
    METHOD <- "approximate correlation power calculation (arctangh transformation)"
    1-power
}

w.average.error.r<-function (alpha=NULL,n=NULL,r=NULL,T1T2cratio=1,HaHopratio=1) ((alpha*T1T2cratio+HaHopratio*(beta.r.test(n=n,r=r,sig.level=alpha))))/(HaHopratio+T1T2cratio)

optimize.average.error<-function (f, interval, ..., lower = min(interval), upper = max(interval), 
    maximum = FALSE, tol = .Machine$double.eps^0.25) 
{
    if (maximum) {
        val <- .Internal(fmin(function(arg) -f(arg, ...), lower, 
            upper, tol))
        list(maximum = val, objective = f(val, ...))
    }
    else {
        val <- .Internal(fmin(function(arg) f(arg, ...), lower, 
            upper, tol))
        f(val, ...)
}
}

min.average.error.r<-function (n=NULL,r=NULL,T1T2cratio=1,HaHopratio=1) optimize.average.error(w.average.error.r,c(0,1),tol=0.000000000001,n=n,r=r,T1T2cratio=T1T2cratio,HaHopratio=HaHopratio)

optimize.alpha<-function (f, interval, ..., lower = min(interval), upper = max(interval), 
    maximum = FALSE, tol = .Machine$double.eps^0.25) 
{
    if (maximum) {
        val <- .Internal(fmin(function(arg) -f(arg, ...), lower, 
            upper, tol))
        list(maximum = val, objective = f(val, ...))
    }
    else {
        val <- .Internal(fmin(function(arg) f(arg, ...), lower, 
            upper, tol))
        val
}
}

alpha.r<-function (n=NULL,r=NULL,T1T2cratio=1,HaHopratio=1) optimize.alpha(w.average.error.r,c(0,1),tol=0.000000000001,n=n,r=r,T1T2cratio=T1T2cratio,HaHopratio=HaHopratio)

beta.r<-function (n=NULL,r=NULL,T1T2cratio=1,HaHopratio=1) ((T1T2cratio+HaHopratio)*min.average.error.r(n=n,r=r,T1T2cratio=T1T2cratio,HaHopratio=HaHopratio)-T1T2cratio*alpha.r(n=n,r=r,T1T2cratio=T1T2cratio,HaHopratio=HaHopratio))/HaHopratio

optab.r<-function (n=NULL,r=NULL,T1T2cratio=1,HaHopratio=1) {
           list(                                 
"output"=t(data.frame("sample size"=n,"critical correlation coefficient effect size"=r,"Type I/II error cost ratio"=T1T2cratio,"Ha/Ho prior probability ratio"=HaHopratio,"average of alpha and beta"=(alpha.r(n=n,r=r,T1T2cratio=T1T2cratio,HaHopratio=HaHopratio)+HaHopratio*beta.r(n=n,r=r,T1T2cratio=T1T2cratio,HaHopratio=HaHopratio))/(1+HaHopratio),"cost-weighted average of alpha and beta"=min.average.error.r(n=n,r=r,T1T2cratio=T1T2cratio,HaHopratio=HaHopratio),  
        "optimal alpha"=alpha.r(n=n,r=r,T1T2cratio=T1T2cratio,HaHopratio=HaHopratio),"optimal beta"=beta.r(n=n,r=r,T1T2cratio=T1T2cratio,HaHopratio=HaHopratio),row.names="values"))
)}



#This code is designed to calculate optimal alpha levels for regression and correlation tests (two-tailed only), authored by Joe Mudge (joe.mudge@unb.ca).
#The function used to calculate optimal alphas is: optab.r(n=NULL,r=NULL,T1T2cratio=1,HaHopratio=1)
#The argument 'n'is the sample size
#The argument 'r' is the critical effect size in terms of a correlation coefficient. 
#The argument 'T1T2cratio' is the cost ratio of Type I errors relative to Type II errors. T1T2cratio is set at 1 as a default, making Type I and Type II errors equally serious.
#The argument 'HaHopratio' is the prior probability of the alternate hypothesis relative to the prior probability of the null hypothesis.  HaHopratio is set at 1 as a default, to not weight alpha and beta by their prior probabilities (assuming they are unknown).
#This code is partially based on code modified from the R package 'pwr'(Champely 2009)