.packageName <- "smatr"

b.com.est <- function( z, n, method, lambda=1, res.df)
{
    zcom    <- t(z) %*% ( n - 1 )
    zlam    <- zcom
    iter    <- 100
    bi      <- matrix( 0, iter, 1 )
    bchange <- 1
    i       <- 1

    while ( abs(bchange) > 10^(-6) )
    {
        i  <- i+1;
        if ( i > 100 ) 
        {
            warning("no convergence!")
		i <- i-1 #so that i=100
            break
        }

        if ( (method==1) | (method=="SMA") )
        {
            bi[i] <- sign( zcom[3] )*sqrt( zcom[1]/zcom[2] )
            l1    <- ( bi[i]^2*z[,2] + 2*bi[i]*z[,3] + z[,1] )/2/abs(bi[i])
            l2    <- ( bi[i]^2*z[,2] - 2*bi[i]*z[,3] + z[,1] )/2/abs(bi[i])
            wts   <- n * (1/l2 + 1/l1)
            wts[n==1] <- 0 #to avoid errors with n==1
            zcom  <- t(z) %*% wts
        }
        else if ( (method==2) | (method=="MA") )
        {
            fac   <- zcom[1] - lambda*zcom[2]
            bi[i] <- ( fac + sqrt( fac^2 + 4*lambda*zcom[3]^2 ) ) /2/zcom[3]
            l1    <- ( lambda^2*z[,2] + 2*lambda*bi[i]*z[,3] + bi[i]^2*z[,1] ) / (lambda+bi[i]^2)
            l2    <- ( bi[i]^2*z[,2] - 2*bi[i]*z[,3] + z[,1] )/ ( lambda + bi[i]^2 )
            wts   <- n * (1/l2 - lambda/l1)
            wts[n==1] <- 0 #to avoid errors with n==1
            zcom  <- t(z) %*% wts
        }
        else if ( (method==3) | (method=="lamest") )
        {
            fac   <- zcom[1] - lambda*zcom[2]
    	      bi[i] <- ( fac + sqrt( fac^2 + 4*lambda*zcom[3]^2 ) ) /2/zcom[3]
            lambda<- abs( ( bi[i]^2*zlam[3] - bi[i]*zlam[1] ) / (zlam[3] - bi[i]*zlam[2]))
            l1    <- ( lambda^2*z[,2] + 2*lambda*bi[i]*z[,3] + bi[i]^2*z[,1] ) / (lambda+bi[i]^2)
            l2    <- ( bi[i]^2*z[,2] - 2*bi[i]*z[,3] + z[,1] )/ ( lambda + bi[i]^2 )
            wts   <- n * (1/l2 - lambda/l1)
            wts[n==1] <- 0 #to avoid errors with n==1
            zcom  <- t(z) %*% wts
            wtLam <- n / l1
            wtLam[n==1] <- 0 #to avoid errors with n==1
            zlam  <- t(z) %*% wtLam
        }
        else 
        {
            stop("No such method")
        }

        bchange <- bi[i] - bi[i-1]
        b       <- bi[i]
    }
    if ( (method==1) | (method=='SMA') ) { lambda <- b^2 }

    bi=bi[2:i] #ignoring first entry, which was 0.

    list( b=b, bi=bi, l1=l1, l2=l2, lambda=lambda )
}




