.packageName <- "RLRsim"
`LRTSim` <-
function(X,Z,q,sqrt.Sigma, seed=NA, nsim=5000,
                       log.grid.hi=8, log.grid.lo=-10, gridlength=200)
{
K<-NCOL(Z)     # no. of random effects
n<-NROW(X)     # no. of obs
p<-NCOL(X)     # no of fixed effects

#compute eigenvalues
mu<- (svd(sqrt.Sigma%*%t(qr.resid(qr(X), Z)), nu = 0, nv = 0)$d)^2
ksi<-(svd(sqrt.Sigma%*%t(Z),nu=0,nv=0)$d)^2

#norm eigenvalues
mu<-mu/max(mu)
ksi<-ksi/max(ksi)


#generate random samples
if(!is.na(seed)) set.seed(seed)
w.k.sq.mat<-matrix(rchisq(nsim*K,1),nrow=K)  #K*nsim matrix of ChiSq(1)
w.sum2<-rchisq(nsim,n-p-K)                   #1*nsim vector of ChiSq(n-p-K)
w.sum<-colSums(w.k.sq.mat)+w.sum2            #1*nsim of ChiSq(n-p)
u<-ifelse(rep(q,nsim)==0,rep(0,nsim),rchisq(nsim,q))   #1*nsim of ChiSq(q)

f.lambdafix.vec<-function(lambda,mu.w,w.k.sq.mat,w.sum2,mu,ksi,n,p)
#vectorized version: lambda as scalar
{
     num<-  colSums((lambda*mu.w)/(1+lambda*mu) )
     den<-  colSums( w.k.sq.mat / (1+lambda*mu) ) + t(w.sum2)
     return( n*log( 1+ (num/den) ) - sum(log(1+lambda*ksi)))
}

    #matrix (K*nsim) (mu_i*w_ij) i=1:K, j=1:nsim
    mu.w<-mu*w.k.sq.mat
    
    lambda.grid    <-c(0,exp(seq(log.grid.lo,log.grid.hi,length=gridlength-1)))
    lrt.array     <-sapply(lambda.grid,f.lambdafix.vec,mu.w,w.k.sq.mat,w.sum2,mu,ksi,n,p) + n*log(1+(u/w.sum)) #grid.length * nsim
    max.index.lrt.array  <-apply(lrt.array,1,which.max) #column-indices of rowmaxima
    lrt.max       <-lrt.array[cbind(1:nsim,max.index.lrt.array)]
    lambda.max     <-lambda.grid[max.index.lrt.array]
    res            <-as.data.frame(cbind(lambda.max,lrt.max))

    colnames(res)<-c("lambda","lrt")

#calculate p-value
return(res)
}#end LRT1Sim

