.packageName <- "asypow"
asypow.constraints <- function(constraints) {
#-----------------------------------------------------------------------
#
#       Fixes the constraints, makes sure they are consistant
#
#-----------------------------------------------------------------------

      if (is.vector(constraints)) {
           if (length(constraints) != 3)
                     stop("constraint vector must be of length 3")
           constraints <- t(as.matrix(constraints))
           s <- 1
      }      else {
           dimc <- dim(constraints)
           if (dimc[2] != 3)
                     stop("constraint matrix must have 3 columns")
           s <- dimc[1]
      }

      if (any(constraints[,1] != 1 & constraints[,1] != 2))
                     stop("bad constraint matrix")

      for (i in 1:s) {
           if (constraints[i,1] == 2) {
                if (constraints[i,2] == constraints[i,3])
                          stop("bad constraint matrix") else 
                     if (constraints[i,3] < constraints[i,2])
                     constraints[i,] <- c(constraints[i,1],constraints[i,3],
                                                             constraints[i,2])
           }
      }

      if (any(duplicated(constraints[,2]))) stop("bad constraint matrix")

      ord             <- order(constraints[,2])
      constraints[,1] <- constraints[ord,1]
      constraints[,2] <- constraints[ord,2]
      constraints[,3] <- constraints[ord,3]

      min.no.cons <- max(c(constraints[,2],constraints[constraints[,1]==2,3]))

      return(list(constraints=constraints,min.no.cons=min.no.cons))

}
asypow.construct.a <- function(constraints,p) {
#----------------------------------------------------------------------
#               Contructs the matrix A using constraints
#
# constraints: The constraints which set the null hypothesis from the
#     alternative hypothesis. They are in matrix form.
#          CONSTRAINT[,1] is 1 for setting parameter to a value
#                            2 for equality of two parameters
#          CONSTRAINT[,2] is case on CONSTRAINT[,1]
#               (1) Number of parameter to set to value
#               (2) Number of one of two parameters to be set equal
#          CONSTRAINT[,3] is case on CONSTRAINT[,1]
#               (1) Value to which parameter is set
#               (2) Number of other of two parameters to be set equal
#
#     p : The number of parameters in the model.
#
#
# RETURNS a list:
#
#     a : matrix that will multiply parameters
#
#     phi.ho : values of constrained parameters under the null model
#
#     ix.con : ixdex corresponding to phi.ho
#----------------------------------------------------------------------

      new.cons    <- asypow.constraints(constraints)
      constraints <- new.cons$constraints
      if (p < new.cons$min.no.cons)
                     stop("p is too small for the constraint matrix")

      s <- dim(constraints)[1]
      r <- p - s

      ix.con <- constraints[,2]
      if (r > 0) {
           ix.unc <- (1:p)[-ix.con]
           A <- matrix(0,ncol=p,nrow=r)
           for(i in 1:r) A[i,ix.unc[i]] <- 1
      }      else A <- NULL

      phi.ho <- rep(NA,s)
      Acon <- matrix(0,ncol=p,nrow=s)
      for(i in 1:s) {
           if(constraints[i,1] == 1) {
                Acon[i,constraints[i,2]] <- 1
                phi.ho[i] <- constraints[i,3]
           }  else {
                Acon[i,constraints[i,2]] <- 1
                Acon[i,constraints[i,3]] <- -1
                phi.ho[i] <- 0
           }
      }

      return(list(a=rbind(Acon,A),phi.ho=phi.ho,ix.con=ix.con,
                                              constraints=constraints))
}
asypow.n <- function(asypow.obj, power, significance) {
#----------------------------------------------------------------------
#
#          Calculates the sample size needed to obtain the
#                      desired power for a test.
#
# asypow.obj : The object returned from asypow.noncent
#
# power : The power of the test.
#
# significance: The significance level of the test.
#
#
# RETURNS the needed sample size.
#
#----------------------------------------------------------------------

      n <- length(significance)
      m <- length(power)
      if (n !=1 & m!= 1 & n != m)
                stop("lengths of significance and power must match")
      if (n == 1) significance <- rep(significance,length=m)
      if (m == 1) power <- rep(power,length=n)

      w <- rep(0,n)

      crit <- qchisq(1-significance,asypow.obj$df)

      for(i in 1:n) {
	 w[i] <- cdfchn(4, p=1-power[i], x=crit[i], df=asypow.obj$df)$pnonc
      }

      sample.size <- w / asypow.obj$w

      return(sample.size)
}
asypow.noncent <- function(theta.ha, info.mat, constraints, nobs.ell=1,
                              get.ho=TRUE) {
#----------------------------------------------------------------------
#
# theta.ha: Array of parameter values under the alternative hypothesis.
#
# info.mat: The information matrix, the second derivate matrix of the
#           expected log likelihood under the alternative hypothesis.
#           The negative of the hessian matrix.
#
# constraints: the constraints which set the null hypothesis from the
#     alternative hypothesis. They are in matrix form.
#          CONSTRAINT[,1] is 1 for setting parameter to a value
#                            2 for equality of two parameters
#          CONSTRAINT[,2] is case on CONSTRAINT[,1]
#               (1) Index of parameter to set to value
#               (2) Index of one of two parameters to be set equal
#          CONSTRAINT[,3] is case on CONSTRAINT[,1]
#               (1) Value to which parameter is set
#               (2) Index of other of two parameters to be set equal
#
# nobs.ell: The number of observations used in computing the information
#           matrix.  That is, info.mat is that for nobs.ell observations.
#
# get.ho: If TRUE, estimates of the parameter values under the null
#      hypothesis are calculated and returned, otherwise not.
#
#
# RETURNS a list of:
#
# w: noncentrality parameter for 1 observation
#
# df: degrees of freedom of the test
#
# theta.ho: estimates of the parameter values under the null hypothesis
#
#----------------------------------------------------------------------

      if (is.matrix(theta.ha)) theta.ha <- as.vector(t(theta.ha))
      p <- length(theta.ha)

      if (length(info.mat)==1) info.mat <- matrix(info.mat, nrow=1, ncol=1)
      dimi <- dim(info.mat)
      if (dimi[1] != dimi[2]) stop("info.mat is not a square matrix")
      if (p != dimi[1])
           stop("length of theta.ha must match dimension of info.mat")

      Aans <- asypow.construct.a(constraints,length(theta.ha))
      Ainv <- solve(Aans$a)
      hess <- t(Ainv) %*% info.mat %*% Ainv

      constraints <- Aans$constraints
      s <- dim(constraints)[1]
      r <- p - s
      
      hess.phiphi <- hess[1:s, 1:s]
      if (r > 0) {
           hess.philam <- hess[1:s, (s+1):p]
           hess.lamphi <- hess[(s+1):p, 1:s]
           hess.lamlam <- hess[(s+1):p, (s+1):p]

           w <- hess.phiphi - 
                          hess.philam %*% solve(hess.lamlam) %*% hess.lamphi
      }      else w <- hess.phiphi

      phi.ha.tran <- transformPhi(theta.ha, constraints)

      phi.diff <- Aans$phi.ho - phi.ha.tran

      w <- t(phi.diff) %*% w %*% phi.diff

#  now convert to the w statistic for one observation
      w <- w / nobs.ell

      df <- s

      if(r > 0 & get.ho) {
           lam.ho.tran <- theta.ha[-Aans$ix.con] + 
                           solve(hess.lamlam) %*% hess.lamphi %*% phi.diff

           theta.ho <- asypow.theta.ho(lam.ho.tran, constraints)

           return(list(w=w, df=df, theta.ho=theta.ho))
      }      else return(list(w=w, df=df))
}
asypow.power <- function(asypow.obj, sample.size, significance) {
#----------------------------------------------------------------------
#
#               Calculates the power of a test
#
# asypow.obj : The object returned from asypow.noncent
#
# sample.size : The sample size of the study.
#
# significance: The significance level of the test.
#
#
# RETURNS the power of the test.
#
#----------------------------------------------------------------------

      n <- length(significance)
      m <- length(sample.size)
      if (n !=1 & m!= 1 & n != m)
                stop("lengths of significance and sample.size must match")
      if (n == 1) significance <- rep(significance,length=m)
      if (m == 1) sample.size <- rep(sample.size,length=n)

      crit <- qchisq(1-significance, asypow.obj$df)
      w <- asypow.obj$w * sample.size

      power <- rep(0,n)

      for(i in 1:n) {
	power[i] <- 1-cdfchn(1,x=crit[i],df=asypow.obj$df,pnonc=w[i])$p
      }
      return(power)
}
asypow.sig <- function(asypow.obj, sample.size, power) {
#----------------------------------------------------------------------
#
#          Calculates the significance level of the test.
#
# asypow.obj : The object returned from asypow.noncent
#
# sample.size : The sample size of the test
#
# power : The power of the test.
#
#
# RETURNS the significance level
#
#----------------------------------------------------------------------

      n <- length(sample.size)
      m <- length(power)
      if (n !=1 & m!= 1 & n != m)
                stop("lengths of sample.size and power must match")
      if (n == 1) sample.size <- rep(sample.size, length=m)
      if (m == 1) power <- rep(power, length=n)

      w <- asypow.obj$w * sample.size

      crit <- rep(0,n)

      for(i in 1:n) {
	crit[i] <- cdfchn(2,p=1-power[i], df=asypow.obj$df, pnonc=w[i])$x
      }

      return(1-pchisq(crit,1))
}
asypow.theta.ho <- function(lam.ho, constraints) {

      p <- length(lam.ho) + length(constraints[,1])
      theta.ho <- rep(NA,p)

      ix.con <- constraints[,2]
      theta.ho[-ix.con] <- lam.ho

      if(any(constraints[,1]==1)) {
           ix.set <- constraints[constraints[,1]==1,2]
           theta.ho[ix.set] <- constraints[constraints[,1]==1,3]
      }

      if(any(constraints[,1]==2)) {
           ix.equ <- constraints[constraints[,1]==2,2]
           for(i in rev(ix.equ)) {
                theta.ho[i] <- theta.ho[constraints[i,3]]
           }
      }

      return(theta.ho)
}
cdfchn <- function(which, p=0.0, x=0.0, df=0.0, pnonc=0.0)
#**********************************************************************
#
#               Cumulative Distribution Function
#               Non-central Chi-Square
#
#
#                              Function
#
#
#     Calculates any one parameter of the non-central chi-square
#     distribution given values for the others.
#
#
#                              Arguments
#
#
#     WHICH --> Integer indicating which of the next three argument
#               values is to be calculated from the others.
#               Input range: 1..4
#               iwhich = 1 : Calculate P from X and DF
#               iwhich = 2 : Calculate X from P,DF and PNONC
#               iwhich = 3 : Calculate DF from P,X and PNONC
#               iwhich = 3 : Calculate PNONC from P,X and DF
#                    INTEGER WHICH
#
#     P <--> The integral from 0 to X of the non-central chi-square
#            distribution.
#            Input range: [0, 1-1E-16).
#                    DOUBLE PRECISION P
#
#     X <--> Upper limit of integration of the non-central
#            chi-square distribution.
#            Input range: [0, +infinity).
#            Search range: [0,1E300]
#                    DOUBLE PRECISION X
#
#     DF <--> Degrees of freedom of the non-central
#             chi-square distribution.
#             Input range: (0, +infinity).
#             Search range: [ 1E-300, 1E300]
#                    DOUBLE PRECISION DF
#
#     PNONC <--> Non-centrality parameter of the non-central
#                chi-square distribution.
#                Input range: [0, +infinity).
#                Search range: [0,1E4]
#                    DOUBLE PRECISION PNONC
#
#                              Method
#
#
#     Formula  26.4.25   of   Abramowitz   and   Stegun,  Handbook  of
#     Mathematical  Functions (1966) is used to compute the cumulative
#     distribution function.
#
#     Computation of other parameters involve a seach for a value that
#     produces  the desired  value  of P.   The search relies  on  the
#     monotinicity of P with the other parameter.
#
#
#                            WARNING
#
#     The computation time  required for this  routine is proportional
#     to the noncentrality  parameter  (PNONC).  Very large  values of
#     this parameter can consume immense  computer resources.  This is
#     why the search range is bounded by 10,000.
#
#**********************************************************************
{
  request <- c("p","x","df","pnonc")

# **** cdfchn should be loaded before the next statement ****

  ans <- .Fortran("cdfchn",
		  as.integer(which),
		  as.double(p),
		  as.double(1.0-p),
		  as.double(x),
                  as.double(df),
		  as.double(pnonc),
		  status=as.integer(0),
		  bound = as.double(0), 
                  PACKAGE="asypow")
  status <- ans$status
  bound  <- ans$bound
  if (status != 0) {
    if (status == -1) stop("which should be 1,2,3 or 4")else 
    if (status == -2) stop("p should be in range [0, 1-1E-16)") else 
    if (status == -3) stop("x should be in range [0, +infinity)") else 
    if (status == -4) stop("df should be in range [0, +infinity)") else 
    if (status == -5) stop("pnonc should be in range [0, +infinity)") else 
    if (status == 1) 
	stop(paste(request[which],"lower than lowest search bound", bound)) else 
    if (status == 2)
	stop(paste(request[which],"larger than largest search bound",bound)) else
        stop("SMALL, X, BIG not monotone in INVR")
  } else {
    if (which == 1) return(list(p=ans[[2]])) else 
    if (which == 2) return(list(x=ans[[4]])) else 
    if (which == 3) return(list(df=ans[[5]])) else 
    if (which == 4) return(list(pnonc=ans[[6]]))
  }
}
derivs.link <- function(u, link){

### Value and first two derivatives of link function

### link
###      (1) Logistic
###          g(u) = exp(u)/(1+exp(u))
###      (2) Complementary log-log
###          g(u) = 1 - exp( -exp(u) )

### Returns vector of length three 
###     [1] - value of link function at u
###     [2] - first derivative of link function wrt u
###     [3] - second derivative of link function wrt u

  ans <- rep( 0, 3 )
  ans[1] <- 1
  BIG <- 690
  if ( u > BIG ) return( ans )
  if (link < 1 || link > 2) stop('Illegal value of link')

### Logistic

  if (link == 1 ) {
    tmp <- exp(u)
    ans[1] <- tmp / ( 1 + tmp )
    ans[2] <- ans[1] * ( 1 - ans[1] )
    ans[3] <- ans[2] * ( 1 - 2*ans[1] )  } else {
      tmp <- exp(u)
      ans[1] <- 1 - exp( -tmp )
      ans[2] <- exp( u - tmp )
      ans[3] <- ans[2] - exp( 2*u - tmp )   }

  return( ans )     }