com.ci <- function( b, varb, crit, z, n, l1, l2, method, lambda, res.df)
{
    b.ci <- c(NA,NA)
    arguments <- list( l1=l1, l2=l2, z=z, n=n, method=method, crit=crit, lambda=lambda, res.df=res.df )
    #check if limits have opposite sign
    val.b <- lr.b.com(b,arguments)
    b.m   <- b - 2*sqrt(crit*varb)
    b.p   <- b + 2*sqrt(crit*varb)
    val.m <- lr.b.com(b.m,arguments)
    val.p <- lr.b.com(b.p,arguments)
    #if necessary, move limits further from b (small sample issues)
    if ( val.m*val.b > 0 )
        {
         b.m <- b - 4*sqrt(crit*varb)
         val.m <- lr.b.com(b.m,arguments)
        }
    if ( val.p*val.b > 0 )
        {
         b.p <- b + 4*sqrt(crit*varb)
         val.p <- lr.b.com(b.p,arguments)
        }
    #if still problems, move further and adjust for possibly 0 variance
    if ( val.m*val.b > 0 )
        {
         b.m <- b - 8*sqrt(crit*(varb+0.1))
         val.m <- lr.b.com(b.m,arguments)
        }
    if ( val.p*val.b > 0 )
        {
         b.p <- b + 8*sqrt(crit*(varb+0.1))
         val.p <- lr.b.com(b.p,arguments)
        }
    res <- uniroot( lr.b.com, c(b.m, b ), tol = 0.0001, arguments=arguments )
    b.ci[1] <- res$root
    res <- uniroot( lr.b.com, c(b , b.p ), tol = 0.0001, arguments=arguments )
    b.ci[2] <- res$root

    if ( b.ci[1]==b.ci[2] )
    {
        str("Same limits - unable to find a different solution!?")
    }
    b.ci
}

elev.com <- function( y, x, groups, data=NULL, method="SMA", alpha=0.05, V=array( 0, c( 2,2,length(unique(groups)) ) ), group.names=sort(unique(groups)) )
{
    if ( is.null(data)==FALSE )
    {
        attach(data)
    }

    x      <- as.matrix( x )
    y      <- as.matrix( y )
    groups <- as.matrix( groups )

    nobs <- length( groups )
    g    <- length( group.names )

    res  <- slope.com( y, x, groups, method=method, V=V, bs=FALSE, ci=FALSE )
    lr   <- res$lr
    p    <- res$p
    b    <- res$b
    varb <- res$varb

    n      <- matrix( 0, g, 1 )
    varres <- matrix( 0, g, 1 )
    means  <- matrix( 0, g, 2 )
    res    <- y - b*x

    for ( i in 1:g )
    {
        iref       <- ( groups==group.names[i] )
        iref       <- iref & ( is.na(x+y) == FALSE )
        n[i]       <- sum( iref )
        means[i,1] <- mean( y[iref] ) 
        means[i,2] <- mean( x[iref] )
        varres[i]  <- ( var( res[iref] ) - V[1,1,i] - b^2*V[2,2,i] )
    }
    varres <- varres *( n - 1 )/( n - 2 )

    as     <- means[,1] - b*means[,2]
    names(as) <- group.names
    varas  <- diag( array( varres/n ) ) + varb*means[,2]%*%t( means[,2] )
    varas[n==1,] <- 0 #For singleton groups
    varas[,n==1] <- 0
    df     <- g - 1 - sum(n==1)
    L      <- matrix(0,df,g)
    L[,n>1] <- cbind( matrix( 1, df, 1), diag( array( -1, df), nrow=df ) )
    
    stat   <- t(L%*%as)%*%( solve( L%*%varas%*%t(L) ) )%*%(L%*%as)
    pvalue <- 1 - pchisq( stat, df ) # remove during sims
    sinv=matrix(0,g,g)
    sinv[n>1,n>1]   <- solve( varas[n>1,n>1] )
    a      <- (matrix(1,1,g)%*%sinv%*%as)/ sum( sum( sinv) )
    vara   <- 1 / sum( sum( sinv ) )
    crit   <- qchisq( 1 - alpha, 1 )
    a.ci   <- c( a - sqrt( crit*vara), a + sqrt( crit*vara ) )

    if ( is.null(data)==FALSE )
    {
        detach(data)
    }

    list( stat=stat, p=pvalue , a=a, ci=a.ci, as=as )
}