`RLRTSim` <-
function(X,Z,sqrt.Sigma,lambda0=NA, seed= NA, nsim=5000, use.approx=0,
                   log.grid.hi=8, log.grid.lo=-10, gridlength=200)
{
if(is.na(lambda0)) lambda0<-0
#checking args:
if(!is.numeric(lambda0)|(lambda0<0)|length(lambda0)!=1) stop("Invalid lambda0 specified. \n")
if(lambda0>exp(log.grid.hi))
  {
    log.grid.hi<-log(10*lambda0)
    warning("lambda0 smaller than upper end of grid: \n Setting log.grid.hi to ln(10*lambda0).\n",immediate.=T)
  }
if((lambda0!=0)&&(lambda0<exp(log.grid.lo)))
  {
    log.grid.lo<-log(-10*lambda0)
    warning("lambda0 > 0 and larger than lower end of grid: \n Setting log.grid.lo to ln(-10*lambda0).\n",immediate.=T)
  }

n<-NROW(X)     # no. of obs
p<-NCOL(X)     # no. of fixed effects
K<-min(n,NCOL(Z))     # no. of non-zero eigenvalues

if(any(is.na(sqrt.Sigma))) sqrt.Sigma<-diag(NCOL(Z))

mu<-(svd(sqrt.Sigma%*%t(qr.resid(qr(X), Z)), nu = 0, nv = 0)$d)^2 #s. Mail D. Bates, 21.7.06

#normalize
mu<-mu/max(mu)

if(!is.na(seed))set.seed(seed)

if(use.approx) #should approximations be used
{
  #eigenvalue pattern of balanced ANOVA: mu_s=const for s=1,..,K-1, mu_K approx. 0 
  if((length(unique(round(mu,6)))==2)&(1000*mu[K]<mu[1]))                                                                    
  {
     cat("using simplified distribution for balanced ANOVA \n")
     approx.constantmu<-function(nsim,n,p,K,mu)
      #simplified distribution for balanced ANOVA:
      #mu_s=const for s=1,..,K-1 and mu_K=0
      {
        w.K<-rchisq(nsim,(K-1))
        w.n<-rchisq(nsim,(n-p-K+1))
        lambda<-pmax(rep(0,nsim), ((((n-p-K+1)/(K-1))*w.K/w.n -1)/mu[1]) )
        rlrt<-rep(0,nsim)
        rlrt[lambda!=0]= ((n-p)*log((w.K+w.n)/(n-p)) -(n-p-K+1)*log(w.n/(n-p-K+1)) - (K-1)*log(w.K/(K-1)) )[lambda!=0]
        return(cbind(lambda,rlrt))
      }
     res<-approx.constantmu(nsim,n,p,K,mu) #see below
     return(res)
  }
    
  #eigenvalue pattern for P-splines: exponential decrease
  if(mu[1]/sum(mu) > use.approx)
  {
    cat("using simplified distribution for 1 single dominating eigenvalue \n")
    approx.scalarmu<-function(nsim,n,p,K,mu)
    #simplified distribution for B-splines:
    #mu_1 >>> mu_s for s=2,..,K
    {
      mu<-mu[1]
      w.1<-rchisq(nsim,1)
      w.n<-rchisq(nsim,(n-p-1))
      lambda<-pmax(rep(0,nsim), ((((n-p-1)*w.1)/w.n)-1)/mu )
      rlrt<-rep(0,nsim)
      rlrt[lambda!=0]=log( ((w.1+w.n)/(n-p))^(n-p) / (w.1*(w.n/(n-p-1))^(n-p-1)) )[lambda!=0]
      return(cbind(lambda,rlrt))
    }
    res<-approx.scalarmu(nsim,n,p,K,mu)
    return(res)
  }

  #use only first k elements of mu, adapt K<-k accordingly
  #how many eigenvalues are needed to represent at least approx.ratio of the sum of all eigenvalues  (at least 1, of course)
  new.K<- max(sum((cumsum(mu)/sum(mu))< use.approx), 1)
  if(new.K<K) cat(paste("Approximation used:",new.K, "biggest eigenvalues instead of",K,"\n"))  
  mu<-mu[1:new.K]
  K<-new.K
}#end if(use.approx)

#generate random samples
w.k.sq.mat<-matrix(rchisq(nsim*K,1),nrow=K)  #K*nsim matrix of ChiSq(1)
w.sum2<-try(rchisq(nsim,n-p-K),sil=TRUE)                   #1*nsim vector of ChiSq(n-p-K)
if(class(w.sum2)=="try-error") w.sum2<-rep(0,nsim)

rlrt1.lambdafix.vec<-function(lambda,mu.w,lambda0.mu.w,lambda0.mu,w.sum2,lambda0,mu,n,p)
#vectorized version: lambda as scalar
{
     num<-  colSums(((lambda-lambda0)*mu.w)/(1+lambda*mu))
     den<-  colSums((lambda0.mu.w) / (1+lambda*mu)) + t(w.sum2)

     return( (n-p) * log(1+(num/den)) - sum(log((1+lambda*mu)/(lambda0.mu))))
}

make.lambdagrid<-function(lambda0,gridlength,log.grid.lo,log.grid.hi)
#generate symmetric grid around lambda0 that is log-equidistant to the right,
{
if(lambda0==0) return(c(0,exp(seq(log.grid.lo,log.grid.hi,length=gridlength-1))))
else
{
 leftratio<- min(max((log(lambda0)/((log.grid.hi)-(log.grid.lo))),0.2),0.8) #minimum 20%, maximum 80% of gridpoints smaller lambda0
 leftlength<-  max(round(leftratio*gridlength)-1,2) #at least 2 points
 leftdistance<-lambda0-exp(log.grid.lo)
#make sure leftlength doesn't split the left side into too small parts:
if( leftdistance < (leftlength*10*.Machine$double.eps))
                  {  leftlength <- max(round(leftdistance/(10*.Machine$double.eps)),2) }
#leftdistance approx. 1 ==> make a regular grid, since (1 +- epsilon)^((1:n)/n) makes a too concentrated grid
if(abs(leftdistance-1)<.3)
{
    leftgrid<-seq(exp(log.grid.lo),lambda0,length=leftlength+1)[-(leftlength+1)]
}
else
{
    leftdiffs<-ifelse(rep(leftdistance > 1,leftlength-1), leftdistance^((2:leftlength)/leftlength)-leftdistance^(1/leftlength),
                                                       leftdistance^((leftlength-1):1) - leftdistance^(leftlength))
    leftgrid<-lambda0-rev(leftdiffs)
}

 rightlength<- gridlength-leftlength
 rightdistance<-exp(log.grid.hi)-lambda0
 rightdiffs<-rightdistance^((2:rightlength)/rightlength)-rightdistance^(1/rightlength)
 rightgrid<-lambda0+rightdiffs

 return(c(0,leftgrid,lambda0,rightgrid))
}
}#end make.lambdagrid
#matrix (K*nsim) (mu_i*w_ij) i=1:K, j=1:nsim
mu.w<-mu*w.k.sq.mat

lambda0.mu<-(1+lambda0*mu)   #K*1

#matrix(K*nsim) ((1+lambda0*mu_i)w_ij) i=1:K, j=1:nsim
lambda0.mu.w<-lambda0.mu*w.k.sq.mat

   lambda.grid    <-make.lambdagrid(lambda0,gridlength,log.grid.lo=log.grid.lo,log.grid.hi=log.grid.hi)
   rlrt.array     <-sapply(lambda.grid,rlrt1.lambdafix.vec,mu.w,lambda0.mu.w,lambda0.mu,w.sum2,lambda0,mu,n,p) #grid.length * nsim
   max.index.rlrt.array  <-apply(rlrt.array,1,which.max) #column-indices of rowmaxima
   rlrt.max       <-rlrt.array[cbind(1:nsim,max.index.rlrt.array)]
   lambda.max     <-lambda.grid[max.index.rlrt.array]
   res            <-as.data.frame(cbind(lambda.max,rlrt.max))

colnames(res)<-c("lambda","rlrt")

return(res)
}#end RLRT1.sim