info.binomial.design <- function(model="linear", link="logistic", theta,
                             xpoints, natx=1, group.size=1) {
#-----------------------------------------------------------------------
#        Returns the information matrix for a binomial design
#
# model: One of {"linear", "quadratic"} Only enough to ensure a unique
#           match need be supplied.
#
# link: One of {"logistic", "complementary log"} Only enough to ensure
#           a unique match need be supplied.
#
# theta: Matrix of parameters of the linear part of the model.
#          Each row represents a group.
#
# xpoints: Matrix of covariate values for each group.
#             Each row represents a group.
#
# natx: Matrix of number of observations at xpoints for each group.
#           Each row represents a group.
#           At covariate value xpoint[i,j] there are natx[i,j] observations.
#
# group.size: The relative number of observations in each group
#
#
# Returns: The the information matrix for one observation for this design.
#     The observation is assumed to be spread over xpoints in proportion
#     to natx.
#
#-----------------------------------------------------------------------

      if (is.vector(theta)) theta <- t(as.matrix(theta))
      dimt <- dim(theta)
      ngroups <- dimt[1]

      if (is.vector(xpoints)) {
           xpoints <- matrix(xpoints,ngroups,length(xpoints),byrow=TRUE)
           dimp <- dim(xpoints)
      } else {
           dimp <- dim(xpoints)
           if (dimp[1] != ngroups)
                stop("Number of rows of xpoints and theta must match")
      }
      if (is.vector(natx)) {
           if (length(natx) == 1)
                natx <- matrix(natx,ngroups,dimp[2],byrow=TRUE) else {
                if (length(natx) != dimp[2] )
                     stop ("length of natx must match number of xpoints")
                natx <- matrix(natx,ngroups,dimp[2],byrow=TRUE)
           }
           dimn <- dim(natx)
      } else {
           dimn <- dim(natx)
           if (dimn[1] != dimp[1] || dimn[2] != dimp[2])
                stop("xpoints and natx must have the same dimensions")
      }

      lngrpsz <- length(group.size)
      if (lngrpsz == 1) group.size <- rep(group.size,ngroups) else 
      if (ngroups != lngrpsz)
       stop("\nNumber of rows of theta and length of group.size must match")

      info <- vector("list", dimp[1])

      for (j in 1:ngroups) {
           info[[j]] <- 0
           for (i in 1:length(xpoints[j,]))
                if(natx[j, i] != 0) info[[j]] <- info[[j]] + natx[j,i] *
                     info.binomial.one(model,link,theta[j,],xpoints[j,i])
           info[[j]] <- info[[j]] * group.size[j]
      }

      info <- k.blocks.info(info)

      return(info/sum(group.size * natx))
}
info.binomial.kgroup <- function(p, group.size=1) {
###-----------------------------------------------------------------------
###      Returns the fisher information for the raw binomial model
###
### p: For l groups, a vector of length l. The probability of an event for
###     a single trial.  For k groups a vector of length k.
###
### group.size: The relative number of observations in each group
###
### Returns: The information from a single trial which is spread over
###          the several groups.
###-----------------------------------------------------------------------

  if (any(p < 0.000001 | p > .999999)) stop ("p must between 0 and 1")
  ngroups <- length(p)

  lngrpsz <- length(group.size)
  if (lngrpsz == 1) group.size <- rep(1,ngroups) else 
         if (ngroups != lngrpsz)
              stop ("lengths of p and group.size must match")

  hess <- -1/(p*(1-p))

  info <- (group.size * -hess) / sum(group.size)
  if (ngroups > 1) info <- diag(info)

  return(info)
}
info.binomial.one <- function(model="linear", link="logistic",
                                                        theta, covariate) {
#-----------------------------------------------------------------------
#  Returns the information matrix for the binomial model with a
#  single covariate value
#
# model: One of {"linear", "quadratic"} Only enough to ensure a unique
#           match need be supplied.
#
# link: One of {"logistic", "complementary log"} Only enough to ensure
#           a unique match need be supplied.
#
# theta: Vector of parameters of the linear part of the model.
#
# covariate: Scalar value of the covariate.
#
#
# Returns: The contribution to the information matrix of a single
#           observation at value covariate.
#
#-----------------------------------------------------------------------

      model <- pmatch(model, c("linear","quadratic"))
      if (is.na(model)) stop("model must be one of {'linear','quadratic'}")
      if (model == 1) u <- theta[1] + theta[2]*covariate
      else u <- theta[1] + theta[2]*covariate + theta[3]*covariate^2

      if(model != (length(theta)-1))
                stop("theta inconsistant with model")

      link <- pmatch(link, c("logistic", "complementary log"))
      if (is.na(link))
                stop("link must be one of {'logistic','complementary log'}")
      if (link == 1) p <- exp(u) / (1 + exp(u)) else p <- 1 - exp(-exp(u))

      d2lldp2 <- -1 / (p *(1-p))

      if (link == 1) dpdu <- p * (1-p) else dpdu <- exp(u) * (1-p)

      dpda <- dpdu
      dpdb <- dpdu * covariate
      if (model == 2) dpdc <- dpdu * covariate^2

      if (model == 1) hess <- matrix(c(dpda^2,rep(dpda*dpdb,2),dpdb^2),2,2) else 
      hess <- matrix(c(dpda^2,dpda*dpdb,dpda*dpdc,
                     dpdb*dpda,dpdb^2,dpdb*dpdc,
                     dpdc*dpda,dpdc*dpdb,dpdc^2),3,3)

      return(- d2lldp2 * hess)
}
info.expsurv.design <- function(model="linear", theta, L, xpoints,
                             natx=1, group.size=1) {
#-----------------------------------------------------------------------
#        Returns the information matrix for a poisson design
#
# model: One of {"linear", "quadratic"} Only enough to ensure a unique
#           match need be supplied.
#
# theta: Matrix of parameters of the linear part of the model.
#             Each row represents a group.
#
# L : Length of the experiment
#
# xpoints: Matrix of covariate values for each group.
#             Each row represents a group.
#
# natx: Matrix of number of observations at xpoints for each group.
#           Each row represents a group.
#           At covariate value xpoint[i,j] there are natx[i,j] observations.
#
# group.size: The relative number of observations in each group
#
#
# Returns: The the information matrix for one observation for this design.
#     The observation is assumed to be spread over xpoints in proportion
#     to natx.
#
#-----------------------------------------------------------------------

      if (is.vector(theta)) theta <- t(as.matrix(theta))
      dimt <- dim(theta)
      ngroups <- dimt[1]

      if (length(L) == 1) L <- rep(L,ngroups) else {
         if (length(L) != ngroups)
            stop("Length of L and number of rows of theta must match")
      }

      if (is.vector(xpoints)) {
           xpoints <- matrix(xpoints,ngroups,length(xpoints),byrow=TRUE)
           dimp <- dim(xpoints)
      } else {
           dimp <- dim(xpoints)
           if (dimp[1] != ngroups)
                stop("Number of rows of xpoints and theta must match")
      }
      if (is.vector(natx)) {
           if (length(natx) == 1)
                natx <- matrix(natx,ngroups,dimp[2], byrow=TRUE) else {
                if (length(natx) != dimp[2] )
                     stop ("length of natx must match number of xpoints")
                natx <- matrix(natx,ngroups,dimp[2], byrow=TRUE)
           }
           dimn <- dim(natx)
      } else {
           dimn <- dim(natx)
           if (dimn[1] != dimp[1] || dimn[2] != dimp[2])
                stop("xpoints and natx must have the same dimensions")
      }

      lngrpsz <- length(group.size)
      if (lngrpsz == 1) group.size <- rep(group.size,ngroups) else 
      if (ngroups != lngrpsz)
       stop("\nNumber of rows of theta and length of group.size must match")

      info <- vector("list", dimp[1])

      for (j in 1:dimp[1]) {
           info[[j]] <- 0
           for (i in 1:length(xpoints[j,]))
                if(natx[j, i] != 0) info[[j]] <- info[[j]] + natx[j,i] *
                      info.expsurv.one(model,L[j],theta[j,],xpoints[j,i])
           info[[j]] <- info[[j]] * group.size[j]
      }

      info <- k.blocks.info(info)

      return(info/sum(group.size * natx))
}
info.expsurv.kgroup <- function(w, L, group.size=1) {
###-----------------------------------------------------------------------
###      Returns the fisher information for the raw exponential
###      survival model
###
### L : The length of the study. If L is length 1 each group has
###     a study of length L. If L is the same length as w
###     each group has a different length.
###
### w : For l groups a vector of length l. The rate, or inverse
###          of the mean of the exponential distribution.
###
### group.size: The relative number of observations in each group
###
### Returns: The information from a single trial which is spread over
###          the several groups.
###-----------------------------------------------------------------------
  ngroups <- length(w)

  if (length(L) == 1) L <- rep(L,ngroups)
  if (length(L) != ngroups)
     stop("lengths of w and L must match")

  lngrpsz <- length(group.size)
  if (lngrpsz == 1) group.size <- rep(1,ngroups) else 
  if (ngroups != lngrpsz)
      stop ("lengths of w and group.size must match")

  nhess <- (exp(-w*L) - 1)/(L*w^3) + 1/(w^2)
  info <- (group.size * nhess) / sum(group.size)
  if (ngroups > 1) info <- diag(info)

  return(info)
}
info.expsurv.one <- function(model="linear", L, theta, covariate) {
#-----------------------------------------------------------------------
#  Returns the information matrix for the exponential survival model
#  with a single covariate value
#
# model: One of {"linear", "quadratic"} Only enough to ensure a unique
#           match need be supplied.
#
# L : Length of the experiment
#
# theta: Vector of parameters of the linear part of the model.
#
# covariate: Scalar value of the covariate.
#
#
# Returns: The contribution to the information matrix of a single
#           observation at value covariate.
#
#-----------------------------------------------------------------------

      model <- pmatch(model, c("linear","quadratic"))
      if (is.na(model)) stop("model must be one of {'linear','quadratic'}")

      if(model != (length(theta)-1))
                stop("theta inconsistant with model")

      x <- covariate
      x2 <- x*x
      x3 <- x2*x
      x4 <- x3*x

      if (model == 1) u <- theta[1] + theta[2]*x  else 
         u <- theta[1] + theta[2]*x + theta[3]*x2

      w <- exp(u)
      wL <- w*L
      enwL <- exp(-wL)
      const <- ((enwL*(wL+2) + w*L - 2) - (enwL*(wL+1) - 1))/wL
      if (model == 1) 
         info <- const*matrix(c(1,x,x,x2),nrow=2,ncol=2) else
         info <- const*matrix(c(1,x,x2,x,x2,x3,x2,x3,x4),nrow=3,ncol=3)

      return(info)

}
info.mvlogistic <- function( coef, design, rss=1 ){
#     Information Matrix for a Multivariate Logistic

# MODEL IS:
#        Prob event(u) = exp(u) / ( 1 + exp(u) )
# where u = Sum( coef[i]*x[i] )
# and coef is the argument so named.  The x are rows of the 
# design matrix.


# coef - Vector of length p (number of covariates) giving coefficients
#        of variables

# design - Matrix of length n X p each row of which gives values of
#          covariates at one of the n design points
# Note: Most models will include a constant term and the column of
#       design corresponding to this term will be identically 1

# rss - The relative sample size at each design point.  If changed
#       from its default value should be a vector of length n.
# Note:  The information matrix is calculated for one observation
#        spread over the n design points in proportions determined
#        by rss.

# NOTE: The primary use of this routine will be for tables analysed
#       using anova techniques with a logistic model.

#----------------------------------------------------------------------

p <- length( coef )

if (is.vector(design)) {
   design <- matrix(design,nrow=1)
}

tmp <- dim( design )

if ( tmp[2] != p ) 
   stop('Number of variables in coef and design differ')

n <- tmp[1]

lrss <- length(rss)
if ( lrss == 1 ) {
   wt <- rep(1,n)
   tot <- n } else if ( lrss == n ) {
   wt <- rss
   tot <- sum(rss) } else 
         stop('Length of rss does not match number of design points.')

info <- matrix( 0, ncol=p, nrow=p )

for (i in 1:n) {
  
  row <- design[i,]

  u <- crossprod( row, coef )
  dim(u) <- NULL

  p <- invlogit( u )

  mat <- outer( row, row )

  info <- info + wt[i] * p * (1-p) * mat     }

return( info/tot )     }
info.mvloglin <- function( coef, design, rss=1 ){
#     Information Matrix for a Log-Linear model

# coef - Vector of length p (number of covariates) giving coefficients
#        of variables

# MODEL IS:
#        Prob event(u) = exp(u)
# where u = Sum(log( coef[i] )*x[i] )

# design - Matrix of length n X p each row of which gives values of
#          covariates (x values) at one of the n design points
# Note: Most models will include a constant term and the column of
#       design corresponding to this term will be identically 1

# rss - The relative sample size at each design point.  If changed
#       from its default value should be a vector of length n.
# Note:  The information matrix is calculated for one observation
#        spread over the n design points in proportions determined
#        by rss.

# NOTE: The primary use of this routine will be for tables analysed
#       using anova techniques with a logistic model.

#----------------------------------------------------------------------

p <- length( coef )

if (is.vector(design)) {
   design <- matrix(design,nrow=1)
}

tmp <- dim( design )

if ( tmp[2] != p ) 
     stop('Number of variables in coef and design differ')

n <- tmp[1]

lrss <- length(rss)
if ( lrss == 1 ) {
   wt <- rep(1,n)
   tot <- n } else if ( lrss == n ) {
   wt <- rss
   tot <- sum(rss) } else 
       stop('Length of rss does not match number of design points.')

model.info <- matrix( 0, ncol=p, nrow=p )

lcoef <- log(coef)

for (i in 1:n) {
  
  row <- design[i,]

  u <- crossprod( row, lcoef )
  dim(u) <- NULL
  p <- exp( u )
  if (p >= 1) 
     stop(paste("Probability p generated with from design point",i,
                "is not an element of (0,1)"))

  mat <- outer( row/coef, row/coef )

  mult <- (wt[i] * (p / (1-p)))

  model.info <- model.info + mult * mat     }

return( model.info/tot )     }
info.ordinal.cat <- function( model, link, theta, x, icat ){

### Returns the contribution to the information matrix from an observation
### of icat.

### model is 1 for linear model
###          2 for quadratic model

### link is 1 for logistic link
###         2 for complementary log-log

### theta is vector of parameter values
###         theta[1:(ncat-1)] are intercept terms
###         theta[ncat] is coefficient of x
###         theta[ncat+1] is coefficient of x^2 for quadratic

### x scalar value of covariate

### icat is outcome value for which contribution to into evaluated

  ntheta <- length(theta)

  if ( model == 1 ) ncat <- ntheta   else 
          ncat <- ntheta - 1

  Du.i <- Du.im1 <- rep(0, ntheta)
  Dg.i <- Dg.im1 <- rep(0, 3)

  not.first <- icat > 1
  not.last <- icat < ncat
  if (ncat == 1) not.last <- 1

### Set up value, first and second derivative of link with respect to u
### for u_i and u_im1

  if (not.last) {
    u.i <- theta[icat] + theta[ncat]*x
    if (model == 2) u.i <- u.i + theta[ncat+1]*x^2 
    Dg.i <- derivs.link( u.i, link )  
    Du.i[icat] <- 1
    Du.i[ncat] <- x
    if (model ==2) Du.i[ntheta] <- x^2  }

  if (not.first) {
    u.im1 <- theta[icat-1] + theta[ncat]*x
    if (model == 2) u.im1 <- u.im1 + theta[ncat+1]*x^2 
    Dg.im1 <- derivs.link( u.im1, link )  
    Du.im1[icat-1] <- 1
    Du.im1[ncat] <- x
    if (model ==2) Du.im1[ntheta] <- x^2  }

### Compute p.i, probability of landing in icat

  if (ncat == 1 || icat == 1) p.i <- Dg.i[1] else {
      if (icat < ncat) p.i <- Dg.i[1] - Dg.im1[1]  else 
             p.i <- 1 - Dg.im1[1]   }

### Compute second derivatives multiplied by p.i

  ans <- outer(Du.i,Du.i) * ( Dg.i[3] - Dg.i[2]^2 / p.i ) -
    outer(Du.im1,Du.im1) * ( Dg.im1[3] + Dg.im1[2]^2 / p.i ) + 
      ( outer(Du.i,Du.im1) + outer(Du.im1,Du.i) ) * 
         ( Dg.i[2] * Dg.im1[2] / p.i )

### Return negative of second derivatives multiplied by p.i

  return( -ans )    }