elev.test <- function( y, x, test.value=0, data=NULL, alpha=0.05, method="SMA", V=matrix(0,2,2) )
{
    if ( is.null(data)==FALSE )
    {
        attach(data)
    }

    iref <- ( is.na(x+y) == FALSE ) #to remove NA cases
    n    <- sum(iref)
    res.df <- n - 2
    fcrit  <- qf( 1-alpha, 1, res.df )
    dat    <- cbind( y[iref], x[iref] )
    vr     <- ( var( dat ) - V )*( n - 1 )
    r      <- vr[1,2]/( ( vr[1,1]*vr[2,2] )^0.5 )

    if ( (method==0) | (method=="OLS") )
    {
        b       <- vr[1,2] / vr[2,2]
        var.res <- ( vr[1,1] - 2*b*vr[1,2] + b^2*vr[2,2] ) / res.df
        var.b   <- var.res / vr[2,2]
    }
    else if ( (method==1) | (method=="SMA") )
    {
        b       <- sign( vr[1,2] )*sqrt( vr[1,1] / vr[2,2] )
        var.res <- ( vr[1,1] - 2*b*vr[1,2] + b^2*vr[2,2] ) / res.df
        var.b   <- ( vr[1,1] - (vr[1,2]^2)/vr[2,2] ) / res.df / vr[2,2]
    }
    else if ( (method==2) | (method=="MA") )
    {
        fac     <- vr[1,1] - vr[2,2]
        b       <- ( fac + sqrt( fac^2 + 4*vr[1,2]^2) ) / 2 / vr[1,2]
        var.res <- ( vr[1,1] - 2*b*vr[1,2] + b^2*vr[2,2] ) / res.df
        var.fit <- ( b^2*vr[1,1] + 2*b*vr[1,2] + vr[2,2] ) / res.df
        var.b   <- 1 / ( var.res/var.fit + var.fit/var.res - 2)*( 1 + b^2 )^2 / res.df    # Use Fisher info
    }

    means    <- apply(dat,2,mean)
    a        <- means[1] - b*means[2]
    var.a    <- var.res/n + var.b*means[2]^2
    t      <- (a - test.value)/sqrt(var.a)
    pvalue <- 2*pt( -abs(t), res.df )

    if ( is.null(data)==FALSE )
    {
        detach(data)
    }

    list( t=t, a=a, p=pvalue, a.ci=c( a-sqrt(var.a*fcrit), a+sqrt(var.a*fcrit) ), test.value=test.value )
}

line.cis <- function( y, x, alpha=0.05, data=NULL, method="SMA", intercept=TRUE, V=matrix(0,2,2), f.crit=0 )
{

    if ( is.null(data)==FALSE )
    {
        attach(data)
    }
    iref <- ( is.na(x+y) == FALSE ) #to remove NA cases
    n    <- sum(iref)

    # if the line is forced through the origin, df are n-1 not n-2
    if ( intercept == TRUE )
    {
        res.df <- n-2
    }
    else
    { 
        res.df <- n-1 
    }

    if ( f.crit==0 )
    {
        f.crit <- qf( 1 - alpha, 1, res.df )
    }

    dat  <- data.frame( y, x )
    datm <- as.matrix( dat[iref,] )
    #if the line is forced through the origin, SS are estimated without centring the data.
    if ( intercept == TRUE ) 
    {
        vr <- ( var(dat[iref,]) - V )*(n-1) 
    }
    else 
    {
        vr <- t(datm[iref,])%*%datm[iref,] - V*n
    }

    r   <- vr[1,2] / sqrt( vr[1,1]*vr[2,2] )
    cis <- matrix( 0, 2, 2)

    if ( (method==0) | (method=="OLS") )
    {
        lab      <- "coef(reg)"
        b        <- vr[1,2] / vr[2,2]
        var.res  <- ( vr[1,1] - 2*b*vr[1,2] + b^2*vr[2,2] ) / res.df
        var.b    <- var.res / vr[2,2]
        cis[2,1] <- b - sqrt(var.b)*sqrt(f.crit)
        cis[2,2] <- b + sqrt(var.b)*sqrt(f.crit)
    }
    if ( (method==1) | (method=="SMA") )
    {
        lab      <- "coef(SMA)"
        b        <- sign( vr[1,2] ) * sqrt( vr[1,1] / vr[2,2] )
        bigb     <- f.crit * ( 1 - r^2 ) / res.df
        cis[2,1] <- b*( sqrt(bigb+1) - sqrt(bigb) )
        cis[2,2] <- b*( sqrt(bigb+1) + sqrt(bigb) )
        var.res  <- ( vr[1,1] - 2*b*vr[1,2] + b^2*vr[2,2] ) / res.df
        var.b    <- ( vr[1,1] - vr[1,2]^2/vr[2,2] ) / res.df/vr[2,2]
    }
    if ( (method==2) | (method=="MA") )
    {
        lab      <- "coef(MA)"
        fac      <- vr[1,1] - vr[2,2]
        b        <- ( fac + sqrt( fac^2 + 4*vr[1,2]^2 ) ) / 2 / vr[1,2]
        q        <- f.crit*( vr[1,1]*vr[2,2] - vr[1,2]^2 ) / res.df
        cis[2,1] <- (fac + sqrt( fac^2 + 4*vr[1,2]^2 - 4*q ) ) / 2 / ( vr[1,2] + sqrt(q) )
        cis[2,2] <- (fac + sqrt( fac^2 + 4*vr[1,2]^2 - 4*q ) ) / 2 / ( vr[1,2] - sqrt(q) )
        if ( (fac^2 + 4*vr[1,2]^2 - 4*q ) < 0 )
        {
            cis[2,1] <- -Inf
            cis[2,2] <-  Inf
        }
        var.res  <- ( vr[1,1] - 2*b*vr[1,2] + b^2*vr[2,2] ) / res.df
        var.fit  <- ( b^2*vr[1,1] + 2*b*vr[1,2] + vr[2,2] ) / res.df
        var.b    <- 1 / ( var.res/var.fit + var.fit/var.res - 2 )*( 1 + b^2 )^2 / res.df    # Use Fisher info
    }

    if (intercept == TRUE)
    {
	  means    <- apply(datm,2,mean)
        a        <- means[1] - b*means[2]
	  var.a    <- var.res/n + var.b*means[2]^2
        cis[1,1] <- a - sqrt(var.a)*sqrt(f.crit)
        cis[1,2] <- a + sqrt(var.a)*sqrt(f.crit)
    }
    else
    {
        a        <- 0
        cis[1,]  <- NA
    }

    coeff           <- rbind( a, b )
    coef.names      <- c( "elevation", "slope" )
    coeff           <- data.frame( coeff, cis )
    names(coeff)    <- c( lab, "lower limit", "upper limit" )
    rownames(coeff) <- coef.names

    if ( is.null(data)==FALSE )
    {
        detach(data)
    }

    return(coeff)
}