`exactLRT` <-
function(m,m0, seed=NA, nsim=5000,
                   log.grid.hi=8, log.grid.lo=-10, gridlength=200,
                   print.p=TRUE,return.sample=FALSE)
{
if(class(m0)!="lm") stop("m0 not an lm-object. \n")
if(class(m)=="spm") {m<-m$fit; class(m)<-"lme"}
if (!((c.m<-class(m)) %in% c("lmer","lme")))  stop("Invalid m specified. \n")

d<-switch(c.m,lme=extract.lmeDesign(m),lmer=extract.lmerDesign(m))
X<-d$X; Z<-d$Z; y<-d$y
Vr<-d$Vr

K<-NCOL(Z)     # no. of random effects
n<-NROW(X)     # no. of obs
p<-NCOL(X)     # no. of fixed effects
q<-p-length(coefficients(m0)[!is.na(coefficients(m0))])  #no. of restrictions

if(n!=length(m0$fitted)) stop("different data under the null and alternative. \n")
if(q<0) stop("m0 not nested in m. \n")
if(n-p-K<1) stop("No. of effects greater than n. Reduce model complexity.\n")  ###FIX

if(q==0) cat("No restrictions on fixed effects. REML-based inference probably better. \n")
if("ML"!=switch(c.m,lme=m$method,lmer=switch(m@status[2]+1,"ML","REML")))
{
cat("Using likelihood evaluated at REML estimators.\nPlease refit model with method=\"ML\" for exact results.\n")
}


#observed value of the LRT
lrt.obs<-max(0,2*logLik(m,REML=FALSE)[1]-2*logLik(m0,REML=FALSE)[1])


sample<-LRTSim(X,Z,q,sqrt.Sigma=chol(cov2cor(Vr)), seed=seed, nsim=nsim,
                   log.grid.hi=log.grid.hi, log.grid.lo=log.grid.lo,
                   gridlength=gridlength)[,2]
if(quantile(sample,.9)==0)
(cat("Distribution has", mean(sample==0), "mass at zero. You should really use REML.\n"))
p<-mean(lrt.obs<sample)

if(print.p)
{
  ans<-matrix(c(d$lambda,lrt.obs,p),1,3)
  colnames(ans)<-c("variance ratio", "LRT", "p-value")
  rownames(ans)<-c(" ")
  print(ans,digits=4)
  cat(paste("      p-value based on",nsim, "simulated values. \n"))
}
if(return.sample) return(list(p=p,sample=sample))
invisible(p)
}