info.ordinal.design <- function(model="linear", link="logistic", theta,
                             xpoints, natx=1, group.size=1) {
#-----------------------------------------------------------------------
#        Returns the information matrix for a ordinal design
#
# model: One of {"linear", "quadratic"} Only enough to ensure a unique
#           match need be supplied.
#
# link: One of {"logistic", "complementary log"} Only enough to ensure
#           a unique match need be supplied.
#
# theta: Matrix of parameters of the linear part of the model.
#          Each row represents a group.
#
# xpoints: Matrix of covariate values for each group.
#             Each row represents a group.
#
# natx: Matrix of number of observations at xpoints for each group.
#             Each row represents a group.
#           At covariate value xpoint[i,j] there are natx[i,j] observations.
#
# group.size: The relative number of observations in each group
#
#
# Returns: The the information matrix for one observation for this design.
#     The observation is assumed to be spread over xpoints in proportion
#     to natx.
#
#-----------------------------------------------------------------------

      if (is.vector(theta)) theta <- t(as.matrix(theta))
      dimt <- dim(theta)
      ngroups <- dimt[1]

      if (is.vector(xpoints)) {
           xpoints <- matrix(xpoints,ngroups,length(xpoints),byrow=TRUE)
           dimp <- dim(xpoints)
      } else {
           dimp <- dim(xpoints)
           if (dimp[1] != ngroups)
                stop("Number of rows of xpoints and theta must match")
      }
      if (is.vector(natx)) {
           if (length(natx) == 1)
                natx <- matrix(natx,ngroups,dimp[2],byrow=TRUE)  else {
                if (length(natx) != dimp[2] )
                     stop ("length of natx must match number of xpoints")
                natx <- matrix(natx,ngroups,dimp[2],byrow=T)
           }
           dimn <- dim(natx)
      } else {
           dimn <- dim(natx)
           if (dimn[1] != dimp[1] || dimn[2] != dimp[2])
               stop("xpoints and natx must have the same dimensions")
      }

      lngrpsz <- length(group.size)
      if (lngrpsz == 1) group.size <- rep(group.size,ngroups)
      else if (ngroups != lngrpsz)
       stop("\nNumber of rows of theta and length of group.size must match")

      info <- vector("list",dimp[1])

      for (j in 1:dimp[1]) {
           info[[j]] <- 0
           for (i in 1:length(xpoints[j,]))
                if (natx[j,i] != 0) info[[j]] <- info[[j]] + natx[j,i] *
                      info.ordinal.one(model,link,theta[j,],xpoints[j,i])
           info[[j]] <- info[[j]] * group.size[j]
      }

      info <- k.blocks.info(info)

      return(info/sum(group.size * natx))
}
info.ordinal.kgroup <- function(p, group.size=1) {
###-----------------------------------------------------------------------
###      Returns the information matrix for the raw ordinal model
###
### p: For a single group with n categories,
###        p[i] = prob(event occured in category i or less)
###    Dimension of p in this case is (n-1) since p[n] would
###    automatically be 1.
###
###    For k groups a matrix dimensioned k X (n-1).
###
### group.size: The relative number of observations in each group
###
###
### Returns: The information matrix from a single trial spread over
###          the groups.
###
###-----------------------------------------------------------------------

  if (any(apply(cbind(0,p,1),1, diff) < 0))
    stop("p must be increasing and between 0 and 1")
  if (is.vector(p)) p <- t(as.matrix(p))
  ngroups <- dim(p)[1]

  lngrpsz <- length(group.size)
  if (lngrpsz == 1) group.size <- rep(1,ngroups) else 
        if (ngroups != lngrpsz)
      stop ("\nnumber or rows of p and length of group.size must match")

  hess <- vector("list", ngroups)
  for(j in 1:ngroups) {
    pj <- p[j,]
    k <- length(pj)
    if (k == 0) next
    if (k == 1) hess[[j]] <- -1/(pj*(1-pj)) else {
        hess[[j]] <- matrix(0,k,k)

        p.at <- diff(c(0,pj,1))
        t1 <- 1/p.at[-(k+1)]
        t2 <- 1/p.at[-1]
        diag(hess[[j]]) <- -(t1 + t2 )
        for(i in 1:(k-1)) hess[[j]][i,i+1] <- hess[[j]][i+1,i] <-
          1/p.at[i+1]
      }
    hess[[j]] <- group.size[j] * hess[[j]]
  }

  info <- - k.blocks.info(hess)

  return(info/sum(group.size))
}
info.ordinal.one <- function(model="linear", link="logistic",
                                                    theta, covariate) {
#-----------------------------------------------------------------------
#  Returns the information matrix for the ordinal model with covariate
#
# model: One of {"linear", "quadratic"} Only enough to ensure a unique
#           match need be supplied.
#
# link: One of {"logistic", "complementary log"} Only enough to ensure
#           a unique match need be supplied.
#
# theta: Vector of parameters of the linear part of the model.
#          If there are K categories then
#    model = "linear" :
#      U[i] = THETA[i] + THETA[k]*covariate    i = 1,(k-1)
#    model = "quadratic" :
#      U[i] = THETA[i] + THETA[k]*covariate + THETA[k+1]*covariate^2
#                                                              i = 1,(k-1)
#                    
# covariate: Scalar value of the covariate.
#
#
# Returns: The contribution to the information matrix of a single
#           observation at value covariate.
#
#-----------------------------------------------------------------------

      imodel <- pmatch(model, c("linear","quadratic"))
      if (is.na(imodel)) stop("model must be one of {'linear','quadratic'}")
	
      link <- pmatch(link, c("logistic","complementary log"))
      if (is.na(link))
                stop("link must be one of {'logistic','complementary log'}")

	
      ntheta <- length(theta)
      ans <- matrix(0,ntheta,ntheta)
	
      if (imodel==1) ncat <- ntheta else 
             ncat <- ntheta - 1
      
      for (icat in 1:ncat) ans <- ans + info.ordinal.cat(
      imodel, link, theta, covariate, icat )

      return( ans )
}
info.poisson.design <- function(model="linear", theta, xpoints,
                             natx=1, group.size=1) {
#-----------------------------------------------------------------------
#        Returns the information matrix for a poisson design
#
# model: One of {"linear", "quadratic"} Only enough to ensure a unique
#           match need be supplied.
#
# theta: Matrix of parameters of the linear part of the model.
#             Each row represents a group.
#
# xpoints: Matrix of covariate values for each group.
#             Each row represents a group.
#
# natx: Matrix of number of observations at xpoints for each group.
#           Each row represents a group.
#           At covariate value xpoint[i,j] there are natx[i,j] observations.
#
# group.size: The relative number of observations in each group
#
#
# Returns: The the information matrix for one observation for this design.
#     The observation is assumed to be spread over xpoints in proportion
#     to natx.
#
#-----------------------------------------------------------------------

      if (is.vector(theta)) theta <- t(as.matrix(theta))
      dimt    <- dim(theta)
      ngroups <- dimt[1]

      if (is.vector(xpoints)) {
           xpoints <- matrix(xpoints,ngroups,length(xpoints), byrow=TRUE)
           dimp <- dim(xpoints)
      } else {
           dimp <- dim(xpoints)
           if (dimp[1] != ngroups)
                stop("Number of rows of xpoints and theta must match")
      }
      if (is.vector(natx)) {
           if (length(natx) == 1)
                natx <- matrix(natx,ngroups,dimp[2],byrow=TRUE) else {
                if (length(natx) != dimp[2] )
                     stop ("length of natx must match number of xpoints")
                natx <- matrix(natx,ngroups,dimp[2],byrow=TRUE)
           }
           dimn <- dim(natx)
      } else {
           dimn <- dim(natx)
           if (dimn[1] != dimp[1] || dimn[2] != dimp[2])
                stop("xpoints and natx must have the same dimensions")
      }

      lngrpsz <- length(group.size)
      if (lngrpsz == 1) group.size <- rep(group.size,ngroups) else 
            if (ngroups != lngrpsz)
       stop("\nNumber of rows of theta and length of group.size must match")

      info <- vector("list",dimp[1])

      for (j in 1:dimp[1]) {
           info[[j]] <- 0
           for (i in 1:length(xpoints[j,]))
                if(natx[j, i] != 0) info[[j]] <- info[[j]] + natx[j,i] *
                      info.poisson.one(model,theta[j,],xpoints[j,i])
           info[[j]] <- info[[j]] * group.size[j]
      }

      info <- k.blocks.info(info)

      return(info/sum(group.size * natx))
}
info.poisson.kgroup <- function(lambda, group.size=1 ) {
###-----------------------------------------------------------------------
###      Returns the information for the raw poisson model
###
### lambda: For k groups, a vector of length k. The mean of the poisson
###           distribution for each group
###
### group.size: The relative number of observations in each group
###
###
### Returns: The information from a single trial spread over the
###          several groups
###-----------------------------------------------------------------------

  if (any(lambda <= 0)) stop("lambda must be positive")
  ngroups <- length(lambda)

  lngrpsz <- length(group.size)
  if (lngrpsz == 1) group.size <- rep(1,ngroups) else 
    if (ngroups != lngrpsz)
      stop ("lengths of lambda and group.size must match")

  hess <- -1 / lambda
  info <- (group.size * -hess) / sum(group.size)
  if (ngroups > 1) info <- diag(info)

  return(info)
}
info.poisson.one <- function(model="linear", theta, covariate) {
#-----------------------------------------------------------------------
#  Returns the information matrix for the poisson model with a
#  single covariate value
#
# model: One of {"linear", "quadratic"} Only enough to ensure a unique
#           match need be supplied.
#
# theta: Vector of parameters of the linear part of the model.
#
# covariate: Scalar value of the covariate.
#
#
# Returns: The contribution to the information matrix of a single
#           observation at value covariate.
#
#-----------------------------------------------------------------------

      model <- pmatch(model, c("linear","quadratic"))
      if (is.na(model)) stop("model must be one of {'linear','quadratic'}")
      if (model == 1) u <- theta[1] + theta[2]*covariate else 
           u <- theta[1] + theta[2]*covariate + theta[3]*covariate^2

      if(model != (length(theta)-1))
                stop("theta inconsistant with model")

      lambda <- exp(u)

      d2lldl2 <- -1 / lambda

      dldu <- exp(u)

      dlda <- dldu
      dldb <- dldu * covariate
      if (model == 2) dldc <- dldu * covariate**2

      if (model == 1) hess <- matrix(c(dlda^2,rep(dlda*dldb,2),dldb^2),2,2)
      else hess <- matrix(c(dlda^2,dlda*dldb,dlda*dldc,
                     dldb*dlda,dldb^2,dldb*dldc,
                     dldc*dlda,dldc*dldb,dldc^2),3,3)

      return(- d2lldl2 * hess)
}
info.reparam <- function(theta, info.mat, dg) {
#-----------------------------------------------------------------------
#        Returns the information matrix for a binomial design
#
# theta: Matrix of parameters of the linear part of the model.
#          Each row represents a group. This is under the original
#          parameterization.
#
# info.mat: The information matrix under the original parameterization
#
# dg: A function that computes the partial deravatives of g,the
#          transformation function. Takes theta and returns dg/dtheta[1]
#          dg/dtheta[2] ...
#
#
# Returns: The information matrix under the new parameterization
#
#-----------------------------------------------------------------------

      if (is.vector(theta)) theta <- t(as.matrix(theta))
      dimt <- dim(theta)
      ngroups <- dimt[1]

      if(!is.matrix(info.mat)) stop("info.mat must be a matrix")
      dimi <- dim(info.mat)
      if(dimi[1]/2 != ngroups)
                stop("info.mat and theta do not match up")

      Dg <- vector("list",ngroups)
      for (j in 1:ngroups) Dg[[j]] <- dg(theta[j,])
      Dg <- k.blocks.info(Dg)

      Va <- solve(info.mat)

      var.new <- Dg %*% Va %*% t(Dg)

      info.new <- solve(var.new)

      return(info.new)
}
invlogit <- function( x ){

# Inverse logit transform of x -- yields probability

infinity <- 78   # Close to largest number that can be exponentiated

tmp <- pmin( infinity, pmax( -infinity, x ) )

tmp <- exp(tmp)

return( tmp/(1+tmp) )     }
k.blocks <- function( ... ) {

      blocks <- list(...)

      n <- 0
      for (block in blocks) n <- n + dim(block)[1]
      bmat <- matrix(0, n, n)

      ind <- 1
      for (block in blocks) {
           endind <- ind + dim(block)[1] - 1
           bmat[ind:endind,ind:endind] <- block
           ind <- endind + 1
      }

      return(bmat)
}
k.blocks.info <- function( blocks ) {

      n <- dim(blocks[[1]])[1]
      size <- length(blocks) * n
      info <- matrix(0, size, size)

      ind <- 1
      for (block in blocks) {
           endind <- ind + n - 1
           info[ind:endind,ind:endind] <- block
           ind <- endind + 1
      }

      return(info)
}
logit <- function( p ){ 

# Logit transform of probability p

infinity <- 1.0e30

psmall <- 1.0e-10

pbig <- 1 - 1.0e-7

tmp <- pmin( pbig, pmax( p, psmall ) )

return( log( tmp/(1-tmp) ) )     }
transformPhi <- function(theta.ha, constraints) {

      s <- dim(constraints)[1]
      phi.ha.tran <- rep(NA,s)

      for(i in 1:s) {
           if(constraints[i,1] == 1)
                phi.ha.tran[i] <- theta.ha[constraints[i,2]] else 
                   phi.ha.tran[i] <- 
                     theta.ha[constraints[i,3]] - theta.ha[constraints[i,2]]
      }

      return(phi.ha.tran)
}


.First.lib <- function(lib, pkg) {
     library.dynam("asypow", pkg, lib) }

.noGenerics <- TRUE

.onUnload <- function(libpath)
    library.dynam.unload("asypow", libpath)