lr.b.com <- function( b, arguments )
{
    
    l1     <- arguments$l1
    l2     <- arguments$l2
    z      <- arguments$z
    n      <- arguments$n
    method <- arguments$method
    crit   <- arguments$crit 
    lambda <- arguments$lambda
    res.df <- arguments$res.df 

    if ( (method==1) | (method=='SMA') )
    {
        if ( b==0 ) 
        {
            b <- 10^-6
        }
        l1b <- ( b^2*z[,2] + 2*b*z[,3] + z[,1] )/2/abs(b)
        l2b <- ( b^2*z[,2] - 2*b*z[,3] + z[,1] )/2/abs(b)

    }
    else if ( (method==2) | (method=="MA") | (method==3) | (method=="lamest") )
    {
        l1b <- ( lambda^2*z[,2] + 2*lambda*b*z[,3] + b^2*z[,1] )/( lambda + b^2 )
        l2b <- ( b^2*z[,2] - 2*b*z[,3] + z[,1] )/( lambda + b^2 )
    }

    lr <- sum( (res.df - 0.5)*log( l1b*l2b/l1/l2 ), na.rm=TRUE ) - crit
}


meas.est <- function( datameas, id, data=NULL )
{
    if ( nargs() != 2 )
    {
        stop("An id vector is required, to identify which subject each measurement belongs to.")
    }
    if ( is.null(data)==FALSE )
    {
        attach(data)
    }
    datameas <- as.matrix( datameas )
    siz <- dim( datameas )
    if ( length(id)!=siz[1] )
    {
        stop("The id vector must have the same number of rows as the data matrix")
    }

    idlabels <- sort( unique( id ) )
    n        <- length( idlabels )
    ni       <- matrix( 0, n, siz[2] )
    dat      <- matrix( NA, n, siz[2] )
    vrs      <- rep( NA, siz[2] * siz[2] * n )
    dim(vrs) <- c( siz[2], siz[2], n )

    is.OK    <- is.finite( apply( datameas , 1, sum ) ) #the rows with no nan's

    for ( i in 1:n )
    {
        ref      <- id==idlabels[i] & is.OK
        ni[i]    <- sum( as.numeric(ref) )
        dat[i,]  <- apply( as.matrix( datameas[ ref, ] ), 2, mean )
        if ( ni[i] > 1 )
            { vrs[, , i] <- var( datameas[ ref, ] ) / ni[i] }
    }

    V <- apply(vrs, 1:2, mean, na.rm=TRUE)

    if ( is.null(data)==FALSE )
    {
       detach(data)
    }

    list( V=V, dat.mean=dat )
}