`exactRLRT` <-
function(m,mA=NULL,m0=NULL, seed= NA, nsim=10000,
                   log.grid.hi=8, log.grid.lo=-10, gridlength=200,
                   print.p=TRUE,return.sample=FALSE,...)
{
if(class(m)=="spm") {m<-m$fit; class(m)<-"lme"}
if (!(c.m<-(class(m))) %in% c("lmer","lme"))  stop("Invalid m specified. \n")
if("REML"!=switch(c.m,lme=m$method,lmer=switch(m@status[2]+1,"ML","REML")))
cat("Using restricted likelihood evaluated at ML estimators.\n Refit with method=\"REML\" for exact results.\n")


d<-switch(c.m,lme=extract.lmeDesign(m),lmer=extract.lmerDesign(m))
X<-d$X; Z<-d$Z; y<-d$y
Vr<-d$Vr

K<-ncol(Z)     # no. of random effects
n<-nrow(X)     # no. of obs
p<-ncol(X)     # no. of fixed effects

if(is.null(mA) && is.null(m0)) #test for simple model
{
  #2*restricted ProfileLogLik under H0: lambda=0
  res<-qr.resid(qr(X),y)
  R<-qr.R(qr(X)); detXtX<-det(t(R)%*%R)

  reml.H0<- -((n-p)*log(2*pi) + (n-p)*log(sum(res^2)) +
              log(detXtX) + (n-p) - (n-p)*log(n-p))


  #observed value of the test-statistic
  reml.obs<- 2*logLik(m,REML=TRUE)[1]   #2*observed restricted ML
  rlrt.obs<-max(0,reml.obs - reml.H0)
  lambda<-d$lambda
}
else     #test for model with multiple var.comp.
{
  dA<-switch(class(mA),lme=extract.lmeDesign(mA),lmer=extract.lmerDesign(mA))
  d0<-switch(class(m0),lme=extract.lmeDesign(m0),lmer=extract.lmerDesign(m0))
  check4cor<-switch(class(mA),lme=any(as.matrix(mA$modelStruct$reStruct[[1]])!=diag(diag(as.matrix(mA$modelStruct$reStruct[[1]]))))
                           ,lmer=any(dim(as.matrix(tail(mA@Omega, 1)[[1]]))!=c(1,1)))   #is cov(ranef) a diagonal matrix?
  if(check4cor)
  {
    cat("Random effects not independent - covariance(s) set to 0 under the null hypothesis.\n Approximation not appropriate.\n")
    return(invisible())
  }
  if(any(dim(dA$X)!=dim(d0$X)))
  {
    stop("Fixed effects structures of mA and m0 not identical.\n REML-based inference not appropriate.")
  }

  rlrt.obs<-max(0,2*(logLik(mA,REML=TRUE)[1]-logLik(m0,REML=TRUE)[1]))
  lambda<-tail(dA$lambda,1)
}

if((rlrt.obs!=0)||return.sample)
{
  sample<-RLRTSim(X,Z,sqrt.Sigma=chol(cov2cor(Vr)),lambda0=0, seed=seed, nsim=nsim,
                   log.grid.hi=log.grid.hi, log.grid.lo=log.grid.lo,
                   gridlength=gridlength,...)[,2]
  p<-mean(rlrt.obs<sample)
}
else p=1

if(print.p)
{
  ans<-matrix(c(lambda,rlrt.obs,p),1,3)
  colnames(ans)<-c("variance ratio", "RLRT", "p-value")
  rownames(ans)<-c(" ")
  print(ans,digits=4)
  cat(paste("      p-value based on",nsim, "simulated values. \n"))
}
if(return.sample) return(list(p=p,sample=sample))
invisible(p)
}