shift.com <- function( y, x, groups, data=NULL, method="SMA", intercept=TRUE,  V=array( 0, c( 2,2,length(unique(groups)) ) ), group.names=sort(unique(groups)) )
{
    if ( is.null(data)==FALSE )
    {
        attach(data)
    }

    y <- as.matrix(y)
    x <- as.matrix(x)
    groups <- as.matrix(groups)

    nobs <- length(groups)
    g    <- length(group.names)
    inter<- intercept

    res  <- slope.com( y, x, groups, method, intercept=inter, V=V, ci=FALSE, bs=FALSE )
    lr   <- res$lr
    p    <- res$p
    b    <- res$b
    varb <- res$varb

    n        <- matrix( 0, g, 1 )
    varAxis  <- n
    as       <- n
    means    <- matrix( 0, g, 2 )

    if ( (method=="SMA") | method==1 )
    {
        axis       <- y + b*x
        coefV1     <- 1 #The coef of V[1,1,:] in var(axis).
        coefV2     <- b^2 #The coef of V[2,2,:] in var(axis).
        mean.ref   <- 2 #Ref for the column of means to use as coef of var(b)
    }
    if ( (method=="MA") | method==2 )
    {
        axis       <- b*y + x
        coefV1     <- b^2 #The coef of V[1,1,:] in var(axis).
        coefV2     <- 1
        mean.ref   <- 1 #Ref for the column of means to use as coef of var(b)
    }
 
    for ( i in 1:g )
    {
        iref       <- ( groups==group.names[i] )
        iref       <- iref & ( is.na(x+y) == FALSE )
        n[i]       <- sum( iref )
        means[i,1] <- mean( y[iref] ) 
        means[i,2] <- mean( x[iref] )
        as[i]      <- mean( axis[iref] )
        varAxis[i] <- var( axis[iref] )
    }
    varAxis    <- varAxis - coefV1*V[1,1,] - coefV2*V[2,2,]
    varAxis    <- varAxis * (n-1) / (n-2)
    mean.for.b <- means[,mean.ref]

    varAs <- diag( array(varAxis/n) ) + varb*mean.for.b%*%t(mean.for.b)
    varAs[n==1,] <- 0 #For singleton groups
    varAs[,n==1] <- 0
    df     <- g - 1 - sum(n==1)
    L      <- matrix(0,df,g)
    L[,n>1] <- cbind( matrix( 1, df, 1), diag( array( -1, df), nrow=df ) )
    stat  <- t(L%*%as)%*%solve(L%*%varAs%*%t(L), tol=1.0e-050 )%*%(L%*%as)

    pvalue <- 1 - pchisq( stat, df )

    if ( is.null(data)==FALSE )
    {
        detach(data)
    }

    list( stat=stat, p=pvalue, f.mean=as.vector(as) )

}

slope.com <- function( y, x, groups, method="SMA", alpha=0.05, data=NULL, intercept=TRUE, V=array( 0, c( 2,2,length(unique(groups)) ) ), group.names=sort(unique(groups)), ci=TRUE, bs=TRUE )
{
    if ( nargs() < 3 )
    {
        stop('Sorry, no can do without three arguments -- Y, X, GROUPS')
    }

    if ( is.null(data)==FALSE )
    {
        attach(data)
    }

    dat    <- cbind(y, x)
    g      <- length(group.names)

    # Find sample size, variances for each group:
    n      <- matrix( 0, g, 1 )
    res.df <- matrix( 0, g, 1 )
    z      <- matrix( 0, g, 3 )
    do.bs  <- bs
    bs     <- matrix( NA, 3, g, dimnames=list(c("slope","lower.CI.lim","upper.CI.lim"),group.names) )
    for (i in 1:g)
    {
        iref   <- ( groups==group.names[i] )
        iref   <- iref & ( is.na(x+y) == FALSE )
        n[i]   <- sum(iref)
        if ( intercept==FALSE )
        {
           xi <- t(dat[iref, ]) %*% dat[iref, ] / n[i] - V[, , i]
        }
        else 
        {
           if (n[i]>1)
               { xi <- cov(dat[iref, ]) - V[, , i] }
           else if (n[i]==1)
               { xi <- matrix(0,2,2) } #leave as zero for n[i]=1
        }
        z[i,]     <- c( xi[1,1], xi[2,2], xi[1,2] )
        if (do.bs==TRUE & n[i]>1)
            {
            slopei    <- slope.test(y[iref],x[iref],method=method, alpha=alpha, V=V[,,i], intercept=intercept )
            bs[,i]    <- c(slopei$b, slopei$ci)
            }
    }
    if (intercept==FALSE)
        { res.df <- n-1 }
    else
        { res.df <- n-2 }

    if ( is.null(data)==FALSE )
    {
        detach(data)
    }

    # Find common slope:
    lambda <- 1 #only actually used for the major axis.
    res    <- b.com.est( z, n, method, lambda, res.df=res.df )

    # Calculate LR:
    dets <- z[,1]*z[,2] - z[,3]^2 #This is l1*l2 under Halt.
    arguments <- list( l1=dets, l2=1, z=z, n=n, method=method, crit=0, lambda=lambda, res.df=res.df)
    LR     <- lr.b.com(res$b, arguments) 
    # if lambda is being estimated, check endpoint LR values:
    if ( (method==3) | ( method=='lamest' ) )
    {
        res0     <- b.com.est( z, n, 2, lambda=10^-9, res.df ) # to find est when lambda=0
        arguments <- list( l1=dets, l2=1, z=z, n=n, method=method, crit=0, lambda=10^-9, res.df=res.df)
        LR0      <- lr.b.com(res0$b, arguments) 
        resInf   <- b.com.est( z, n, 2, 10^9, res.df ) # to find est when lambda=inf
        arguments <- list( l1=dets, l2=1, z=z, n=n, method=method, crit=0, lambda=10^9, res.df=res.df)
        LRinf    <- lr.b.com(resInf$b, arguments) 
        LR       <- min(LR,LR0,LRinf)
        if ( LR==LR0 )    { res <- res0 }
        if ( LR==LRinf )  { res <- resInf }
    }
    
    # Record values for arguments separately
    b      <- res$b
    bi     <- res$bi
    l1     <- res$l1
    l2     <- res$l2
    lambda <- res$lambda

    # Calculate P-value:
    Pvalue <- 1 - pchisq( LR, g - 1 - sum(n==1) ) #don't count any singleton groups in df

    # Calculate a CI for common slope
    if ( (method==1) | (method=='SMA') )
    {
       # Getting variance of common slope
       varBs <- ( z[,1] - (z[,3]^2)/z[,2] ) / z[,2]
       varBs <- varBs / res.df
    } else
    if ( (method==2) | (method=='MA') )
    {
       varBs <- 1 / ( l2/l1 + l1/l2 - 2)*( lambda + b^2)^2
       varBs <- varBs / res.df
    }
    if ( (method==3) | (method=='lamest') )
    #Still work to be done to calculate CI for lamest.
    {
       varBs <- NA
    }
    varB <- 1 / sum( 1 / varBs, na.rm=TRUE )

    crit <- qchisq( 1 - alpha, 1 )
    if ( (method==3) | (method=='lamest') )
    {
       ci = FALSE
    }
    bCI=NA
    if ( ci == TRUE )
    {
       bCI  <- com.ci( b, varB, crit, z, n, l1, l2, method, lambda, res.df )
    }
    if (lambda==10^-9) { lambda=0 }
    if (lambda==10^9) { lambda=Inf }
    list( LR=LR, p=Pvalue, b=b, ci=bCI, varb=varB, lambda=lambda, bs=bs )
}