`extract.lmeDesign` <-
function(m)
{
    require(mgcv)
    start.level = 1
    data<-m$data
    grps <- getGroups(m)
    n <- length(grps)
    if (is.null(m$modelStruct$varStruct))
        w <- rep(m$sigma, n)
    else {
        w <- 1/varWeights(m$modelStruct$varStruct)
        group.name <- names(m$groups)
        order.txt <- paste("ind<-order(data[[\"", group.name[1],
            "\"]]", sep = "")
        if (length(m$groups) > 1)
            for (i in 2:length(m$groups)) order.txt <- paste(order.txt,
                ",data[[\"", group.name[i], "\"]]", sep = "")
        order.txt <- paste(order.txt, ")")
        eval(parse(text = order.txt))
        w[ind] <- w
        w <- w * m$sigma
    }
    if (is.null(m$modelStruct$corStruct))
        V <- diag(n)
    else {
        c.m <- corMatrix(m$modelStruct$corStruct)
        if (!is.list(c.m))
            V <- c.m
        else {
            V <- matrix(0, n, n)
            gr.name <- names(c.m)
            n.g <- length(c.m)
            j0 <- 1
            ind <- ii <- 1:n
            for (i in 1:n.g) {
                j1 <- j0 + nrow(c.m[[i]]) - 1
                V[j0:j1, j0:j1] <- c.m[[i]]
                ind[j0:j1] <- ii[grps == gr.name[i]]
                j0 <- j1 + 1
            }
            V[ind, ] <- V
            V[, ind] <- V
        }
    }
    V <- as.vector(w) * t(as.vector(w) * V)
    X <- list()
    grp.dims <- m$dims$ncol
    Zt <- model.matrix(m$modelStruct$reStruct, data)
    cov <- as.matrix(m$modelStruct$reStruct)
    i.col <- 1
    n.levels <- length(m$groups)
    Z <- matrix(0, n, 0)
    if (start.level <= n.levels) {
        for (i in 1:(n.levels - start.level + 1)) {
            if(length(levels(m$groups[[n.levels-i+1]]))!=1)
            {
            X[[1]] <- model.matrix(~m$groups[[n.levels - i +
                1]] - 1, contrasts.arg = c("contr.treatment",
                "contr.treatment"))
            }
            else X[[1]]<-matrix(1)
            X[[2]] <- as.matrix(Zt[, i.col:(i.col + grp.dims[i] -
                1)])
            i.col <- i.col + grp.dims[i]
            Z <- cbind(tensor.prod.model.matrix(X),Z)
        }
        Vr <- matrix(0, ncol(Z), ncol(Z))
        start <- 1
        for (i in 1:(n.levels - start.level + 1)) {
            k <- n.levels - i + 1
            for (j in 1:m$dims$ngrps[i]) {
                stop <- start + ncol(cov[[k]]) - 1
                 Vr[ncol(Z)+1-(stop:start),ncol(Z)+1-(stop:start)] <- cov[[k]]
                 start <- stop + 1
            }
        }

        Vlambda <- V/m$sigma^2 + Z %*% Vr %*% t(Z)
    }
X<-model.matrix(formula(m$call$fixed),data)
y<-as.vector(matrix(m$residuals,nc=NCOL(m$residuals))[,NCOL(m$residuals)] +matrix(m$fitted,nc=NCOL(m$fitted))[,NCOL(m$fitted)])
return(list(
             Vlambda=Vlambda, #Cov(y)/Var(Error)
             V=V, #Cov(Error)
             Vr=Vr, #Cov(RanEf)/Var(Error)
             X=X,
             Z=Z,
             sigmasq=m$sigma^2,
             lambda=unique(diag(Vr)),
             y=y
           )
      )
}

`extract.lmerDesign` <-
function(m)
{
  X<-m@X
  Z<-as.matrix(t(m@Zt))
  Om<-m@Omega
  ngroup<-length(m@flist) #how many groups/outer blocks in Sigma
  nlevel<-numeric(ngroup) #how many levels per group / inner blocks in Sigma_i
  Vr<-matrix(0,NCOL(Z),NCOL(Z)) #Cov(RanEf)/Var(Error)
  from<-1
  for(i in 1:ngroup)
      {
          ii<-nlevel[i]<-length(attr(m@flist[[i]],"l"))
          inner.block<-solve(as.matrix(Om[[i]]))
          to<-from-1+ii*NCOL(inner.block)
          Vr[from:to,from:to]<-diag(ii) %x% inner.block
          from<-to+1
      }
   Vlambda<-diag(nrow(X))+ Z %*% Vr %*% t(Z)
   return(list(
             Vlambda=Vlambda, #Cov(y)/Var(Error)
             Vr=Vr, #Cov(RanEf)/Var(Error)
             X=X,
             Z=Z,
             sigmasq=attributes(VarCorr(m))$sc^2,
             lambda=unique(diag(Vr)),
             y=as.numeric(m@y)
           )
      )
}