slope.test <- function( y, x, test.value=1, data=NULL, method="SMA", alpha=0.05, V=matrix(0,2,2), intercept=TRUE )
{

    if ( nargs() < 2 ) 
    {
        stop('Sorry, no can do without two arguments -- Y, X')
    }

    if ( is.null(data)==FALSE )
    {
        attach(data)
    }

    iref <- ( is.na(x+y) == FALSE ) #to remove NA cases
    n    <- sum(iref)

    if ( intercept==FALSE )
    {
        resDF <- n - 1 
    }
    else 
    {
        resDF <- n - 2
    }

    fCrit <- qf( 1-alpha, 1, resDF )

    dat <- cbind(y[iref], x[iref])
    if ( intercept==FALSE )
    {
        vr <- t(dat)%*%dat - V*n
    }
    else
    {
        vr <- ( cov(dat) - V )*(n-1)
    }
    r <- vr[1,2]/sqrt( vr[1,1]*vr[2,2] )

    bCI     <- matrix( NA, 1, 2 )
    varTest <- matrix( 0, 2, 2 )

    if ( (method==0) | (method=='OLS') )
    {
        b            <- vr[1,2]/vr[2,2]
        varRes       <- ( vr[1,1] - 2*b*vr[1,2] + b^2*vr[2,2] )/resDF
        varB         <- varRes/vr[2,2]
        bCI[1,1]     <- b - sqrt(varB)*sqrt(fCrit)
        bCI[1,2]     <- b + sqrt(varB)*sqrt(fCrit)
        varTest[1,1] <- vr[1,1] - 2*test.value*vr[1,2] + test.value^2*vr[2,2]
        varTest[1,2] <- vr[1,2] - test.value*vr[2,2]
        varTest[2,2] <- vr[2,2]
    }
    else if ( (method==1) | (method=='SMA') )
    {
        b            <- sign(vr[1,2])*sqrt(vr[1,1]/vr[2,2])
        B            <- fCrit*( 1 - r^2 )/resDF
        bCI[1,1]     <- b*( sqrt(B+1) - sqrt(B) )
        bCI[1,2]     <- b*( sqrt(B+1) + sqrt(B) )
        varTest[1,1] <- vr[1,1] - 2*test.value*vr[1,2] + test.value^2*vr[2,2]
        varTest[1,2] <- vr[1,1] - test.value^2*vr[2,2]
        varTest[2,2] <- vr[1,1] + 2*test.value*vr[1,2] + test.value^2*vr[2,2]
    }
    else if ( (method==2) | (method=='MA') )
    {
        fac          <- vr[1,1] - vr[2,2]
        b            <- ( fac + sqrt( fac^2 + 4*vr[1,2]^2) )/2/vr[1,2]
        Q            <- fCrit*( vr[1,1]*vr[2,2] - vr[1,2]^2 )/resDF
        bCI[1,1]     <- ( fac + sqrt( fac^2 + 4*vr[1,2]^2 - 4*Q) )/2/( vr[1,2] + sqrt(Q))
        bCI[1,2]     <- ( fac + sqrt( fac^2 + 4*vr[1,2]^2 - 4*Q) )/2/( vr[1,2] - sqrt(Q))
        if ( ( fac^2 + 4*vr[1,2]^2 - 4*Q) < 0 ) 
        {
            bCI[1,1] <- -Inf
            bCI[1,2] <-  Inf
        }
        varTest[1,1] <- vr[1,1] - 2*test.value*vr[1,2] + test.value^2*vr[2,2]
        varTest[1,2] <- -test.value^2*vr[1,2] + test.value*( vr[1,1] - vr[2,2] ) + vr[1,2]
        varTest[2,2] <- test.value^2*vr[1,1] + 2*test.value*vr[1,2] + vr[2,2]
    }
    else if ( (method==3) | (method=='lamest') )
    {   b=NA
        bCI[1,1:2]   <- NA
    }

     rTest  <- varTest[1,2] / sqrt( varTest[1,1] ) / sqrt( varTest[2,2] )
     F      <- rTest^2/(1 - rTest^2)*(n-2)
     pValue <- 1 - pf( F, 1, resDF)

     if ( is.null(data)==FALSE )
     {
        detach(data)
     }

     list( r=rTest, p=pValue, test.value=test.value, b=b, ci=bCI )

}
