.packageName <- "MCMCpack"
# sample from the posterior distribution of Wakefield's baseline model
# for ecological inference in R using linked C++ code in Scythe
#
# KQ 10/22/2002

"MCMCbaselineEI" <-
  function(r0, r1, c0, c1, burnin=1000, mcmc=50000, thin=10,
           tune=2.65316, verbose=FALSE, seed=0,
           alpha0=1, beta0=1, alpha1=1, beta1=1, method="NA",
           ...){


    # Error checking
    if (length(r0) != length(r1)){
      cat("length(r0) != length(r1).\n")
      stop("Please check data and try MCMCbaselineEI() again.\n")
    }

    if (length(r0) != length(c0)){
      cat("length(r0) != length(c0).\n")
      stop("Please check data and try MCMCbaselineEI() again.\n")  
     }

    if (length(r0) != length(c1)){
      cat("length(r0) != length(c1).\n")
      stop("Please check data and try MCMCbaselineEI() again.\n")
    }

    if (length(r1) != length(c0)){
      cat("length(r1) != length(c0).\n")
      stop("Please check data and try MCMCbaselineEI() again.\n")
    }
    if (length(r1) != length(c1)){
      cat("length(r1) != length(c1).\n")
      stop("Please check data and try MCMCbaselineEI() again.\n")
    }
    
    if (length(c0) != length(c1)){
      cat("length(c0) != length(c1).\n")
      stop("Please check data and try MCMCbaselineEI() again.\n")
    }

    if (min((r0+r1) == (c0+c1))==0){
      cat("Rows and columns do not sum to same thing.\n")
      stop("Please check data and try MCMCbaselineEI() again.\n")
    }

    check.parameters(burnin, mcmc, thin, "MCMCbaselineEI()", tune)
 
    if (alpha0 <= 0 ){
      cat("Parameter alpha0 <= 0.\n")
      stop("Please respecify and try MCMCbaselineEI() again.\n")
    }

    if (beta0 <= 0 ){
      cat("Parameter beta0 <= 0.\n")
      stop("Please respecify and try MCMCbaselineEI() again.\n")
    }

    if (alpha1 <= 0 ){
      cat("Parameter alpha1 <= 0.\n")
      stop("Please respecify and try MCMCbaselineEI() again.\n")
    }

    if (beta1 <= 0 ){
      cat("Parameter beta1 <= 0.\n")
      stop("Please respecify and try  MCMCbaselineEI() again.\n")
    }

    if (!(method %in% c("DA", "NA")) ){
      cat("Parameter method not DA or NA.\n")
      stop("Please respecify and try MCMCbaselineEI() again.\n")
    }

    # setup matrix to hold output from sampling
    ntables = length(r0)
    sample <- matrix(0, mcmc/thin, ntables*4)

    # call C++ code to do the sampling
    if (method=="NA"){
      C.sample <- .C("baselineNA",
                     samdata = as.double(sample),
                     samrow = as.integer(nrow(sample)),
                     samcol = as.integer(ncol(sample)),
                     r0 = as.double(r0),
                     r1 = as.double(r1),
                     c0 = as.double(c0),
                     c1 = as.double(c1),
                     ntables = as.integer(ntables),
                     burnin = as.integer(burnin),
                     mcmc = as.integer(mcmc),
                     thin = as.integer(thin),
                     alpha0 = as.double(alpha0),
                     beta0 = as.double(beta0),
                     alpha1 = as.double(alpha1),
                     beta1 = as.double(beta1),
                     verbose = as.integer(verbose),
                     tune = as.double(tune),
                     seed = as.integer(seed),
                     accepts = as.integer(0),
                     PACKAGE="MCMCpack"
                     )
    }
    else if (method=="DA"){
      C.sample <- .C("baselineDA",
                     samdata = as.double(sample),
                     samrow = as.integer(nrow(sample)),
                     samcol = as.integer(ncol(sample)),
                     r0 = as.double(r0),
                     r1 = as.double(r1),
                     c0 = as.double(c0),
                     c1 = as.double(c1),
                     ntables = as.integer(ntables),
                     burnin = as.integer(burnin),
                     mcmc = as.integer(mcmc),
                     thin = as.integer(thin),
                     alpha0 = as.double(alpha0),
                     beta0 = as.double(beta0),
                     alpha1 = as.double(alpha1),
                     beta1 = as.double(beta1),
                     verbose = as.integer(verbose),
                     seed = as.integer(seed),
                     PACKAGE="MCMCpack"
                     )
    }
    
    sample <- matrix(C.sample$samdata, C.sample$samrow, C.sample$samcol,
                     byrow=TRUE)
    if (method=="NA"){
      sample <- sample[,1:(ntables*2)]
      output <- mcmc2(data=sample, start=1, end=mcmc, thin=thin)
      p0names <- paste("p0table", 1:ntables, sep="")
      p1names <- paste("p1table", 1:ntables, sep="")
      varnames(output) <- c(p0names, p1names)
      cat(" Overall acceptance rate = ",
          C.sample$accepts / (C.sample$burnin+C.sample$mcmc) / ntables, "\n")
    }
    else{
      output <- mcmc2(data=sample, start=1, end=mcmc, thin=thin)
      p0names <- paste("p0table", 1:ntables, sep="")
      p1names <- paste("p1table", 1:ntables, sep="")
      y0names <- paste("y0table", 1:ntables, sep="")
      y1names <- paste("y1table", 1:ntables, sep="")
      varnames(output) <- c(p0names, p1names, y0names, y1names)
    }
    
    attr(output, "title") <- paste("MCMCpack Wakefield's Baseline EI Model Posterior Density Sample, Method =", method)

    return(output)
    
  }
# sample from the posterior of Quinn's dynamic ecological inference model
# in R using linked C++ code in Scythe
#
# KQ 10/25/2002

"MCMCdynamicEI" <-
  function(r0, r1, c0, c1, burnin=5000, mcmc=200000,
           thin=200, tune=2.65316, verbose=FALSE, seed=0,
           W=0, nu0=1, delta0=0.03, nu1=1,
           delta1=0.03, ...){
    
    # Error checking
    if (length(r0) != length(r1)){
      cat("length(r0) != length(r1).\n")
      stop("Please check data and try MCMCdynamicEI() again.\n")
    }

    if (length(r0) != length(c0)){
      cat("length(r0) != length(c0).\n")
      stop("Please check data and try MCMCdynamicEI() again.\n")
    }

    if (length(r0) != length(c1)){
      cat("length(r0) != length(c1).\n")
      stop("Please check data and try MCMCdynamicEI() again.\n")
    }

    if (length(r1) != length(c0)){
      cat("length(r1) != length(c0).\n")
      stop("Please check data and try MCMCdynamicEI() again.\n")
    }

    if (length(r1) != length(c1)){
      cat("length(r1) != length(c1).\n")
      stop("Please check data and try MCMCdynamicEI() again.\n")
    }

    if (length(c0) != length(c1)){
      cat("length(c0) != length(c1).\n")
      stop("Please check data and try MCMCdynamicEI() again.\n")
    }

    if (min((r0+r1) == (c0+c1))==0){
      cat("Rows and columns do not sum to same thing.\n")
      stop("Please check data and try MCMCdynamicEI() again.\n")
    }

    check.parameters(burnin, mcmc, thin, "MCMCdynamicEI", tune)
    
    if (nu0 <= 0 ){
      cat("Parameter nu0 <= 0.\n")
      stop("Please respecify and try MCMCdynamicEI() again.\n")
    }
    
    if (delta0 <= 0 ){
      cat("Parameter delta0 <= 0.\n")
      stop("Please respecify and try MCMCdynamicEI() again.\n")
    }
    
    if (nu1 <= 0 ){
      cat("Parameter nu1 <= 0.\n")
      stop("Please respecify and try MCMCdynamicEI() again.\n")
    }
    
    if (delta1 <= 0 ){
      cat("Parameter delta1 <= 0.\n")
      stop("Please respecify and try MCMCdynamicEI() again.\n")
    }
    
    ntables = length(r0)
    
    if (W==0){ # construct weight matrix for a simple random walk assuming
               # tables are temporally ordered and 1 time unit apart
      W <- matrix(0, ntables, ntables)
      for (i in 2:(ntables)){
        W[i,i-1] <- 1
        W[i-1,i] <- 1
      }
    }

    # setup matrix to hold output from sampling
    sample <- matrix(0, mcmc/thin, ntables*2+2)

    # call C++ code to do the sampling
    C.sample <- .C("dynamicEI",
                   samdata = as.double(sample),
                   samrow = as.integer(nrow(sample)),
                   samcol = as.integer(ncol(sample)),
                   r0 = as.double(r0),
                   r1 = as.double(r1),
                   c0 = as.double(c0),
                   c1 = as.double(c1),
                   ntables = as.integer(ntables),
                   burnin = as.integer(burnin),
                   mcmc = as.integer(mcmc),
                   thin = as.integer(thin),
                   W = as.double(W),
                   nu0 = as.double(nu0),
                   delta0 = as.double(delta0),
                   nu1 = as.double(nu1),
                   delta1 = as.double(delta1),
                   verbose = as.integer(verbose),
                   tune = as.double(tune),
                   seed = as.integer(seed),
                   accepts = as.integer(0),
                   PACKAGE="MCMCpack"
                   )

    cat(" Overall acceptance rate = ",
        C.sample$accepts / (C.sample$burnin+C.sample$mcmc) / ntables, "\n")
    
    sample <- matrix(C.sample$samdata, C.sample$samrow, C.sample$samcol,
                     byrow=TRUE)
    output <- mcmc2(data=sample, start=1, end=mcmc, thin=thin)
    p0names <- paste("p0table", 1:ntables, sep="")
    p1names <- paste("p1table", 1:ntables, sep="")
    varnames(output) <- c(p0names, p1names, "sigma^2_0", "sigma^2_1")
    
    attr(output, "title") <- "MCMCpack Quinn's Dynamic EI Model Posterior Density Sample" 
    
    
    return(output)
    
  }
##########################################################################
# sample from the posterior distribution of a factor analysis model
# model in R using linked C++ code in Scythe.
#
# The model is:
#
# x_i = \Lambda \phi_i + \epsilon_i,   \epsilon_i \sim N(0, \Psi)
#
# where \Psi is diagonal and the priors are:
#
# \lambda_{ij} \sim N(l_{ij}, L^{-1}_{ij})
# \phi_i \sim N(0,I)
# \psi^2_{jj} \sim IG(a0_j/2, b0_j/2)
#
#
# Andrew D. Martin
# Washington University
#
# Kevin M. Quinn
# Harvard University
#
# May 7, 2003
#
##########################################################################

"MCMCfactanal" <-
  function(x, factors, lambda.constraints=list(),
           data=list(), burnin = 1000, mcmc = 10000,
           thin=5, verbose = FALSE, seed = 0,
           lambda.start = NA, psi.start = NA,
           l0=0, L0=0, a0=0.001, b0=0.001,
           store.scores = FALSE, std.var=TRUE, ... ) {
    
    # extract X and variable names from the model formula and frame       
    if (is.matrix(x)){
      X <- x
      xvars <- dimnames(X)[[2]]
      xobs <- dimnames(X)[[1]]
      N <- nrow(X)
      K <- ncol(X)
      if (std.var){
        for (i in 1:K){
          X[,i] <- (X[,i]-mean(X[,i]))/sd(X[,i])
        }
      }
      else{
        for (i in 1:K){
          X[,i] <- X[,i]-mean(X[,i])
        }
      }
    }
    else {
      call <- match.call()
      mt <- terms(x, data=data)
      if (attr(mt, "response") > 0) 
        stop("Response not allowed in formula in MCMCfactanal().\n")
      if(missing(data)) data <- sys.frame(sys.parent())
      mf <- match.call(expand.dots = FALSE)
      mf$factors <- mf$lambda.constraints <- mf$burnin <- mf$mcmc <- NULL
      mf$thin <- mf$verbose <- mf$seed <- NULL
      mf$lambda.start <- mf$psi.start <- mf$l0 <- mf$L0 <- NULL
      mf$a0 <- mf$b0 <- mf$store.scores <- mf$std.var <- mf$... <- NULL
      mf$drop.unused.levels <- TRUE
      mf[[1]] <- as.name("model.frame")
      mf <- eval(mf, sys.frame(sys.parent()))
      
      attributes(mt)$intercept <- 0
      X <- model.matrix(mt, mf, contrasts)
      X <- as.matrix(X)         # X matrix
      xvars <- dimnames(X)[[2]] # X variable names
      xobs <- dimnames(X)[[1]]  # observation names
      N <- nrow(X)	      # number of observations      
      K <- ncol(X)              # number of manifest variables

      # standardize X
      if (std.var){
        for (i in 1:K){
          X[,i] <- (X[,i]-mean(X[,i]))/sd(X[,i])
        }
      }
      else{
        for (i in 1:K){
          X[,i] <- X[,i]-mean(X[,i])
        }
      }
    }
    
    if (is.null(xobs)){
      xobs <- 1:N
    }

    check.parameters(burnin, mcmc, thin, "MCMCfactanal")
      
    # give names to the rows of Lambda related matrices
    Lambda.eq.constraints <- matrix(NA, K, factors)
    Lambda.ineq.constraints <- matrix(0, K, factors)
    Lambda.prior.mean <- matrix(0, K, factors)
    Lambda.prior.prec <- matrix(0, K, factors)

  
    if (is.null(colnames(X))){
      rownames(Lambda.eq.constraints) <- paste("V", 1:ncol(X), sep="") 
      rownames(Lambda.ineq.constraints) <- paste("V", 1:ncol(X), sep="")
      rownames(Lambda.prior.mean) <- paste("V", 1:ncol(X), sep="")
      rownames(Lambda.prior.prec) <- paste("V", 1:ncol(X), sep="")
      X.names <- paste("V", 1:ncol(X), sep="")
    }
    if (!is.null(colnames(X))){
      rownames(Lambda.eq.constraints) <- colnames(X)
      rownames(Lambda.ineq.constraints) <- colnames(X)
      rownames(Lambda.prior.mean) <- colnames(X)
      rownames(Lambda.prior.prec) <- colnames(X)
      X.names <- colnames(X)
    }
    
    # setup the equality and inequality contraints on Lambda
    if (length(lambda.constraints) != 0){
      constraint.names <- names(lambda.constraints)  
      for (i in 1:length(constraint.names)){
        name.i <- constraint.names[i]
        lambda.constraints.i <- lambda.constraints[[i]]
        col.index <- lambda.constraints.i[[1]]
        replace.element <- lambda.constraints.i[[2]]
        if (is.numeric(replace.element)){
          Lambda.eq.constraints[rownames(Lambda.eq.constraints)==name.i,
                                col.index] <- replace.element
        }
        if (replace.element=="+"){
          Lambda.ineq.constraints[rownames(Lambda.ineq.constraints)==name.i,
                                  col.index] <- 1
        }
        if (replace.element=="-"){
          Lambda.ineq.constraints[rownames(Lambda.ineq.constraints)==name.i,
                                  col.index] <- -1
        }
      }
    }
    
    testmat <- Lambda.ineq.constraints * Lambda.eq.constraints

    if (min(is.na(testmat))==0){
      if ( min(testmat[!is.na(testmat)]) < 0){
        cat("Constraints on Lambda are logically inconsistent.\n")
        stop("Please respecify and call MCMCfactanal() again.\n")
      }
    }
    Lambda.eq.constraints[is.na(Lambda.eq.constraints)] <- -999
    
    
    # setup prior means and precisions for Lambda
    # prior means
    if (is.matrix(l0)){ # matrix input for l0
      if (nrow(l0)==K && ncol(l0)==factors)
        Lambda.prior.mean <- l0
      else {
        cat("l0 not of correct size for model specification.\n")
        stop("Please respecify and call MCMCfactanl() again.\n")
      }
    }
    else if (is.list(l0)){ # list input for l0
      l0.names <- names(l0)
      for (i in 1:length(l0.names)){
        name.i <- l0.names[i]
        l0.i <- l0[[i]]
        col.index <- l0.i[[1]]
        replace.element <- l0.i[[2]]
        if (is.numeric(replace.element)){
          Lambda.prior.mean[rownames(Lambda.prior.mean)==name.i,
                            col.index] <- replace.element
        }   
      }
    }
    else if (length(l0)==1 && is.numeric(l0)){ # scalar input for l0
      Lambda.prior.mean <- matrix(l0, K, factors)
    }
    else {
      cat("l0 neither matrix, list, nor scalar.\n")
      stop("Please respecify and call MCMCfactanal() again.\n")
    }
    # prior precisions
    if (is.matrix(L0)){ # matrix input for L0
      if (nrow(L0)==K && ncol(L0)==factors)
        Lambda.prior.prec <- L0
      else {
        cat("L0 not of correct size for model specification.\n")
        stop("Please respecify and call MCMCfactanl() again.\n")
      }
    }
    else if (is.list(L0)){ # list input for L0
      L0.names <- names(L0)
      for (i in 1:length(L0.names)){
        name.i <- L0.names[i]
        L0.i <- L0[[i]]
        col.index <- L0.i[[1]]
        replace.element <- L0.i[[2]]
        if (is.numeric(replace.element)){
          Lambda.prior.prec[rownames(Lambda.prior.prec)==name.i,
                            col.index] <- replace.element
        }   
      }
    }
    else if (length(L0)==1 && is.numeric(L0)){ # scalar input for L0
      Lambda.prior.prec <- matrix(L0, K, factors)
    }
    else {
      cat("L0 neither matrix, list, nor scalar.\n")
      stop("Please respecify and call MCMCfactanal() again.\n")
    }
    if (min(L0) < 0) {
      cat("L0 contains negative elements.\n")
      stop("Please respecify and call MCMCfactanal() again.\n")
    }
    
    # Starting values for Lambda
    Lambda <- matrix(0, K, factors)
    if (is.na(lambda.start)){# sets Lambda to equality constraints & 0s
      for (i in 1:K){
        for (j in 1:factors){
          if (Lambda.eq.constraints[i,j]==-999){
            if(Lambda.ineq.constraints[i,j]==0){
              Lambda[i,j] <- 0
            }
            if(Lambda.ineq.constraints[i,j]>0){
              Lambda[i,j] <- .5
            }
            if(Lambda.ineq.constraints[i,j]<0){
              Lambda[i,j] <- -.5
            }          
          }
          else Lambda[i,j] <- Lambda.eq.constraints[i,j]
        }
      }    
    }
    else if (is.matrix(lambda.start)){
      if (nrow(lambda.start)==K && ncol(lambda.start)==factors)
        Lambda  <- lambda.start
      else {
        cat("lambda.start not of correct size for model specification.\n")
        stop("Please respecify and call MCMCfactanal() again.\n")
      }
    }
    else if (length(lambda.start)==1 && is.numeric(lambda.start)){
      Lambda <- matrix(lambda.start, K, factors)
      for (i in 1:K){
        for (j in 1:factors){
          if (Lambda.eq.constraints[i,j] != -999)
            Lambda[i,j] <- Lambda.eq.constraints[i,j]
        }
      }    
    }
    else {
      cat("lambda.start neither NA, matrix, nor scalar.\n")
      stop("Please respecify and call MCMCfactanal() again.\n")
    }
    
    # starting values for Psi
    if (is.na(psi.start)){
      Psi <- diag(K)*0.5
    }
    else if (is.double(psi.start))
      Psi <- diag(K) * psi.start
    else {
      cat("psi.start neither NA, nor double.\n")
      stop("Please respecify and call MCMCfactanal() again.\n")
    }
    if (nrow(Psi) != K || ncol(Psi) != K){
      cat("Psi starting value not K by K matrix.\n")
      stop("Please respecify and call MCMCfactanal() again.\n")    
    }
    
    # setup prior for diag(Psi)
    if (length(a0)==1 && is.double(a0))
      a0 <- matrix(a0, K, 1)
    else if (length(a0) == K && is.double(a0))
      a0 <- matrix(a0, K, 1)
    else {
      cat("a0 not properly specified.\n")
      stop("Please respecify and call MCMCfactanal() again.\n")
    }
    if (length(b0)==1 && is.double(b0))
      b0 <- matrix(b0, K, 1)
    else if (length(b0) == K && is.double(b0))
      b0 <- matrix(b0, K, 1)
    else {
      cat("b0 not properly specified.\n")
      stop("Please respecify and call MCMCfactanal() again.\n")
    }
    
    # prior for Psi error checking
    if(min(a0) <= 0) {
      cat("IG(a0/2,b0/2) prior parameter a0 less than or equal to zero.\n")
      stop("Please respecify and call MCMCfactanal() again.\n")
    }
    if(min(b0) <= 0) {
      cat("IG(a0/2,b0/2) prior parameter b0 less than or equal to zero.\n")
      stop("Please respecify and call MCMCfactanal() again.\n")      
    }  
    
    # define holder for posterior density sample
    if(store.scores == FALSE) {
      sample <- matrix(data=0, mcmc/thin, K*factors+K)
    }
    else {
      sample <- matrix(data=0, mcmc/thin, K*factors+K+factors*N)
    }

    # Call the C++ code to do the real work
    posterior <- .C("factanalpost",
                    samdata = as.double(sample),
                    samrow = as.integer(nrow(sample)),
                    samcol = as.integer(ncol(sample)),
                    X = as.double(X),
                    Xrow = as.integer(nrow(X)),
                    Xcol = as.integer(ncol(X)),
                    burnin = as.integer(burnin),
                    mcmc = as.integer(mcmc),
                    thin = as.integer(thin),
                    seed = as.integer(seed),
                    verbose = as.integer(verbose),
                    Lambda = as.double(Lambda),
                    Lambdarow = as.integer(nrow(Lambda)),
                    Lambdacol = as.integer(ncol(Lambda)),
                    Psi = as.double(Psi),
                    Psirow = as.integer(nrow(Psi)),
                    Psicol = as.integer(ncol(Psi)),
                    Lameq = as.double(Lambda.eq.constraints),
                    Lameqrow = as.integer(nrow(Lambda.eq.constraints)),
                    Lameqcol = as.integer(ncol(Lambda.ineq.constraints)),
                    Lamineq = as.double(Lambda.ineq.constraints),
                    Lamineqrow = as.integer(nrow(Lambda.ineq.constraints)),
                    Lamineqcol = as.integer(ncol(Lambda.ineq.constraints)),
                    Lampmean = as.double(Lambda.prior.mean),
                    Lampmeanrow = as.integer(nrow(Lambda.prior.mean)),
                    Lampmeancol = as.integer(ncol(Lambda.prior.prec)),
                    Lampprec = as.double(Lambda.prior.prec),
                    Lampprecrow = as.integer(nrow(Lambda.prior.prec)),
                    Lamppreccol = as.integer(ncol(Lambda.prior.prec)),
                    a0 = as.double(a0),
                    a0row = as.integer(nrow(a0)),
                    a0col = as.integer(ncol(a0)),
                    b0 = as.double(b0),
                    b0row = as.integer(nrow(b0)),
                    b0col = as.integer(ncol(b0)),
                    storescores = as.integer(store.scores),
                    PACKAGE="MCMCpack"
                    )
    
    # put together matrix and build MCMC object to return
    sample <- matrix(posterior$samdata, posterior$samrow, posterior$samcol,
                     byrow=TRUE)
    output <- mcmc2(data=sample,start=1, end=mcmc, thin=thin)
    
    Lambda.names <- paste(paste("Lambda",
                                rep(X.names,
                                    each=factors), sep=""),
                          rep(1:factors,K), sep="_")
    
    
    Psi.names <- paste("Psi", X.names, sep="")
    par.names <- c(Lambda.names, Psi.names)
    if (store.scores==TRUE){
      phi.names <- paste(paste("phi",
                               rep(xobs, each=factors), sep="_"),
                         rep(1:factors,factors), sep="_")
      par.names <- c(par.names, phi.names)
    }
    varnames(output) <- par.names

    # get rid of columns for constrained parameters
    output.df <- mcmc2dataframe(output)
    output.var <- diag(var(output.df))
    output.df <- output.df[,output.var != 0]
    
    output <- mcmc2(as.matrix(output.df), start=1, end=mcmc, thin=thin)

    # add constraint info so this isn't lost
    attr(output, "constraints") <- lambda.constraints
    attr(output, "n.manifest") <- K
    attr(output, "n.factors") <- factors
    
    attr(output,"title") <-
      "MCMCpack Factor Analysis Posterior Density Sample"
    return(output)
    
  }
# sample from the posterior distribution of Wakefield's baseline model
# for ecological inference in R using linked C++ code in Scythe
#
# KQ 10/22/2002

"MCMChierEI" <-
  function(r0, r1, c0, c1, burnin=1000, mcmc=50000, thin=1,
           m0=0, M0=10,
           m1=0, M1=10,
           nu0=1.0, delta0=0.5,
           nu1=1.0, delta1=0.5,
           verbose=FALSE, tune=2.65316, seed=0, ...){
    
    # Error checking
    if (length(r0) != length(r1)){
      cat("length(r0) != length(r1).\n")
      stop("Please check data and try MCMChierEI() again.\n")
    }

    if (length(r0) != length(c0)){
      cat("length(r0) != length(c0).\n")
      stop("Please check data and try MCMChierEI() again.\n")
    }
    
    if (length(r0) != length(c1)){
      cat("length(r0) != length(c1).\n")
      stop("Please check data and try MCMChierEI() again.\n")
    }
    
    if (length(r1) != length(c0)){
      cat("length(r1) != length(c0).\n")
      stop("Please check data and try MCMChierEI() again.\n")
    }
    
    if (length(r1) != length(c1)){
      cat("length(r1) != length(c1).\n")
      stop("Please check data and try MCMChierEI() again.\n")
    }
    
    if (length(c0) != length(c1)){
      cat("length(c0) != length(c1).\n")
      stop("Please check data and try MCMChierEI() again.\n")
    }
    
    if (min((r0+r1) == (c0+c1))==0){
      cat("Rows and columns do not sum to same thing.\n")
      stop("Please check data and try MCMChierEI() again.\n")
    }

    check.parameters(burnin, mcmc, thin, "MCMChierEI", tune)
    
    if (M0 <= 0 ){
      cat("Parameter M0 <= 0.\n")
      stop("Please respecify and try MCMChierEI() again.\n")
    }
    
    if (M1 <= 0 ){
      cat("Parameter M1 <= 0.\n")
      stop("Please respecify and try MCMChierEI() again.\n")
    }
    
    if (nu0 <= 0 ){
      cat("Parameter nu0 <= 0.\n")
      stop("Please respecify and try MCMChierEI() again.\n")
    }
    
    if (nu1 <= 0 ){
      cat("Parameter nu1 <= 0.\n")
      stop("Please respecify and try MCMChierEI() again.\n")
    }
    
    if (delta0 <= 0 ){
      cat("Parameter delta0 <= 0.\n")
      stop("Please respecify and try MCMChierEI() again.\n")
    }
    
    if (delta1 <= 0 ){
      cat("Parameter delta1 <= 0.\n")
      stop("Please respecify and try MCMChierEI() again.\n")
    }
   
    # setup matrix to hold output from sampling
    ntables = length(r0)
    sample <- matrix(0, mcmc/thin, ntables*2+4)

    # call C++ code to do the sampling
    C.sample <- .C("hierEI",
                   samdata = as.double(sample),
                   samrow = as.integer(nrow(sample)),
                   samcol = as.integer(ncol(sample)),
                   r0 = as.double(r0),
                   r1 = as.double(r1),
                   c0 = as.double(c0),
                   c1 = as.double(c1),
                   ntables = as.integer(ntables),
                   burnin = as.integer(burnin),
                   mcmc = as.integer(mcmc),
                   thin = as.integer(thin),
                   mu0priormean = as.double(m0),
                   mu0priorvar = as.double(M0),
                   mu1priormean = as.double(m1),
                   mu1priorvar = as.double(M1),
                   nu0 = as.double(nu0),
                   delta0 = as.double(delta0),
                   nu1 = as.double(nu1),
                   delta1 = as.double(delta1),
                   verbose = as.integer(verbose),
                   tune = as.double(tune),
                   seed = as.integer(seed),
                   accepts = as.integer(0),
                   PACKAGE="MCMCpack"
                   )

    cat(" Overall acceptance rate = ",
        C.sample$accepts / (C.sample$burnin+C.sample$mcmc) / ntables, "\n")
    
    sample <- matrix(C.sample$samdata, C.sample$samrow, C.sample$samcol,
                     byrow=TRUE)
    
    output <- mcmc2(data=sample, start=1, end=mcmc, thin=thin)
    p0names <- paste("p0table", 1:ntables, sep="")
    p1names <- paste("p1table", 1:ntables, sep="")
    varnames(output) <- c(p0names, p1names, "mu0", "mu1", "sigma^2.0",
                          "sigma^2.1")
    
    attr(output, "title") <- "MCMCpack Wakefield's Hierarchical EI Model Posterior Density Sample"
        
    return(output)
    
  }
# sample from the posterior distribution of a one-dimensional item
# response theory model in R using linked C++ code in Scythe.
#
# ADM and KQ 1/23/2003
 
"MCMCirt1d" <-
  function(datamatrix, theta.fixed = 1, burnin = 500, mcmc = 1000,
           thin=5, verbose = FALSE, seed = 0, theta.start = NA, 
           alpha.start = NA, beta.start = NA, t0 = 0, T0 = 1,
           b0.alpha = 0, b0.beta = 0, B0.alpha = 1, B0.beta = 1,
           B0.corr = 0, store.item = FALSE, ... ) {

    set.seed(83829)
    
    # burnin / mcmc / thin error checking
    check.parameters(burnin, mcmc, thin, "MCMCirt1d")

    # check vote matrix and convert to work with C++ code 
    datamatrix <- as.matrix(datamatrix)   
    K <- nrow(datamatrix)   # cases
    J <- ncol(datamatrix)   # justices
    if(sum(datamatrix==1 | datamatrix==0 | is.na(datamatrix)) != (J*K)) {
      cat("Data matrix contains elements other than 0, 1 or NA.\n")
      stop("Please check data and try MCMCirt1d() again.\n")
    }
    datamatrix[is.na(datamatrix)] <- 9   

    # starting values for theta error checking
    if (is.na(theta.start)) {
      theta.start <- as.matrix(rnorm(J,1))
    }
    else if(is.null(dim(theta.start))) {
      theta.start <- theta.start * matrix(1,J,1)  
    }
    else if((dim(theta.start)[1] != J) || (dim(theta.start)[2] != 1)) {
      cat("Starting value for theta not conformable.\n")
      stop("Please respecify and call MCMCirt1d() again.\n")
    }

    # starting values for alpha and beta error checking
    if (is.na(alpha.start)) {
      alpha.start <- as.matrix(rnorm(K,1))
    }
    else if(is.null(dim(alpha.start))) {
      alpha.start <- alpha.start * matrix(1,K,1)  
    }
    else if((dim(alpha.start)[1] != K) || (dim(alpha.start)[2] != 1)) {
      cat("Starting value for alpha not conformable.\n")
      stop("Please respecify and call MCMCirt1d() again.\n")
    }      
    if (is.na(beta.start)) {
      beta.start <- as.matrix(rnorm(K,1))
    }
    else if(is.null(dim(beta.start))) {
      beta.start <- beta.start * matrix(1,K,1)  
    }
    else if((dim(beta.start)[1] != K) || (dim(beta.start)[2] != 1)) {
      cat("Starting value for beta not conformable.\n")
      stop("Please respecify and call MCMCirt1d() again.\n")
    }    

    # theta fixed error checking / this is the index of the person
    # to constrain to be negative, which identifies the model
    theta.fixed <- as.integer(theta.fixed)
    if(theta.fixed < 1 || theta.fixed > J) {
      cat("Index of actor to fix is outside range.\n")
      stop("Please respecify and call MCMCirt1d() again.\n")      
    }

    # prior for theta error checking (mean)
    if(is.null(dim(t0))) {
      t0 <- t0 * matrix(1,J,1)  
    }
    if((dim(t0)[1] != J) || (dim(t0)[2] != 1)) {
      cat("Vector of prior means t0 not conformable.\n")
      stop("Please respecify and call MCMCirt1d() again.\n")
    }
   
    # prior for theta error checking (variance)
    if(is.null(dim(T0))) {
      T0 <- T0 * matrix(1,J,1)  
    }
    if((dim(T0)[1] != J) || (dim(T0)[2] != 1)) {
      cat("Vector of prior variances T0 not conformable.\n")
      stop("Please respecify and call MCMCirt1d() again.\n")
    }
    if(sum(T0 > 0) != J) {
      cat("Some Elements of Vector of prior variances T0 not conformable.\n")
      stop("Please respecify and call MCMCirt1d() again.\n")         
    }

    # prior for alpha and beta error checking (mean)
    if(is.null(dim(b0.alpha))) {
      b0.alpha <- b0.alpha * matrix(1,K,1)  
    }
    if((dim(b0.alpha)[1] != K) || (dim(b0.alpha)[2] != 1)) {
      cat("Vector of prior means b0.alpha not conformable.\n")
      stop("Please respecify and call MCMCirt1d() again.\n")
    }
    if(is.null(dim(b0.beta))) {
      b0.beta <- b0.beta * matrix(1,K,1)  
    }
    if((dim(b0.beta)[1] != K) || (dim(b0.beta)[2] != 1)) {
      cat("Vector of prior means b0.beta not conformable.\n")
      stop("Please respecify and call MCMCirt1d() again.\n")
    }
         
    # prior for alpha and beta error checking (variance)
    if(is.null(dim(B0.alpha))) {
      B0.alpha <- B0.alpha * matrix(1,K,1)  
    }
    if((dim(B0.alpha)[1] != K) || (dim(B0.alpha)[2] != 1)) {
      cat("Vector of prior variances B0.alpha not conformable.\n")
      stop("Please respecify and call MCMCirt1d() again.\n")
    }
    if(sum(B0.alpha > 0) != K) {
      cat("Elements of prior variances B0.alpha not conformable.\n")
      stop("Please respecify and call MCMCirt1d() again.\n")         
    }
    if(is.null(dim(B0.beta))) {
      B0.beta <- B0.beta * matrix(1,K,1)  
    }
    if((dim(B0.beta)[1] != K) || (dim(B0.beta)[2] != 1)) {
      cat("Elements of prior variances B0.beta not conformable.\n")
      stop("Please respecify and call MCMCirt1d() again.\n")
    }
    if(sum(B0.beta > 0) != K) {
      cat("Elements of prior variances B0.beta negative.\n")
      stop("Please respecify and call MCMCirt1d() again.\n")         
    }
   
    # prior for alpha and beta error checking (correlation)
    if(is.null(dim(B0.corr))) {
      B0.corr <- B0.corr * matrix(1,K,1)  
    }
    if((dim(B0.corr)[1] != K) || (dim(B0.corr)[2] != 1)) {
      cat("Vector of covariances alpha.b0.beta not conformable.\n")
      stop("Please respecify and call MCMCirt1d() again.\n")
    }
    if(sum(B0.corr >= -1.0 & B0.corr<=1.0) != K) {
      cat("Elements of prior correlations B0.corr not defined.\n")
      stop("Please respecify and call MCMCirt1d() again.\n")       
    }
    alpha.beta.cov <- B0.corr / (sqrt(B0.alpha) * sqrt(B0.beta))   
         
    # define holder for posterior density sample
    if(store.item == FALSE) {
      sample <- matrix(data=0, mcmc/thin, J)
    }
    else {
      sample <- matrix(data=0, mcmc/thin, J + 2 * K)
    }
   
    # call C++ code to draw sample
    inv.obj <- .C("irt1dpost",
                  samdata = as.double(sample),
                  samrow = as.integer(nrow(sample)),
                  samcol = as.integer(ncol(sample)),
                  votedata = as.double(datamatrix),
                  voterow = as.integer(nrow(datamatrix)),
                  votecol = as.integer(ncol(datamatrix)),    
                  burnin = as.integer(burnin),
                  gibbs = as.integer(mcmc),
                  thin = as.integer(thin),
                  seed = as.integer(seed),
                  verbose = as.integer(verbose),
                  tstartdata = as.double(theta.start),
                  tstartrow = as.integer(nrow(theta.start)),
                  tstartcol = as.integer(ncol(theta.start)),
                  thetafixed = as.integer(theta.fixed),
                  astartdata = as.double(alpha.start),
                  astartrow = as.integer(nrow(alpha.start)),
                  astartcol = as.integer(ncol(alpha.start)),
                  bstartdata = as.double(beta.start),
                  bstartrow = as.integer(nrow(beta.start)),
                  bstartcol = as.integer(ncol(beta.start)),
                  t0data = as.double(t0),
                  t0row = as.integer(nrow(t0)),
                  t0col = as.integer(ncol(t0)),   
                  T0data = as.double(T0),
                  T0row = as.integer(nrow(T0)),
                  T0col = as.integer(ncol(T0)),
                  ameandata = as.double(b0.alpha),
                  ameanrow = as.integer(nrow(b0.alpha)),
                  ameancol = as.integer(ncol(b0.alpha)),   
                  bmeandata = as.double(b0.beta),
                  bmeanrow = as.integer(nrow(b0.beta)),
                  bmeancol = as.integer(ncol(b0.beta)), 
                  avardata = as.double(B0.alpha),
                  avarrow = as.integer(nrow(B0.alpha)),
                  avarcol = as.integer(ncol(B0.alpha)), 
                  bvardata = as.double(B0.beta),
                  bvarrow = as.integer(nrow(B0.beta)),
                  bvarcol = as.integer(ncol(B0.beta)), 
                  abcovdata = as.double(alpha.beta.cov),
                  abcovrow = as.integer(nrow(alpha.beta.cov)),
                  abcovcol = as.integer(ncol(alpha.beta.cov)),
                  store = as.integer(store.item),
                  PACKAGE="MCMCpack"
                  )
    
    theta.names <- paste("theta", 1:J, sep = "")
    alpha.beta.names <- paste(rep(c("alpha","beta"), K), rep(1:K, each = 2),
                              sep = "")
   
    # put together matrix and build MCMC object to return
    sample <- matrix(inv.obj$samdata, inv.obj$samrow, inv.obj$samcol,
                     byrow=TRUE)
    output <- mcmc2(data=sample,start=1, end=mcmc, thin=thin)
   
    if(store.item == FALSE) {
      names <- theta.names
    }
    else {
      names <- c(theta.names, alpha.beta.names)
    }
    varnames(output) <- names
    attr(output,"title") <-
      "MCMCpack One Dimensional IRT Model Posterior Density Sample"
    return(output)
    
  }
##########################################################################
# sample from a K-dimensional two-parameter item response model with
# probit link. This is just a wrapper function that calls
# MCMCordfactanal.
#
# Andrew D. Martin
# Washington University
#
# Kevin M. Quinn
# Harvard University
#
# June 8, 2003
#
##########################################################################

"MCMCirtKd" <-
  function(datamatrix, dimensions, item.constraints=list(),
           burnin = 1000, mcmc = 10000,
           thin=5, verbose = FALSE, seed = 0,
           alphabeta.start = NA, b0=0, B0=0,
           store.item=FALSE, store.ability=TRUE,
           drop.constantvars=TRUE, ... ) {

    datamatrix <- t(as.matrix(datamatrix))   
    
    post <- MCMCordfactanal(x=datamatrix, factors=dimensions,
                            lambda.constraints=item.constraints,
                            burnin=burnin, mcmc=mcmc, thin=thin,
                            tune=NA, verbose=verbose, seed=seed,
                            lambda.start=alphabeta.start,
                            l0=b0, L0=B0, store.lambda=store.item,
                            store.scores=store.ability,
                            drop.constantvars=drop.constantvars,
                            drop.constantcases=drop.constantcases,
                            special.case="special.case")
    return(post)
  }

# sample from the posterior distribution of a logistic regression
# model in R using linked C++ code in Scythe
#
# KQ 1/23/2003
#
# note: B0 is now a precision

"MCMClogit" <-
  function(formula, data = list(), burnin = 1000, mcmc = 10000,
           thin=5, tune=1.1, verbose = FALSE, seed = 0, beta.start = NA,
           b0 = 0, B0 = 0.001, ...) {
  
    # extract X, Y, and variable names from the model formula and frame       
    call <- match.call()
    mt <- terms(formula, data=data)
    if(missing(data)) data <- sys.frame(sys.parent())
    mf <- match.call(expand.dots = FALSE)
    mf$seed <- mf$verbose <- mf$beta.start <- NULL
    mf$burnin <- mf$mcmc <- mf$thin <- mf$tune <- NULL
    mf$b0 <- mf$B0 <- mf$... <- NULL
    mf$drop.unused.levels <- TRUE
    mf[[1]] <- as.name("model.frame")
    mf <- eval(mf, sys.frame(sys.parent()))
    
    # null model support
    X <- if (!is.empty.model(mt)) model.matrix(mt, mf, contrasts)
    X <- as.matrix(X)         # X matrix
    xvars <- dimnames(X)[[2]] # X variable names
    Y <- as.matrix(model.response(mf, "numeric")) # Y matrix
    N <- nrow(X)	             # number of observations      
    K <- ncol(X)              # number of covariates
      
    # y \in {0, 1} error checking
    if (sum(Y!=0 & Y!=1) > 0) {
      cat("Elements of Y equal to something other than 0 or 1.\n")
      stop("Check data and call MCMClogit() again. \n") 
    }
   
    # burnin / mcmc / thin error checking
    check.parameters(burnin, mcmc, thin, "MCMClogit", tune)
   
    # starting values for beta error checking
    library(MASS)
    glm.out <- glm(formula, data=data, family=binomial(link=logit))
    m <- coef(glm.out)
    V <- vcov(glm.out)
    if (is.na(beta.start)) { # use MLEs
      beta.start <- matrix(m, K, 1)
    }
    else if(is.null(dim(beta.start))) {
      beta.start <- beta.start * matrix(1,K,1)  
    }
    else if((dim(beta.start)[1] != K) || (dim(beta.start)[2] != 1)) {
      cat("Starting value for beta not conformable.\n")
      stop("Please respecify and call MCMClogit() again.\n")
     }

    # prior for beta error checking
    if(is.null(dim(b0))) {
      b0 <- b0 * matrix(1,K,1)  
    }
    if((dim(b0)[1] != K) || (dim(b0)[2] != 1)) {
      cat("N(b0,B0^-1) prior b0 not conformable.\n")
      stop("Please respecify and call MCMClogit() again.\n")
    }
    if(is.null(dim(B0))) {
      B0 <- B0 * diag(K)    
    }
    if((dim(B0)[1] != K) || (dim(B0)[2] != K)) {
      cat("N(b0,B0^-1) prior B0 not conformable.\n")
      stop("Please respecify and call MCMClogit() again.\n") 
    }
   
    # define holder for posterior density sample
    sample <- matrix(data=0, mcmc/thin, dim(X)[2] )
  
    # call C++ code to draw sample
    posterior <- .C("logitpost",
                    samdata = as.double(sample),
                    samrow = as.integer(nrow(sample)),
                    samcol = as.integer(ncol(sample)),
                    Xdata = as.double(X),
                    Xrow = as.integer(nrow(X)),
                    Xcol = as.integer(ncol(X)),   
                    Ydata = as.double(Y),
                    Yrow = as.integer(nrow(Y)),
                    Ycol = as.integer(ncol(Y)),   
                    burnin = as.integer(burnin),
                    mcmc = as.integer(mcmc),
                    thin = as.integer(thin),
                    seed = as.integer(seed),
                    verbose = as.integer(verbose),
                    bstartdata = as.double(beta.start),
                    bstartrow = as.integer(nrow(beta.start)),
                    bstartcol = as.integer(ncol(beta.start)),
                    b0data = as.double(b0),
                    b0row = as.integer(nrow(b0)),
                    b0col = as.integer(ncol(b0)),   
                    B0data = as.double(B0),
                    B0row = as.integer(nrow(B0)),
                    B0col = as.integer(ncol(B0)),
                    mdata = as.double(m),
                    mrow = as.integer(length(m)),
                    mcol = as.integer(1),
                    Vdata = as.double(V),
                    Vrow = as.integer(nrow(V)),
                    Vcol = as.integer(ncol(V)),
                    tune = as.double(tune),
                    accepts = as.integer(0),
                    PACKAGE="MCMCpack"
                    )
    cat(" Overall acceptance rate = ",
        posterior$accepts / (posterior$burnin+posterior$mcmc), "\n")
  
    # put together matrix and build MCMC object to return
    sample <- matrix(posterior$samdata, posterior$samrow,
                     posterior$samcol, byrow=TRUE)
    output <- mcmc2(data=sample, start=1, end=mcmc, thin=thin)
    names <- c(xvars)
    varnames(output) <- names
    attr(output,"title") <-
      "MCMCpack Logistic Regression Posterior Density Sample"
    return(output)
    
  }

##########################################################################


##########################################################################
# sample from the posterior distribution of a factor analysis model
# model in R using linked C++ code in Scythe.
#
# The model is:
#
# x*_i = \Lambda \phi_i + \epsilon_i,   \epsilon_i \sim N(0, \Psi)
#
# \lambda_{ij} \sim N(l0_{ij}, L0^{-1}_{ij})
# \phi_i \sim N(0,I)
#
# and x*_i is the latent variable formed from the observed ordinal
# variable in the usual (Albert and Chib, 1993) way and is equal to
# x_i when x_i is continuous. When x_j is ordinal \Psi_jj is assumed
# to be 1.
#
# Andrew D. Martin
# Washington University
#
# Kevin M. Quinn
# Harvard University
#
# 12/2/2003
#
##########################################################################

"MCMCmixfactanal" <-
  function(x, factors, lambda.constraints=list(),
           data=list(), burnin = 1000, mcmc = 10000,
           thin=5, tune=NA, verbose = FALSE, seed = 0,
           lambda.start = NA, psi.start=NA,
           l0=0, L0=0, a0=0.001, b0=0.001,
           store.lambda=TRUE, store.scores=FALSE,
           std.mean=TRUE, std.var=TRUE, ... ) {
    
    call <- match.call()
    mt <- terms(x, data=data)
    if (attr(mt, "response") > 0) 
      stop("Response not allowed in formula in MCMCmixfactanal().\n")
    if(missing(data)) data <- sys.frame(sys.parent())
    mf <- match.call(expand.dots = FALSE)
    mf$factors <- mf$lambda.constraints <- mf$burnin <- mf$mcmc <- NULL
    mf$thin <- mf$tune <- mf$verbose <- mf$seed <- NULL
    mf$lambda.start <- mf$l0 <- mf$L0 <- mf$a0 <- mf$b0 <- NULL
    mf$store.lambda <- mf$store.scores <- mf$std.var <- mf$... <- NULL
    mf$drop.unused.levels <- TRUE
    mf[[1]] <- as.name("model.frame")
    mf <- eval(mf, sys.frame(sys.parent()))
    attributes(mt)$intercept <- 0
    Xterm.length <- length(attr(mt, "variables"))
    X <- subset(mf,
                select=as.character(attr(mt, "variables"))[2:Xterm.length])

    N <- nrow(X)	      # number of observations      
    K <- ncol(X)              # number of manifest variables
    ncat <- matrix(NA, K, 1)  # vector of number of categ. in each man. var. 
    for (i in 1:K){ 
      if (is.numeric(X[,i])){
        ncat[i] <- -999
        X[is.na(X[,i]), i] <- -999
      }
      else if (is.ordered(X[,i])){
        ncat[i] <- nlevels(X[,i])      
        X[,i] <- as.integer(X[,i])
        X[is.na(X[,i]), i] <- -999
      }
      else {
        stop("Manifest variable ", dimnames(X)[[2]][i],
             " neither ordered factor nor numeric variable.\n")
      }
    }
    
    X <- as.matrix(X)
    xvars <- dimnames(X)[[2]] # X variable names
    xobs <- dimnames(X)[[1]]  # observation names
    
    if (is.null(xobs)){
      xobs <- 1:N
    }

    # standardize X
    if (std.mean){
      for (i in 1:K){
        if (ncat[i] == -999){
          X[,i] <- X[,i]-mean(X[,i])
        }
      }
    }
    if (std.var){
      for (i in 1:K){
        if (ncat[i] == -999){
          X[,i] <- (X[,i])/sd(X[,i])
        }
      }
    }
     


    n.ord.ge3 <- 0
    for (i in 1:K)
      if (ncat[i] >= 3) n.ord.ge3 <- n.ord.ge3 + 1
    
    check.parameters(burnin, mcmc, thin, "MCMCmixfactanal()")


    
    # give names to the rows of Lambda related matrices
    Lambda.eq.constraints <- matrix(NA, K, factors+1)
    Lambda.ineq.constraints <- matrix(0, K, factors+1)
    Lambda.prior.mean <- matrix(0, K, factors+1)
    Lambda.prior.prec <- matrix(0, K, factors+1)
    
    if (is.null(colnames(X))){
      rownames(Lambda.eq.constraints) <- paste("V", 1:ncol(X), sep="") 
      rownames(Lambda.ineq.constraints) <- paste("V", 1:ncol(X), sep="")
      rownames(Lambda.prior.mean) <- paste("V", 1:ncol(X), sep="")
      rownames(Lambda.prior.prec) <- paste("V", 1:ncol(X), sep="")
      X.names <- paste("V", 1:ncol(X), sep="")
    }
    if (!is.null(colnames(X))){
      rownames(Lambda.eq.constraints) <- colnames(X)
      rownames(Lambda.ineq.constraints) <- colnames(X)
      rownames(Lambda.prior.mean) <- colnames(X)
      rownames(Lambda.prior.prec) <- colnames(X)
      X.names <- colnames(X)
    }
  
    # setup the equality and inequality contraints on Lambda
    if (length(lambda.constraints) != 0){
      constraint.names <- names(lambda.constraints)  
      for (i in 1:length(constraint.names)){
        name.i <- constraint.names[i]
        lambda.constraints.i <- lambda.constraints[[i]]
        col.index <- lambda.constraints.i[[1]]
        replace.element <- lambda.constraints.i[[2]]
        if (is.numeric(replace.element)){
          Lambda.eq.constraints[rownames(Lambda.eq.constraints)==name.i,
                                col.index] <- replace.element
        }
        if (replace.element=="+"){
          Lambda.ineq.constraints[rownames(Lambda.ineq.constraints)==name.i,
                                  col.index] <- 1
        }
        if (replace.element=="-"){
          Lambda.ineq.constraints[rownames(Lambda.ineq.constraints)==name.i,
                                  col.index] <- -1
        }
      }
    }

    # if subtracting out the mean of continuous X then constrain
    # the mean parameter to 0
    for (i in 1:K){
      if (ncat[i] < 2 && std.mean==TRUE){
        Lambda.eq.constraints[i,1] <- 0.0
      }
    }
    
    
    testmat <- Lambda.ineq.constraints * Lambda.eq.constraints
    
    if (min(is.na(testmat))==0){
      if ( min(testmat[!is.na(testmat)]) < 0){
          cat("Constraints on Lambda are logically inconsistent.\n")
        stop("Please respecify and call MCMCmixfactanal() again\n")
      }
    }
    Lambda.eq.constraints[is.na(Lambda.eq.constraints)] <- -999
    
    # setup prior means and precisions for Lambda
    # prior means
    if (is.matrix(l0)){ # matrix input for l0
      if (nrow(l0)==K && ncol(l0)==(factors+1))
        Lambda.prior.mean <- l0
      else {
        cat("l0 not of correct size for model specification.\n")
        stop("Please respecify and call MCMCmixfactanal() again\n")
      }
    }
    else if (is.list(l0)){ # list input for l0
      l0.names <- names(l0)
      for (i in 1:length(l0.names)){
        name.i <- l0.names[i]
        l0.i <- l0[[i]]
        col.index <- l0.i[[1]]
        replace.element <- l0.i[[2]]
        if (is.numeric(replace.element)){
          Lambda.prior.mean[rownames(Lambda.prior.mean)==name.i,
                            col.index] <- replace.element
        }   
      }
    }
    else if (length(l0)==1 && is.numeric(l0)){ # scalar input for l0
      Lambda.prior.mean <- matrix(l0, K, factors+1)
    }
    else {
      cat("l0 neither matrix, list, nor scalar.\n")
      stop("Please respecify and call MCMCmixfactanal() again\n")
    }
    
    # prior precisions
    if (is.matrix(L0)){ # matrix input for L0
      if (nrow(L0)==K && ncol(L0)==(factors+1))
        Lambda.prior.prec <- L0
      else {
        cat("L0 not of correct size for model specification.\n")
        stop("Please respecify and call MCMCmixfactanal() again\n")
      }
    }
    else if (is.list(L0)){ # list input for L0
      L0.names <- names(L0)
      for (i in 1:length(L0.names)){
        name.i <- L0.names[i]
        L0.i <- L0[[i]]
        col.index <- L0.i[[1]]
        replace.element <- L0.i[[2]]
        if (is.numeric(replace.element)){
          Lambda.prior.prec[rownames(Lambda.prior.prec)==name.i,
                            col.index] <- replace.element
        }   
      }
    }
    else if (length(L0)==1 && is.numeric(L0)){ # scalar input for L0
      Lambda.prior.prec <- matrix(L0, K, factors+1)
    }
    else {
      cat("L0 neither matrix, list, nor scalar.\n")
      stop("Please respecify and call MCMCmixfactanal() again\n")
    }
    if (min(L0) < 0){
      cat("L0 contains negative elements.\n")
      stop("Please respecify and call MCMCmixfactanal() again\n")
    }
    
    # Starting values for Lambda
    Lambda <- matrix(0, K, factors+1)
    if (is.na(lambda.start)){# sets Lambda to equality constraints & 0s
      for (i in 1:K){
        for (j in 1:(factors+1)){
          if (Lambda.eq.constraints[i,j]==-999){
            if(Lambda.ineq.constraints[i,j]==0){
              if (j==1){
                if (ncat[i] < 2){
                  Lambda[i,j] <- mean(X[,i]!=-999)
                }
                if (ncat[i] == 2){
                  probit.out <- glm(as.factor(X[X[,i]!=-999,i])~1,
                                    family=binomial(link=probit))
                  probit.beta <- coef(probit.out)
                  Lambda[i,j] <- probit.beta[1]
                }
                if (ncat[i] > 2){
                  polr.out <- polr(ordered(X[X[,i]!=-999,i])~1)
                  Lambda[i,j] <- -polr.out$zeta[1]*.588
                }
              }
            }
            if(Lambda.ineq.constraints[i,j]>0){
              Lambda[i,j] <- 1.0
            }
            if(Lambda.ineq.constraints[i,j]<0){
              Lambda[i,j] <- -1.0
            }          
          }
          else Lambda[i,j] <- Lambda.eq.constraints[i,j]
        }
      }    
    }
    else if (is.matrix(lambda.start)){
      if (nrow(lambda.start)==K && ncol(lambda.start)==(factors+1))
        Lambda  <- lambda.start
      else {
        cat("Starting values not of correct size for model specification.\n")
        stop("Please respecify and call ", echo.name, "() again\n")
      }
    }
    else if (length(lambda.start)==1 && is.numeric(lambda.start)){
      Lambda <- matrix(lambda.start, K, factors+1)
      for (i in 1:K){
        for (j in 1:(factors+1)){
          if (Lambda.eq.constraints[i,j] != -999)
            Lambda[i,j] <- Lambda.eq.constraints[i,j]
        }
      }    
    }
    else {
      cat("Starting values neither NA, matrix, nor scalar.\n")
      stop("Please respecify and call ", echo.name, "() again\n")
    }
    
    # check MH tuning parameter
    if (is.na(tune)){
      tune <- matrix(NA, K, 1)
      for (i in 1:K){
        tune[i] <- abs(0.05/ncat[i])
      }
    }
    else if (is.double(tune)){
      tune <- matrix(tune, K, 1)
    }
    if(min(tune) < 0) {
      cat("Tuning parameter is negative.\n")
      stop("Please respecify and call MCMCmixfactanal() again\n")
    }
  
    # starting values for gamma (note: not changeable by user)
    if (max(ncat) <= 2){
      gamma <- matrix(0, 3, K)
    }
    else {
      gamma <- matrix(0, max(ncat)+1, K)
    }
    for (i in 1:K){
      if (ncat[i]<=2){
        gamma[1,i] <- -300
        gamma[2,i] <- 0
        gamma[3,i] <- 300
      }
      if(ncat[i] > 2) {
        polr.out <- polr(ordered(X[X[,i]!=-999,i])~1)
        gamma[1,i] <- -300
        gamma[2,i] <- 0
        gamma[3:ncat[i],i] <- (polr.out$zeta[2:(ncat[i]-1)] -
                               polr.out$zeta[1])*.588
        gamma[ncat[i]+1,i] <- 300
      }
    }

    # starting value for Psi
    Psi <- matrix(0, K, K)
    if (is.na(psi.start)){
      for (i in 1:K){
        if (ncat[i] < 2) {
          Psi[i,i] <- 0.5 *var(X[,i])
        }
        else {
          Psi[i,i] <- 1.0
        }
      }
    }
    else if (is.double(psi.start)){
      for (i in 1:K){
        Psi <- diag(K) * psi.start
        if (ncat[i] >= 2) {
          Psi[i] <- 1.0
        }
      }
    }
    else {
      cat("psi.start neither NA, nor double.\n")
      stop("Please respecify and call MCMCmixfactanal() again.\n")
    }
    if (nrow(Psi) != K || ncol(Psi) != K){
      cat("Psi starting value not K by K matrix.\n")
      stop("Please respecify and call MCMCmixfactanal() again.\n")    
    }


    # setup prior for diag(Psi)
    if (length(a0)==1 && is.double(a0))
      a0 <- matrix(a0, K, 1)
    else if (length(a0) == K && is.double(a0))
      a0 <- matrix(a0, K, 1)
    else {
      cat("a0 not properly specified.\n")
      stop("Please respecify and call MCMCmixfactanal() again.\n")
    }
    if (length(b0)==1 && is.double(b0))
      b0 <- matrix(b0, K, 1)
    else if (length(b0) == K && is.double(b0))
      b0 <- matrix(b0, K, 1)
    else {
      cat("b0 not properly specified.\n")
      stop("Please respecify and call MCMCmixfactanal() again.\n")
    }
    
    # prior for Psi error checking
    if(min(a0) <= 0) {
      cat("IG(a0/2,b0/2) prior parameter a0 less than or equal to zero.\n")
      stop("Please respecify and call MCMCmixfactanal() again.\n")
    }
    if(min(b0) <= 0) {
      cat("IG(a0/2,b0/2) prior parameter b0 less than or equal to zero.\n")
      stop("Please respecify and call MCMCmixfactanal() again.\n")      
    }  
   
    
    # define holder for posterior density sample
    if (store.scores == FALSE && store.lambda == FALSE){
      sample <- matrix(data=0, mcmc/thin, length(gamma)+K)
    }
    else if (store.scores == TRUE && store.lambda == FALSE){
      sample <- matrix(data=0, mcmc/thin, (factors+1)*N + length(gamma)+K)
    }
    else if(store.scores == FALSE && store.lambda == TRUE) {
      sample <- matrix(data=0, mcmc/thin, K*(factors+1)+length(gamma)+K)
    }
    else { # store.scores==TRUE && store.lambda==TRUE
      sample <- matrix(data=0, mcmc/thin, K*(factors+1)+(factors+1)*N +
                       length(gamma)+K)
    }
    
    # Call the C++ code to do the real work
    posterior <- .C("mixfactanalpost",
                    samdata = as.double(sample),
                    samrow = as.integer(nrow(sample)),
                    samcol = as.integer(ncol(sample)),
                    X = as.double(X),
                    Xrow = as.integer(nrow(X)),
                    Xcol = as.integer(ncol(X)),
                    burnin = as.integer(burnin),
                    mcmc = as.integer(mcmc),
                    thin = as.integer(thin),
                    tune = as.double(tune),
                    seed = as.integer(seed),
                    verbose = as.integer(verbose),
                    Lambda = as.double(Lambda),
                    Lambdarow = as.integer(nrow(Lambda)),
                    Lambdacol = as.integer(ncol(Lambda)),
                    gamma = as.double(gamma),
                    gammarow = as.integer(nrow(gamma)),
                    gammacol = as.integer(ncol(gamma)),
                    Psi = as.double(Psi),
                    Psirow = as.integer(nrow(Psi)),
                    Psicol = as.integer(ncol(Psi)),
                    ncat = as.integer(ncat),
                    ncatrow = as.integer(nrow(ncat)),
                    ncatcol = as.integer(ncol(ncat)),
                    Lameq = as.double(Lambda.eq.constraints),
                    Lameqrow = as.integer(nrow(Lambda.eq.constraints)),
                    Lameqcol = as.integer(ncol(Lambda.ineq.constraints)),
                    Lamineq = as.double(Lambda.ineq.constraints),
                    Lamineqrow = as.integer(nrow(Lambda.ineq.constraints)),
                    Lamineqcol = as.integer(ncol(Lambda.ineq.constraints)),
                    Lampmean = as.double(Lambda.prior.mean),
                    Lampmeanrow = as.integer(nrow(Lambda.prior.mean)),
                    Lampmeancol = as.integer(ncol(Lambda.prior.prec)),
                    Lampprec = as.double(Lambda.prior.prec),
                    Lampprecrow = as.integer(nrow(Lambda.prior.prec)),
                    Lamppreccol = as.integer(ncol(Lambda.prior.prec)),
                    a0 = as.double(a0),
                    a0row = as.integer(nrow(a0)),
                    a0col = as.integer(ncol(a0)),
                    b0 = as.double(b0),
                    b0row = as.integer(nrow(b0)),
                    b0col = as.integer(ncol(b0)),
                    storelambda = as.integer(store.lambda),
                    storescores = as.integer(store.scores),
                    accepts = as.integer(0),
                    PACKAGE="MCMCpack"
                    )

    cat(" overall acceptance rate = ",
        posterior$accepts / ((posterior$burnin+posterior$mcmc)*n.ord.ge3), "\n")

    
    # put together matrix and build MCMC object to return
    sample <- matrix(posterior$samdata, posterior$samrow, posterior$samcol,
                     byrow=TRUE)
    output <- mcmc2(data=sample,start=1, end=mcmc, thin=thin)
    
    par.names <- NULL
    if (store.lambda==TRUE){
      Lambda.names <- paste(paste("Lambda",
                                  rep(X.names,
                                      each=(factors+1)), sep=""),
                            rep(1:(factors+1),K), sep=".")
      par.names <- c(par.names, Lambda.names)
    }
    
    gamma.names <- paste(paste("gamma",
                               rep(0:(nrow(gamma)-1),
                                   each=K), sep=""),
                         rep(X.names,  nrow(gamma)), sep=".")
    par.names <- c(par.names, gamma.names)
    
    if (store.scores==TRUE){
      phi.names <- paste(paste("phi",
                               rep(xobs, each=(factors+1)), sep="."),
                         rep(1:(factors+1),(factors+1)), sep=".")
      par.names <- c(par.names, phi.names)
    }

    Psi.names <- paste("Psi", X.names, sep=".")
    par.names <- c(par.names, Psi.names)
    
    varnames(output) <- par.names

    # get rid of columns for constrained parameters
    output.df <- mcmc2dataframe(output)
    output.var <- diag(var(output.df))
    output.df <- output.df[,output.var != 0]
    output <- mcmc2(as.matrix(output.df), start=1, end=mcmc, thin=thin)
    
    # add constraint info so this isn't lost
    attr(output, "constraints") <- lambda.constraints
    attr(output, "n.manifest") <- K
    attr(output, "n.factors") <- factors
    attr(output, "accept.rate") <- posterior$accepts /
      ((posterior$burnin+posterior$mcmc)*n.ord.ge3)
      attr(output,"title") <-
        "MCMCpack Mixed Data Factor Analysis Posterior Density Sample"
    
    return(output)
    
  }

# sample from the posterior distribution of an ordered probit model
# via the data augmentation approach of Cowles (1996)
#
# KQ 1/25/2003

"MCMCoprobit" <-
  function(formula, data = list(), burnin = 1000, mcmc = 10000,
           thin = 5, tune = NA, verbose = FALSE, seed = 0, beta.start = NA,
           b0 = 0, B0 = 0.001, ...) {
   
   # extract X, Y, and variable names from the model formula and frame
   call <- match.call()
   mt <- terms(formula, data=data)
   if(missing(data)) data <- sys.frame(sys.parent())
   mf <- match.call(expand.dots = FALSE)
   mf$burnin <- mf$mcmc <- mf$b0 <- mf$B0 <- NULL
   mf$thin <- mf$... <- mf$tune <- mf$verbose <- mf$seed <- NULL
   mf$beta.start <- NULL
   mf$drop.unused.levels <- TRUE
   mf[[1]] <- as.name("model.frame")
   mf <- eval(mf, sys.frame(sys.parent()))
   vars <- as.character(attr(mt, "variables"))[-1] # y varname and x varnames
   
   # null model support
   X <- if (!is.empty.model(mt)) model.matrix(mt, mf, contrasts)# else NULL
   X.names <- dimnames(X)[[2]]
   Y    <- model.response(mf, "numeric")
   Y    <- factor(Y, ordered=TRUE)
   ncat <- nlevels(Y)             # number of categories of y
   cat  <- levels(Y)              # values of categories of y
   N <- nrow(X)	                  # number of observations
   K <- ncol(X)	                  # number of covariates
   
   # convert data to matrices to be passed
   Y <- as.matrix(as.integer(Y))
   X <- as.matrix(X)
   
   # burnin / mcmc / thin error checking
   check.parameters(burnin, mcmc, thin, "MCMCoprobit", tune)
    
   # check tuning parameter
   if (is.na(tune)){
     tune <- 0.05/ncat
   }
 
   xint <- match("(Intercept)", colnames(X), nomatch=0)
   if (xint > 0){
     new.X <- X[, -xint, drop=FALSE]
   }
   else warning("An intercept is needed and assumed in MCMCoprobit()\n.")
   if (ncol(new.X) == 0){
     polr.out <- polr(ordered(Y)~1)
   }
   else {
     polr.out <- polr(ordered(Y)~new.X)
   }
   
   # starting values for beta error checking
   if (is.na(beta.start)){
     beta.start <- matrix(0, K, 1)
     beta.start[1] <- -.588 * polr.out$zeta[1]
     if( ncol(new.X) > 0){
       beta.start[2:K] <- .588 * coef(polr.out)
     }
   }
   else if(is.null(dim(beta.start))) {
     beta.start <- beta.start * matrix(1,K,1)  
   }
   else if((dim(beta.start)[1] != K) || (dim(beta.start)[2] != 1)) {
     cat("Starting value for beta not conformable.\n")
     stop("Please respecify and call MCMCoprobit() again.\n")
   }
   
   # prior for beta error checking
   if(is.null(dim(b0))) {
     b0 <- b0 * matrix(1,K,1)  
   }
   if((dim(b0)[1] != K) || (dim(b0)[2] != 1)) {
     cat("N(b0,B0) prior b0 not conformable.\n")
     stop("Please respecify and call MCMCoprobit() again.\n") 
   }   
   if(is.null(dim(B0))) {
     B0 <- B0 * diag(K)    
   }
   if((dim(B0)[1] != K) || (dim(B0)[2] != K)) {
     cat("N(b0,B0) prior B0 not conformable.\n")
     stop("Please respecify and call MCMCoprobit() again.\n")
   }

   # form gamma starting values (note: not changeable)
   gamma <- matrix(NA,ncat+1,1)
   gamma[1] <- -300
   gamma[2] <- 0
   gamma[3:ncat] <- (polr.out$zeta[2:(ncat-1)] - polr.out$zeta[1])*.588
   gamma[ncat+1] <- 300
      
   # posterior density sample
   sample <- matrix(data=0, mcmc/thin, K + ncat + 1)
   
   posterior <- .C("oprobitpost",
                   samdata = as.double(sample),
                   samrow = as.integer(nrow(sample)),
                   samcol = as.integer(ncol(sample)),
                   Ydata = as.integer(Y),
                   Yrow = as.integer(nrow(Y)),
                   Ycol = as.integer(ncol(Y)),   
                   Xdata = as.double(X),
                   Xrow = as.integer(nrow(X)),
                   Xcol = as.integer(ncol(X)),   
                   burnin = as.integer(burnin),
                   mcmc = as.integer(mcmc),
                   thin = as.integer(thin),
                   tune = as.double(tune),
                   seed = as.integer(seed),
                   verbose = as.integer(verbose),
                   bstartdata = as.double(beta.start),
                   bstartrow = as.integer(nrow(beta.start)),
                   bstartcol = as.integer(ncol(beta.start)),
                   gammadata = as.double(gamma),
                   gammarow = as.integer(nrow(gamma)),
                   gammacol = as.integer(ncol(gamma)),
                   b0data = as.double(b0),
                   b0row = as.integer(nrow(b0)),
                   b0col = as.integer(ncol(b0)),   
                   B0data = as.double(B0),
                   B0row = as.integer(nrow(B0)),
                   B0col = as.integer(ncol(B0)),
                   accepts = as.integer(0),
                   PACKAGE="MCMCpack"
                   )

   cat(" Overall acceptance rate = ",
       posterior$accepts / (posterior$burnin+posterior$mcmc), "\n")
   
   
   # put together matrix and build MCMC object to return
   sample <- matrix(posterior$samdata, posterior$samrow,
                    posterior$samcol, byrow=TRUE)
   sample <- sample[,c(1:K, (K+3):(K+ncat))]

   output <- mcmc2(data=sample, start=1, end=mcmc, thin=thin)
   names <- c(X.names, paste("gamma", 2:(ncat-1), sep=""))     
   varnames(output) <- names
   attr(output,"title") <-
     "MCMCpack Ordered Probit Posterior Density Sample"   
   return(output)
 }
##########################################################################
# sample from the posterior distribution of a factor analysis model
# model in R using linked C++ code in Scythe.
#
# The model is:
#
# x*_i = \Lambda \phi_i + \epsilon_i,   \epsilon_i \sim N(0, I)
#
# \lambda_{ij} \sim N(l0_{ij}, L0^{-1}_{ij})
# \phi_i \sim N(0,I)
#
# and x*_i is the latent variable formed from the observed ordinal
# variable in the usual (Albert and Chib, 1993) way.
#
# Andrew D. Martin
# Washington University
#
# Kevin M. Quinn
# Harvard University
#
# May 12, 2003
#
##########################################################################

"MCMCordfactanal" <-
  function(x, factors, lambda.constraints=list(),
           data=list(), burnin = 1000, mcmc = 10000,
           thin=5, tune=NA, verbose = FALSE, seed = 0,
           lambda.start = NA, l0=0, L0=0,
           store.lambda=TRUE, store.scores=FALSE,
           drop.constantvars=TRUE, drop.constantcases=FALSE,... ) {

    # check for MCMCirtKd special case, this is used to tell the R
    # and C++ code what to echo (1 if regular, 2 if MCMCirtKd)
    # the test is based on the existence of a string
    # "special.case" coming through the ellipses
    args <- list(...)

    if(length(args) > 0) test.string <- args[[1]][1]
    else test.string <- "xxx"
        
    if(test.string=="special.case") {
      case.switch <- 2
      echo.name <- "MCMCirtKd"
    }
    else {
      case.switch <- 1
      echo.name <- "MCMCordfactanal"
    } 
 
    # extract X and variable names from the model formula and frame       
    if (is.matrix(x)){
      if (drop.constantvars==TRUE){
        x.col.var <- apply(x, 2, var, na.rm=TRUE)
        x <- x[,x.col.var!=0]
        x.row.var <- apply(x, 1, var, na.rm=TRUE)
        x <- x[x.row.var!=0,]
      }
      X <- as.data.frame(x)
      xvars <- dimnames(X)[[2]]
      xobs <- dimnames(X)[[1]]
      N <- nrow(X)    # number of observations
      K <- ncol(X)    # number of manifest variables
      ncat <- matrix(NA, K, 1) # vector of number of categ. in each man. var. 
      for (i in 1:K){
        X[,i] <- factor(X[,i], ordered=TRUE)
        ncat[i] <- nlevels(X[,i])
        X[,i] <- as.integer(X[,i])
        X[is.na(X[,i]), i] <- -999
      }
      X <- as.matrix(X)
    }
    else {
      call <- match.call()
      mt <- terms(x, data=data)
      if (attr(mt, "response") > 0) 
        stop("Response not allowed in formula in ", echo.name, "().\n")
      if(missing(data)) data <- sys.frame(sys.parent())
      mf <- match.call(expand.dots = FALSE)
      mf$factors <- mf$lambda.constraints <- mf$burnin <- mf$mcmc <- NULL
      mf$thin <- mf$tune <- mf$verbose <- mf$seed <- NULL
      mf$lambda.start <- mf$l0 <- mf$L0 <- NULL
      mf$store.lambda <- mf$store.scores <- mf$drop.constantvars <- NULL
      mf$drop.constantcases <- mf$... <- NULL
      mf$drop.unused.levels <- TRUE
      mf[[1]] <- as.name("model.frame")
      mf <- eval(mf, sys.frame(sys.parent()))
      attributes(mt)$intercept <- 0
      Xterm.length <- length(attr(mt, "variables"))
      X <- subset(mf,
                  select=as.character(attr(mt, "variables"))[2:Xterm.length])
      if (drop.constantvars==TRUE){
        x.col.var <- apply(X, 2, var, na.rm=TRUE)
        X <- X[,x.col.var!=0]
      }
      if (drop.constantcases==TRUE){
        x.row.var <- apply(X, 1, var, na.rm=TRUE)
        X <- X[x.row.var!=0,]
      }
      N <- nrow(X)	        # number of observations      
      K <- ncol(X)              # number of manifest variables
      ncat <- matrix(NA, K, 1)  # vector of number of categ. in each man. var. 
      for (i in 1:K){
        X[,i] <- factor(X[,i], ordered=TRUE)
        ncat[i] <- nlevels(X[,i])      
        X[,i] <- as.integer(X[,i])
        X[is.na(X[,i]), i] <- -999
      }
      X <- as.matrix(X)
      xvars <- dimnames(X)[[2]] # X variable names
      xobs <- dimnames(X)[[1]]  # observation names
    }
    
    if (is.null(xobs)){
      xobs <- 1:N
    }

    
    check.parameters(burnin, mcmc, thin, echo.name)
    
    # give names to the rows of Lambda related matrices
    Lambda.eq.constraints <- matrix(NA, K, factors+1)
    Lambda.ineq.constraints <- matrix(0, K, factors+1)
    Lambda.prior.mean <- matrix(0, K, factors+1)
    Lambda.prior.prec <- matrix(0, K, factors+1)
    
    if (is.null(colnames(X))){
      rownames(Lambda.eq.constraints) <- paste("V", 1:ncol(X), sep="") 
      rownames(Lambda.ineq.constraints) <- paste("V", 1:ncol(X), sep="")
      rownames(Lambda.prior.mean) <- paste("V", 1:ncol(X), sep="")
      rownames(Lambda.prior.prec) <- paste("V", 1:ncol(X), sep="")
      X.names <- paste("V", 1:ncol(X), sep="")
    }
    if (!is.null(colnames(X))){
      rownames(Lambda.eq.constraints) <- colnames(X)
      rownames(Lambda.ineq.constraints) <- colnames(X)
      rownames(Lambda.prior.mean) <- colnames(X)
      rownames(Lambda.prior.prec) <- colnames(X)
      X.names <- colnames(X)
    }
  
    # setup the equality and inequality contraints on Lambda
    if (length(lambda.constraints) != 0){
      constraint.names <- names(lambda.constraints)  
      for (i in 1:length(constraint.names)){
        name.i <- constraint.names[i]
        lambda.constraints.i <- lambda.constraints[[i]]
        col.index <- lambda.constraints.i[[1]]
        replace.element <- lambda.constraints.i[[2]]
        if (is.numeric(replace.element)){
          Lambda.eq.constraints[rownames(Lambda.eq.constraints)==name.i,
                                col.index] <- replace.element
        }
        if (replace.element=="+"){
          Lambda.ineq.constraints[rownames(Lambda.ineq.constraints)==name.i,
                                  col.index] <- 1
        }
        if (replace.element=="-"){
          Lambda.ineq.constraints[rownames(Lambda.ineq.constraints)==name.i,
                                  col.index] <- -1
        }
      }
    }
    
    testmat <- Lambda.ineq.constraints * Lambda.eq.constraints
    
    if (min(is.na(testmat))==0){
      if ( min(testmat[!is.na(testmat)]) < 0){
        if(case.switch==1) {
          cat("Constraints on Lambda are logically inconsistent.\n")
        }
        else {
          cat("Constraints on item parameters are logically inconsistent.\n")
        }
        stop("Please respecify and call ", echo.name, "() again\n")
      }
    }
    Lambda.eq.constraints[is.na(Lambda.eq.constraints)] <- -999
    
    # setup prior means and precisions for Lambda
    # prior means
    if (is.matrix(l0)){ # matrix input for l0
      if (nrow(l0)==K && ncol(l0)==(factors+1))
        Lambda.prior.mean <- l0
      else {
        if(case.switch==1) {
          cat("l0 not of correct size for model specification.\n")
        }
        else {
          cat("b0 not of correct size for model specification.\n")
        }
        stop("Please respecify and call ", echo.name, "() again\n")
      }
    }
    else if (is.list(l0)){ # list input for l0
      l0.names <- names(l0)
      for (i in 1:length(l0.names)){
        name.i <- l0.names[i]
        l0.i <- l0[[i]]
        col.index <- l0.i[[1]]
        replace.element <- l0.i[[2]]
        if (is.numeric(replace.element)){
          Lambda.prior.mean[rownames(Lambda.prior.mean)==name.i,
                            col.index] <- replace.element
        }   
      }
    }
    else if (length(l0)==1 && is.numeric(l0)){ # scalar input for l0
      Lambda.prior.mean <- matrix(l0, K, factors+1)
    }
    else {
      if(case.switch==1) {    
        cat("l0 neither matrix, list, nor scalar.\n")
      }
      else {
        cat("b0 neither matrix, list, nor scalar.\n")      
      }
      stop("Please respecify and call ", echo.name, "() again\n")
    }
    
    # prior precisions
    if (is.matrix(L0)){ # matrix input for L0
      if (nrow(L0)==K && ncol(L0)==(factors+1))
        Lambda.prior.prec <- L0
      else {
        if(case.switch==1) {       
          cat("L0 not of correct size for model specification.\n")
        }
        else {
          cat("B0 not of correct size for model specification.\n")      
        }
        stop("Please respecify and call ", echo.name, "() again\n")
      }
    }
    else if (is.list(L0)){ # list input for L0
      L0.names <- names(L0)
      for (i in 1:length(L0.names)){
        name.i <- L0.names[i]
        L0.i <- L0[[i]]
        col.index <- L0.i[[1]]
        replace.element <- L0.i[[2]]
        if (is.numeric(replace.element)){
          Lambda.prior.prec[rownames(Lambda.prior.prec)==name.i,
                            col.index] <- replace.element
        }   
      }
    }
    else if (length(L0)==1 && is.numeric(L0)){ # scalar input for L0
      Lambda.prior.prec <- matrix(L0, K, factors+1)
    }
    else {
      if(case.switch==1) {  
        cat("L0 neither matrix, list, nor scalar.\n")
      }
      else {
        cat("B0 neither matrix, list, nor scalar.\n")      
      }
      stop("Please respecify and call ", echo.name, "() again\n")
    }
    if (min(L0) < 0){
      if(case.switch==1) {      
        cat("L0 contains negative elements.\n")
      }
      else {
        cat("B0 contains negative elements.\n")      
      }
      stop("Please respecify and call ", echo.name, "() again\n")
    }
    
    # Starting values for Lambda
    Lambda <- matrix(0, K, factors+1)
    if (is.na(lambda.start)){# sets Lambda to equality constraints & 0s
      for (i in 1:K){
        for (j in 1:(factors+1)){
          if (Lambda.eq.constraints[i,j]==-999){
            if(Lambda.ineq.constraints[i,j]==0){
              if (j==1){
                if (ncat[i] == 2){
                  probit.out <- glm(as.factor(X[X[,i]!=-999,i])~1,
                                    family=binomial(link=probit))
                  probit.beta <- coef(probit.out)
                  Lambda[i,j] <- probit.beta[1]
                }
                if (ncat[i] > 2){
                  polr.out <- polr(ordered(X[X[,i]!=-999,i])~1)
                  Lambda[i,j] <- -polr.out$zeta[1]*.588
                }
              }
            }
            if(Lambda.ineq.constraints[i,j]>0){
              Lambda[i,j] <- 1.0
            }
            if(Lambda.ineq.constraints[i,j]<0){
              Lambda[i,j] <- -1.0
            }          
          }
          else Lambda[i,j] <- Lambda.eq.constraints[i,j]
        }
      }    
    }
    else if (is.matrix(lambda.start)){
      if (nrow(lambda.start)==K && ncol(lambda.start)==(factors+1))
        Lambda  <- lambda.start
      else {
        cat("Starting values not of correct size for model specification.\n")
        stop("Please respecify and call ", echo.name, "() again\n")
      }
    }
    else if (length(lambda.start)==1 && is.numeric(lambda.start)){
      Lambda <- matrix(lambda.start, K, factors+1)
      for (i in 1:K){
        for (j in 1:(factors+1)){
          if (Lambda.eq.constraints[i,j] != -999)
            Lambda[i,j] <- Lambda.eq.constraints[i,j]
        }
      }    
    }
    else {
      cat("Starting values neither NA, matrix, nor scalar.\n")
      stop("Please respecify and call ", echo.name, "() again\n")
    }
    
    # check MH tuning parameter
    if (is.na(tune)){
      tune <- matrix(NA, K, 1)
      for (i in 1:K){
        tune[i] <- 0.05/ncat[i]
      }
    }
    else if (is.double(tune)){
      tune <- matrix(tune, K, 1)
    }
    if(min(tune) < 0) {
      cat("Tuning parameter is negative.\n")
      stop("Please respecify and call ", echo.name, "() again\n")
    }
  
    # starting values for gamma (note: not changeable by user)
    gamma <- matrix(0, max(ncat)+1, K)
    for (i in 1:K){
      if (ncat[i]<=2){
        gamma[1,i] <- -300
        gamma[2,i] <- 0
        gamma[3,i] <- 300
      }
      if(ncat[i] > 2) {
        polr.out <- polr(ordered(X[X[,i]!=-999,i])~1)
        gamma[1,i] <- -300
        gamma[2,i] <- 0
        gamma[3:ncat[i],i] <- (polr.out$zeta[2:(ncat[i]-1)] -
                               polr.out$zeta[1])*.588
        gamma[ncat[i]+1,i] <- 300
      }
    }

    # define holder for posterior density sample
    if (store.scores == FALSE && store.lambda == FALSE){
      sample <- matrix(data=0, mcmc/thin, length(gamma))
    }
    else if (store.scores == TRUE && store.lambda == FALSE){
      sample <- matrix(data=0, mcmc/thin, (factors+1)*N + length(gamma))
    }
    else if(store.scores == FALSE && store.lambda == TRUE) {
      sample <- matrix(data=0, mcmc/thin, K*(factors+1)+length(gamma))
    }
    else { # store.scores==TRUE && store.lambda==TRUE
      sample <- matrix(data=0, mcmc/thin, K*(factors+1)+(factors+1)*N +
                       length(gamma))
    }

    
    # Call the C++ code to do the real work
    posterior <- .C("ordfactanalpost",
                    samdata = as.double(sample),
                    samrow = as.integer(nrow(sample)),
                    samcol = as.integer(ncol(sample)),
                    X = as.integer(X),
                    Xrow = as.integer(nrow(X)),
                    Xcol = as.integer(ncol(X)),
                    burnin = as.integer(burnin),
                    mcmc = as.integer(mcmc),
                    thin = as.integer(thin),
                    tune = as.double(tune),
                    seed = as.integer(seed),
                    verbose = as.integer(verbose),
                    Lambda = as.double(Lambda),
                    Lambdarow = as.integer(nrow(Lambda)),
                    Lambdacol = as.integer(ncol(Lambda)),
                    gamma = as.double(gamma),
                    gammarow = as.integer(nrow(gamma)),
                    gammacol = as.integer(ncol(gamma)),
                    ncat = as.integer(ncat),
                    ncatrow = as.integer(nrow(ncat)),
                    ncatcol = as.integer(ncol(ncat)),
                    Lameq = as.double(Lambda.eq.constraints),
                    Lameqrow = as.integer(nrow(Lambda.eq.constraints)),
                    Lameqcol = as.integer(ncol(Lambda.ineq.constraints)),
                    Lamineq = as.double(Lambda.ineq.constraints),
                    Lamineqrow = as.integer(nrow(Lambda.ineq.constraints)),
                    Lamineqcol = as.integer(ncol(Lambda.ineq.constraints)),
                    Lampmean = as.double(Lambda.prior.mean),
                    Lampmeanrow = as.integer(nrow(Lambda.prior.mean)),
                    Lampmeancol = as.integer(ncol(Lambda.prior.prec)),
                    Lampprec = as.double(Lambda.prior.prec),
                    Lampprecrow = as.integer(nrow(Lambda.prior.prec)),
                    Lamppreccol = as.integer(ncol(Lambda.prior.prec)),
                    storelambda = as.integer(store.lambda),
                    storescores = as.integer(store.scores),
                    accepts = as.integer(0),
                    outswitch = as.integer(case.switch),
                    PACKAGE="MCMCpack"
                    )
    if(case.switch==1) {
      cat(" overall acceptance rate = ",
          posterior$accepts / ((posterior$burnin+posterior$mcmc)*K), "\n")
    }
    
    # put together matrix and build MCMC object to return
    sample <- matrix(posterior$samdata, posterior$samrow, posterior$samcol,
                     byrow=TRUE)
    output <- mcmc2(data=sample,start=1, end=mcmc, thin=thin)
    
    par.names <- NULL
    if (store.lambda==TRUE){
      if(case.switch==1) {
      Lambda.names <- paste(paste("Lambda",
                                  rep(X.names,
                                      each=(factors+1)), sep=""),
                            rep(1:(factors+1),K), sep=".")
      }
      if(case.switch==2) {
        alpha.hold <- paste("alpha", X.names, sep=".")
        beta.hold <- paste("beta", X.names, sep = ".")
        beta.hold <- rep(beta.hold, factors, each=factors)
        beta.hold <- paste(beta.hold, 1:factors, sep=".")
                
        Lambda.names <- t(cbind(matrix(alpha.hold, K, 1), 
                                matrix(beta.hold,K,factors,byrow=TRUE)))  
        dim(Lambda.names) <- NULL
      }
      par.names <- c(par.names, Lambda.names)
    }
    
    gamma.names <- paste(paste("gamma",
                               rep(0:(nrow(gamma)-1),
                                   each=K), sep=""),
                         rep(X.names,  nrow(gamma)), sep=".")
    par.names <- c(par.names, gamma.names)
    
    if (store.scores==TRUE){
      if(case.switch==1) {
      phi.names <- paste(paste("phi",
                               rep(xobs, each=(factors+1)), sep="."),
                         rep(1:(factors+1),(factors+1)), sep=".")
      par.names <- c(par.names, phi.names)
      }
      if(case.switch==2) {
      phi.names <- paste(paste("theta",
                               rep(xobs, each=(factors+1)), sep="."),
                         rep(0:factors,(factors+1)), sep=".")
      par.names <- c(par.names, phi.names)      
      
      }
    }
    
    varnames(output) <- par.names

    # get rid of columns for constrained parameters
    output.df <- mcmc2dataframe(output)
    output.var <- diag(var(output.df))
    output.df <- output.df[,output.var != 0]
    output <- mcmc2(as.matrix(output.df), start=1, end=mcmc, thin=thin)
    
    # add constraint info so this isn't lost
    attr(output, "constraints") <- lambda.constraints
    attr(output, "n.manifest") <- K
    attr(output, "n.factors") <- factors
    attr(output, "accept.rate") <- posterior$accepts /
      ((posterior$burnin+posterior$mcmc)*K)
    if(case.switch==1) {
      attr(output,"title") <-
        "MCMCpack Ordinal Data Factor Analysis Posterior Density Sample"
    }
    if(case.switch==2) {
      attr(output,"title") <-
        "MCMCpack K-Dimensional Item Response Theory Model Posterior Density Sample"
    }
    return(output)
    
  }

# sample from the posterior distribution of general linear panel
# model in R using linked C++ code in Scythe
#
# ADM and KQ 8/1/2002

"MCMCpanel" <-
  function(obs, Y, X, W, burnin = 1000, mcmc = 10000, thin = 5, 
           verbose = FALSE, seed = 0, sigma2.start = NA,
           D.start = NA, b0 = 0, B0 = 1, eta0, R0, nu0 = 0.001,
           delta0 = 0.001, ...) {

    # DESCRIPTION:
    #
    #   MCMCpanel fits a general linear panel model using Algorithm 2 of
    #   Chib and Carlin (1999).  The program calls a compiled C++ shared
    #   library to perform the actual sampling. The model takes the
    #   following form:
    #
    #      y_i = X_i \beta + W_i b_i + \varepsilon_i
    #
    #      b_i \sim N_q(0,D)
    #
    #      \varepsilon_i \sim N_k(0,\sigma^2 I_n)
    #
    #   With conjugate priors:
    #
    #      \beta \sim N_p(\beta_0, \B_0^-1)
    #
    #      D^-1 \sim Wishart(\nu_0^{-1} R_0, \nu_0)
    #
    #      \sigma^-2 \sim Gamma(\nu_00/2, \delta_00/2) 
    #
    #   The model is defined in terms of k (the number of responses
    #   per subject, assumed to be constant across subjects), p (the
    #   number of columns in the design matrix of covariates), and 
    #   q (the number of columns in the design matrix), and n (the
    #   number of subjects).  The components of the model are the
    #   following:
    #
    #      y_i (k \times 1) vector of responses for subject i
    #
    #      X_i (k \times p) matrix of covariates for subject i      
    #
    #      \beta (p \times 1) vector of fixed effects coefficients
    #
    #      W_i (k \times q) design matrix for random effects for subject i
    #
    #      b_i (q \times 1) vector of random effects for subject i
    #
    #      \varepsilon (k \times 1) vector of errors for subject i
    #

    # model parameters
    n <- length(unique(obs))
    k <- length(Y) / n
    p <- dim(X)[2]
    q <- dim(W)[2]

    # check data conformability
    if(dim(obs)[2] != 1) {
      cat("obs is not a column vector.\n")
      stop("Please respecify and call MCMCpanel() again.\n")
    }   
    if(length(unique(tabulate(obs))) != 1) {
      cat("Panel is not balanced [check obs vector].\n")
      stop("Please respecify and call MCMCpanel() again.\n") 
    }
    if(dim(Y)[2] != 1) {
      cat("Y is not a column vector.\n")
      stop("Please respecify and call MCMCpanel() again.\n")
    }
    if(dim(X)[1] != n * k) {
      cat("X matrix is not conformable [does not match Y].\n")
      stop("Please respecify and call MCMCpanel() again.\n")  
    }
    if(dim(W)[1] != n * k) {
      cat("W matrix is not conformable [does not match Y].\n")
      stop("Please respecify and call MCMCpanel() again.\n")
    }   
 
    # check iteration parameters
    check.parameters(burnin, mcmc, thin, "MCMCpanel")
    totiter <- mcmc + burnin

    # starting values for beta error checking
    beta.start <- NA
    ols.beta <- solve(t(X) %*% X) %*% t(X) %*% Y
    ols.sigma2 <-
      t(Y - X %*% ols.beta) %*% (Y - X %*% ols.beta) / (k*n - p - 1)
    ols.sigma2 <- as.double(ols.sigma2)
    if (is.na(beta.start)){ # use least squares estimates
      beta.start <- ols.beta
    }
    if(is.null(dim(beta.start))) {
      beta.start <- beta.start * matrix(1,p,1)  
    }
    if((dim(beta.start)[1] != p) || (dim(beta.start)[2] != 1)) {
      cat("Starting value for beta not conformable.\n")
      stop("Please respecify and call MCMCpanel() again.\n")
    }
  
    # sigma2 starting values error checking
    if (is.na(sigma2.start)){
      sigma2.start <- ols.sigma2
    }   
    if(sigma2.start <= 0) {
      cat("Starting value for sigma2 negative.\n")
      stop("Please respecify and call MCMCpanel() again.\n")
    }   

    # starting values for D error checking
    if (is.na(D.start)){ # use matrix of ones
      D.start <- .5 * ols.sigma2 * diag(q)
    }   
    if(is.null(dim(D.start))) {
      D.start <- D.start * diag(q)
    }
    if((dim(D.start)[1] != q) || (dim(D.start)[2] != q)) {
      cat("Starting value for D not conformable.\n")
      stop("Please respecify and call MCMCpanel() again.\n")
    }

    # set up prior for beta
    if(is.null(dim(b0))) {
      b0 <- b0 * matrix(1,p,1)  
    }
    if((dim(b0)[1] != p) || (dim(b0)[2] != 1)) {
      cat("N(b0,B0^-1) prior b0 not conformable.\n")
      stop("Please respecify and call MCMCpanel() again.\n")
    }  
    if(is.null(dim(B0))) {
      B0 <- B0 * diag(p)
    }
    if((dim(B0)[1] != p) || (dim(B0)[2] != p)) {
      cat("N(b0,B0^-1) prior B0 not conformable.\n")
      stop("Please respecify and call MCMCpanel() again.\n")
    } 
   
    # set up prior for sigma2
    if(nu0 <= 0) {
      cat("G(nu0,delta0) prior nu0 less than or equal to zero.\n")
      stop("Please respecify and call MCMCpanel() again.\n")
    }
    if(delta0 <= 0) {
      cat("G(nu0,delta0) prior delta0 less than or equal to zero.\n")
      stop("Please respecify and call MCMCpanel() again.\n")      
    }
       
    # set up prior for D
    if(eta0 < q) {
      cat("Wishart(eta0,R0) prior eta0 less than or equal to q.\n")
      stop("Please respecify and call MCMCpanel() again.\n")
    }   
    if(is.null(dim(R0))) {
      R0 <- R0 * diag(q)
    }
    if((dim(R0)[1] != q) || (dim(R0)[2] != q)) {
      cat("Wishart(eta0,R0) prior R0 not comformable [q times q].\n")
      stop("Please respecify and call MCMCpanel() again.\n")
    }
         
    # set up big holder matrix
    sample <- matrix(0, mcmc/thin, p+q*q+1)
   
    # call C++ code to draw sample
    inv.obj <- .C("panelpost",
                  samdata = as.double(sample),
                  samrow = as.integer(nrow(sample)),
                  samcol = as.integer(ncol(sample)),
                  obsdata = as.double(obs),
                  obsrow = as.integer(nrow(obs)),
                  obscol = as.integer(ncol(obs)),   
                  ydata = as.double(Y),
                  yrow = as.integer(nrow(Y)),
                  ycol = as.integer(ncol(Y)),   
                  xdata = as.double(X),
                  xrow = as.integer(nrow(X)),
                  xcol = as.integer(ncol(X)),   
                  wdata = as.double(W),
                  wrow = as.integer(nrow(W)),
                  wcol = as.integer(ncol(W)),   
                  burnin = as.integer(burnin),
                  gibbs = as.integer(mcmc),
                  thin = as.integer(thin),
                  seed = as.integer(seed),
                  verbose = as.integer(verbose),
                  bstartdata = as.double(beta.start),
                  bstartrow = as.integer(nrow(beta.start)),
                  bstartcol = as.integer(ncol(beta.start)),
                  sigma2start = as.double(sigma2.start),
                  Dstartdata = as.double(D.start),
                  Dstartrow = as.integer(nrow(D.start)),
                  Dstartcol = as.integer(ncol(D.start)),
                  b0data = as.double(b0),
                  b0row = as.integer(nrow(b0)),
                  b0col = as.integer(ncol(b0)),   
                  B0data = as.double(B0),
                  B0row = as.integer(nrow(B0)),
                  B0col = as.integer(ncol(B0)),  
                  nu0 = as.double(nu0),
                  delta0 = as.double(delta0),
                  eta0 = as.integer(eta0),    
                  R0data = as.double(R0),
                  R0row = as.integer(nrow(R0)),
                  R0col = as.integer(ncol(R0)),
                  n = as.integer(n),
                  k = as.integer(k),
                  p = as.integer(p),
                  q = as.integer(q),
                  PACKAGE="MCMCpack"
                  )     
    
    # put together matrix and build MCMC object to return
    sample <- matrix(inv.obj$samdata, inv.obj$samrow, inv.obj$samcol,
                     byrow=TRUE)   
  
    beta.names <- paste("beta", 1:p, sep = "")
    D.names <- paste("D", 1:(q*q), sep = "")
    sigma2.names <- "sigma2"
    names <- c(beta.names, D.names, sigma2.names)   
    output <- mcmc2(data=sample, start=1, end=mcmc, thin=thin)
    varnames(output) <- names
    attr(output,"title") <- 
      "MCMCpack Linear Panel Model Posterior Density Sample"
    return(output)
  }

# sample from the posterior distribution of a Poisson regression
# model in R using linked C++ code in Scythe
#
# ADM 1/24/2003
# KQ 3/17/2003 [bug fix]

"MCMCpoisson" <-
  function(formula, data = list(), burnin = 1000, mcmc = 10000,
           thin=5, tune=1.1, verbose = FALSE, seed = 0, beta.start = NA,
           b0 = 0, B0 = 0.001, ...) {
  
    # extract X, Y, and variable names from the model formula and frame       
    call <- match.call()
    mt <- terms(formula, data=data)
    if(missing(data)) data <- sys.frame(sys.parent())
    mf <- match.call(expand.dots = FALSE)
    mf$seed <- mf$verbose <- mf$beta.start <- NULL
    mf$burnin <- mf$mcmc <- mf$thin <- mf$tune <- NULL
    mf$b0 <- mf$B0 <- mf$... <- NULL
    mf$drop.unused.levels <- TRUE
    mf[[1]] <- as.name("model.frame")
    mf <- eval(mf, sys.frame(sys.parent()))
  
    # null model support
    X <- if (!is.empty.model(mt)) model.matrix(mt, mf, contrasts)
    X <- as.matrix(X)         # X matrix
    xvars <- dimnames(X)[[2]] # X variable names
    Y <- as.matrix(as.integer(model.response(mf, "numeric"))) # Y matrix
    N <- nrow(X)	      # number of observations      
    K <- ncol(X)              # number of covariates
     
    # test y non-negative
    if (sum(Y < 0) > 0) {
      cat("\n Elements of Y negative. ")
      stop("\n Check data and call MCMCpoisson() again. \n") 
    }
   
    # burnin / mcmc / thin error checking
    check.parameters(burnin, mcmc, thin, "MCMCpoisson", tune)
   
    # starting values for beta error checking
    library(MASS)
    glm.out <- glm(formula, data=data, family=poisson())
    m <- coef(glm.out)
    V <- vcov(glm.out)
    if (is.na(beta.start)) { # use MLEs
      beta.start <- matrix(m, K, 1)
    }
    else if(is.null(dim(beta.start))) {
      beta.start <- beta.start * matrix(1,K,1)  
    }
    else if((dim(beta.start)[1] != K) || (dim(beta.start)[2] != 1)) {
      cat("Starting value for beta not conformable.\n")
      stop("Please respecify and call MCMCpoisson() again.\n")
    }

    # prior for beta error checking
    if(is.null(dim(b0))) {
      b0 <- b0 * matrix(1,K,1)  
    }
    if((dim(b0)[1] != K) || (dim(b0)[2] != 1)) {
      cat("N(b0,B0) prior b0 not conformable.\n")
      stop("Please respecify and call MCMCpoisson() again.\n")
    }
    if(is.null(dim(B0))) {
      B0 <- B0 * diag(K)    
    }
    if((dim(B0)[1] != K) || (dim(B0)[2] != K)) {
      cat("N(b0,B0) prior B0 not conformable.\n")
      stop("Please respecify and call MCMCpoisson() again.\n") 
    }
   
    # define holder for posterior density sample
    sample <- matrix(data=0, mcmc/thin, dim(X)[2] )
  
    # call C++ code to draw sample
    posterior <- .C("poissonpost",
                    samdata = as.double(sample),
                    samrow = as.integer(nrow(sample)),
                    samcol = as.integer(ncol(sample)),
                    Xdata = as.double(X),
                    Xrow = as.integer(nrow(X)),
                    Xcol = as.integer(ncol(X)),   
                    Ydata = as.double(Y),
                    Yrow = as.integer(nrow(Y)),
                    Ycol = as.integer(ncol(Y)),   
                    burnin = as.integer(burnin),
                    mcmc = as.integer(mcmc),
                    thin = as.integer(thin),
                    seed = as.integer(seed),
                    verbose = as.integer(verbose),
                    bstartdata = as.double(beta.start),
                    bstartrow = as.integer(nrow(beta.start)),
                    bstartcol = as.integer(ncol(beta.start)),
                    b0data = as.double(b0),
                    b0row = as.integer(nrow(b0)),
                    b0col = as.integer(ncol(b0)),   
                    B0data = as.double(B0),
                    B0row = as.integer(nrow(B0)),
                    B0col = as.integer(ncol(B0)),
                    mdata = as.double(m),
                    mrow = as.integer(length(m)),
                    mcol = as.integer(1),
                    Vdata = as.double(V),
                    Vrow = as.integer(nrow(V)),
                    Vcol = as.integer(ncol(V)),
                    tune = as.double(tune),
                    accepts = as.integer(0),
                    PACKAGE="MCMCpack"
                    )
    cat("Overall acceptance rate = ",
        posterior$accepts / (posterior$burnin+posterior$mcmc), "\n")
  

    # put together matrix and build MCMC object to return
    sample <- matrix(posterior$samdata, posterior$samrow,
                     posterior$samcol, byrow=TRUE)
    output <- mcmc2(data=sample, start=1, end=mcmc, thin=thin)
    names <- c(xvars)
    varnames(output) <- names
    attr(output,"title") <-
      "MCMCpack Poisson Regression Posterior Density Sample"
    return(output)

  }


# sample from the posterior distribution of a probit
# model in R using linked C++ code in Scythe
#
# ADM and KQ 5/21/2002


"MCMCprobit" <-
  function(formula, data = list(), burnin = 1000, mcmc = 10000,
           thin = 5, verbose = FALSE, seed = 0, beta.start = NA,
           b0 = 0, B0 = 0, bayes.resid=FALSE, ...) {
  
    # extract X, Y, and variable names from the model formula and frame
    call <- match.call()
    mt <- terms(formula, data=data)
    if(missing(data)) data <- sys.frame(sys.parent())
    mf <- match.call(expand.dots = FALSE)
    mf$seed <- mf$verbose <- mf$beta.start <- mf$bayes.resid <- NULL
    mf$burnin <- mf$mcmc <- mf$thin <- NULL
    mf$b0 <- mf$B0 <- mf$... <- NULL
    mf$drop.unused.levels <- TRUE
    mf[[1]] <- as.name("model.frame")
    mf <- eval(mf, sys.frame(sys.parent()))
  
    # null model support
    X <- if (!is.empty.model(mt)) model.matrix(mt, mf, contrasts)
    X <- as.matrix(X)         # X matrix
    xvars <- dimnames(X)[[2]] # X variable names
    Y <- as.matrix(model.response(mf, "numeric")) # Y matrix
    N <- nrow(X)	             # number of observations      
    K <- ncol(X)              # number of covariates
      
    # residuals setup
    if (is.logical(bayes.resid) && bayes.resid==TRUE){
      resvec <- 1:N
    }
    else if (bayes.resid != FALSE){
      resvec <- bayes.resid
    }

    # y \in {0, 1} error checking
    if (sum(Y!=0 & Y!=1) > 0) {
      cat("Elements of Y equal to something other than 0 or 1.\n")
      stop("Check data and call MCMCprobit() again.\n") 
    }
   
    # burnin / mcmc / thin error checking
    check.parameters(burnin, mcmc, thin, "MCMCprobit")
   
    # starting values for beta error checking
    if (is.na(beta.start)){ # use MLEs
      beta.start <- matrix(coef(glm(formula, data=data,
                                    family=binomial(link=probit))), K, 1)
    }
    else if(is.null(dim(beta.start))) {
      beta.start <- beta.start * matrix(1,K,1)  
    }
    else if((dim(beta.start)[1] != K) || (dim(beta.start)[2] != 1)) {
      cat("Starting value for beta not conformable.\n")
      stop("Please respecify and call MCMCprobit() again.\n")
    }

    # prior for beta error checking
    if(is.null(dim(b0))) {
      b0 <- b0 * matrix(1,K,1)  
    }
    if((dim(b0)[1] != K) || (dim(b0)[2] != 1)) {
      cat("N(b0,B0^-1) prior b0 not conformable.\n")
      stop("Please respecify and call MCMCprobit() again.\n")
    }  
   
    if(is.null(dim(B0))) {
      B0 <- B0 * diag(K)    
    }
    if((dim(B0)[1] != K) || (dim(B0)[2] != K)) {
      cat("N(b0,B0^-1) prior B0 not conformable.\n")
      stop("Please respecify and call MCMCprobit() again.\n")
    }  
   
    if (bayes.resid == FALSE){
   
      # define holder for posterior density sample
      sample <- matrix(data=0, mcmc/thin, dim(X)[2] )
  
      # call C++ code to draw sample
      posterior <- .C("probitpost",
                      samdata = as.double(sample),
                      samrow = as.integer(nrow(sample)),
                      samcol = as.integer(ncol(sample)),
                      Xdata = as.double(X),
                      Xrow = as.integer(nrow(X)),
                      Xcol = as.integer(ncol(X)),   
                      Ydata = as.double(Y),
                      Yrow = as.integer(nrow(Y)),
                      Ycol = as.integer(ncol(Y)),   
                      burnin = as.integer(burnin),
                      gibbs = as.integer(mcmc),
                      thin = as.integer(thin),
                      seed = as.integer(seed),
                      verbose = as.integer(verbose),
                      bstartdata = as.double(beta.start),
                      bstartrow = as.integer(nrow(beta.start)),
                      bstartcol = as.integer(ncol(beta.start)),
                      b0data = as.double(b0),
                      b0row = as.integer(nrow(b0)),
                      b0col = as.integer(ncol(b0)),   
                      B0data = as.double(B0),
                      B0row = as.integer(nrow(B0)),
                      B0col = as.integer(ncol(B0)),   
                      PACKAGE="MCMCpack"
                      )
   
      # put together matrix and build MCMC object to return
      sample <- matrix(posterior$samdata, posterior$samrow,
                       posterior$samcol, byrow=TRUE)
      output <- mcmc2(data=sample, start=1, end=mcmc, thin=thin)
      names <- c(xvars)
      varnames(output) <- names
      attr(output,"title") <-
        "MCMCpack Probit Regression Posterior Density Sample"
    }
    else{
      # define holder for posterior density sample
      sample <- matrix(data=0, mcmc/thin, dim(X)[2]+length(resvec) )
  
      # call C++ code to draw sample
      posterior <- .C("probitpostres",
                      samdata = as.double(sample),
                      samrow = as.integer(nrow(sample)),
                      samcol = as.integer(ncol(sample)),
                      Xdata = as.double(X),
                      Xrow = as.integer(nrow(X)),
                      Xcol = as.integer(ncol(X)),   
                      Ydata = as.double(Y),
                      Yrow = as.integer(nrow(Y)),
                      Ycol = as.integer(ncol(Y)),
                      resvecdata = as.double(resvec),
                      resvecrow = as.integer(length(resvec)),
                      resveccol = as.integer(1),
                      burnin = as.integer(burnin),
                      gibbs = as.integer(mcmc),
                      thin = as.integer(thin),
                      seed = as.integer(seed),
                      verbose = as.integer(verbose),
                      bstartdata = as.double(beta.start),
                      bstartrow = as.integer(nrow(beta.start)),
                      bstartcol = as.integer(ncol(beta.start)),
                      b0data = as.double(b0),
                      b0row = as.integer(nrow(b0)),
                      b0col = as.integer(ncol(b0)),   
                      B0data = as.double(B0),
                      B0row = as.integer(nrow(B0)),
                      B0col = as.integer(ncol(B0)),
                      PACKAGE="MCMCpack"   
                      )
      # put together matrix and build MCMC object to return
      sample <- matrix(posterior$samdata, posterior$samrow,
                       posterior$samcol, byrow=TRUE)
      output <- mcmc2(data=sample, start=1, end=mcmc, thin=thin)
      names <- c(xvars, paste("epsilonstar", as.character(resvec), sep="") )
      varnames(output) <- names
      attr(output,"title") <-
        "MCMCpack Probit Regression Posterior Density Sample"
    }
    return(output)
  
  }


# sample from the posterior distribution of a Gaussian linear regression
# model in R using linked C++ code in Scythe
#
# ADM and KQ 5/21/2002

"MCMCregress" <-
  function(formula, data = list(), burnin = 1000, mcmc = 10000,
   thin=5, verbose = FALSE, seed = 0, sigma2.start = NA,
   b0 = 0, B0 = 0, nu = 0.001, delta = 0.001, ...) {
    
    # extract X, Y, and variable names from the model formula and frame       
    call <- match.call()
    mt <- terms(formula, data=data)
    if(missing(data)) data <- sys.frame(sys.parent())
    mf <- match.call(expand.dots = FALSE)
    mf$seed <- mf$verbose <- mf$beta.start <- mf$sigma2.start <- NULL
    mf$burnin <- mf$mcmc <- mf$thin <- NULL
    mf$b0 <- mf$B0 <- mf$nu <- mf$delta <- mf$... <- NULL
    mf$drop.unused.levels <- TRUE
    mf[[1]] <- as.name("model.frame")
    mf <- eval(mf, sys.frame(sys.parent()))
  
    # null model support
    X <- if (!is.empty.model(mt)) model.matrix(mt, mf, contrasts)
    X <- as.matrix(X)         # X matrix
    xvars <- dimnames(X)[[2]] # X variable names
    Y <- as.matrix(model.response(mf, "numeric")) # Y matrix
    N <- nrow(X)	             # number of observations      
    K <- ncol(X)              # number of covariates
   
    # burnin / mcmc / thin error checking
    check.parameters(burnin, mcmc, thin, "MCMCregress")
    
    # starting values for beta error checking
    beta.start <- NA
    if (is.na(beta.start)){ # use MLEs
      beta.start <- matrix(coef(lm(formula, data=data)), K, 1)
    }
    else if(is.null(dim(beta.start))) {
      beta.start <- beta.start * matrix(1,K,1)  
    }
    else if((dim(beta.start)[1] != K) || (dim(beta.start)[2] != 1)) {
      cat("Starting value for beta not conformable.\n")
      stop("Please respecify and call MCMCregress() again.\n")
    }

       # sigma2 starting values error checking
    if (is.na(sigma2.start)){ # use MLE
      lm.out <- lm(formula, data=data)
      sigma2.start <- var(residuals(lm.out))
    }
    else if(sigma2.start <= 0) {
      cat("Starting value for sigma2 negative.\n")
      stop("Please respecify and call MCMCregress() again.\n")
    }   
    
    # prior for beta error checking
    if(is.null(dim(b0))) {
      b0 <- b0 * matrix(1,K,1)  
    }
    if((dim(b0)[1] != K) || (dim(b0)[2] != 1)) {
      cat("N(b0,B0^-1) prior b0 not conformable.\n")
      cat("Please respecify and call MCMCregress() again.\n") 
    }  
    if(is.null(dim(B0))) {
      B0 <- B0 * diag(K)    
    }
    if((dim(B0)[1] != K) || (dim(B0)[2] != K)) {
      cat("N(b0,B0^-1) prior B0 not conformable.\n")
      stop("Please respecify and call MCMCregress() again.\n")
    }  
   
    # prior for sigma2 error checking
    if(nu <= 0) {
      cat("IG(nu/2,delta/2) prior nu less than or equal to zero.\n")
      stop("Please respecify and call MCMCregress() again.\n")
    }
    if(delta <= 0) {
      cat("IG(nu/2,delta/2) prior delta less than or equal to zero.\n")
      stop("Please respecify and call MCMCregress() again.\n")      
    }  
   
    # define holder for posterior density sample
    sample <- matrix(data=0, mcmc/thin, dim(X)[2] + 1)
  
    # call C++ code to draw sample
    inv.obj <- .C("regpost",
                  samdata = as.double(sample),
                  samrow = as.integer(nrow(sample)),
                  samcol = as.integer(ncol(sample)),
                  Xdata = as.double(X),
                  Xrow = as.integer(nrow(X)),
                  Xcol = as.integer(ncol(X)),   
                  Ydata = as.double(Y),
                  Yrow = as.integer(nrow(Y)),
                  Ycol = as.integer(ncol(Y)),   
                  burnin = as.integer(burnin),
                  gibbs = as.integer(mcmc),
                  thin = as.integer(thin),
                  seed = as.integer(seed),
                  verbose = as.integer(verbose),
                  bstartdata = as.double(beta.start),
                  bstartrow = as.integer(nrow(beta.start)),
                  bstartcol = as.integer(ncol(beta.start)),
                  sigma2start = as.double(sigma2.start),
                  b0data = as.double(b0),
                  b0row = as.integer(nrow(b0)),
                  b0col = as.integer(ncol(b0)),   
                  B0data = as.double(B0),
                  B0row = as.integer(nrow(B0)),
                  B0col = as.integer(ncol(B0)),   
                  nu = as.double(nu),
                  delta = as.double(delta),
                  PACKAGE="MCMCpack"
                  )
   
    # put together matrix and build MCMC object to return
    sample <- matrix(inv.obj$samdata, inv.obj$samrow, inv.obj$samcol, byrow=TRUE)
    output <- mcmc2(data=sample,start=1, end=mcmc, thin=thin)
    names <- c(xvars, "sigma2")
    varnames(output) <- names
    attr(output,"title") <- "MCMCregress Posterior Density Sample"
    return(output)   
  }
########## Density Functions and Random Number Generators ##########

##
## Wishart
##

# rwish delivers a pseudo-random Wishart deviate
#
# USAGE:
#
#   A <- rwish(v, S)
#
# INPUT:
#
#   v    degrees of freedom
#
#   S    Scale matrix
#
# OUTPUT:
#
#  A     a pseudo-random Wishart deviate
#
# Based on code originally posted by Bill Venables to S-news
# on 6/11/1998
#
# KQ on 2/5/2001

"rwish" <-
  function(v, S) {
    if (!is.matrix(S))
      S <- matrix(S)
    if (nrow(S) != ncol(S)) {
      stop(message="S not square in rwish().\n")
    }
    if (v < nrow(S)) {
      stop(message="v is less than the dimension of S in rwish().\n")
    }
    p <- nrow(S)
    CC <- chol(S) 
    Z <- matrix(0, p, p)
    diag(Z) <- sqrt(rchisq(p, v:(v-p+1)))
    if(p > 1) {
      pseq <- 1:(p-1)
      Z[rep(p*pseq, pseq) + unlist(lapply(pseq, seq))] <- rnorm(p*(p-1)/2)
    }
    return(crossprod(Z %*% CC))
  }

# dwish evaluations the Wishart pdf at positive definite matrix W.
# note: uses the Gelman, et. al. parameterization.
#
# USAGE:
#
#   x <- dwish(W, v, S)
#
# INPUT:
#
#   W    positive definite matrix at which to evaluate PDF
#
#   v    degrees of freedom
#
#   S    Scale matrix
#
# OUTPUT:
#
#   x    the PDF evaluated (scalar)
#
# ADM 8/16/2002

"dwish" <-
  function(W, v, S) {
    if (!is.matrix(S))
      S <- matrix(S)
    if (nrow(S) != ncol(S)){
      stop(message="W not square in dwish()\n\n")
    }
    if (!is.matrix(W))
      S <- matrix(W)
    if (nrow(W) != ncol(W)){
      stop(message="W not square in dwish()\n\n")
    }   
    if(nrow(S) != ncol(W)){
      stop(message="W and X of different dimensionality in dwish()\n\n")
    }
    if (v < nrow(S)){
      stop(message="v is less than the dimension of S in  dwish()\n\n")
    }    
    k <- nrow(S)
  
    # denominator
    gammapart <- 1
    for(i in 1:k) {
      gammapart <- gammapart * gamma((v + 1 - i)/2)
    } 
    denom <- gammapart *  2^(v * k / 2) * pi^(k*(k-1)/4)
  
    # numerator
    detS <- det(S)
    detW <- det(W)
    hold <- solve(S) %*% W
    tracehold <- sum(hold[row(hold) == col(hold)])  
    num <- detS^(-v/2) * detW^((v - k - 1)/2) * exp(-1/2 * tracehold)

    return(num / denom)
  }

##
## Inverse Wishart
##

# riwish generates a draw from the inverse Wishart distribution
# (using the Wishart generator)  

"riwish" <-
  function(v, S) {
    return(solve(rwish(v,S)))
  }

# diwish evaluates the inverse Wishart pdf at positive definite
# matrix W.  note: uses the Gelman, et. al. parameterization.
#
# USAGE:
#
#   x <- diwish(W, v, S)
#
# INPUT:
#
#   W    positive definite matrix at which to evaluate PDF
#
#   v    degrees of freedom
#
#   S    Scale matrix
#
# OUTPUT:
#
#   x    the PDF evaluated (scalar)
#
# ADM 8/16/2002
 
"diwish" <-
  function(W, v, S) {
    if (!is.matrix(S))
      S <- matrix(S)
    if (nrow(S) != ncol(S)){
      stop("W not square in diwish().\n")
    }
    if (!is.matrix(W))
      S <- matrix(W)
    if (nrow(W) != ncol(W)){
      stop("W not square in diwish().\n")
    }   
    if(nrow(S) != ncol(W)){
      stop("W and X of different dimensionality in diwish().\n")
    }
    if (v < nrow(S)){
      stop("v is less than the dimension of S in  diwish().\n")
    }
    
    k <- nrow(S)   

    # denominator
    gammapart <- 1
    for(i in 1:k) {
      gammapart <- gammapart * gamma((v + 1 - i)/2)
    } 
    denom <- gammapart *  2^(v * k / 2) * pi^(k*(k-1)/4)
  
    # numerator
    detS <- det(S)
    detW <- det(W)
    hold <- S %*% solve(W)
    tracehold <- sum(hold[row(hold) == col(hold)])  
    num <- detS^(v/2) * detW^(-(v + k + 1)/2) * exp(-1/2 * tracehold)

    return(num / denom)
  }

##
## Inverse Gamma
##

# evaluate the inverse gamma density
#
# Kevin Rompala 5/6/2003

"dinvgamma" <-
  function(x, shape, rate = 1) {

    # error checking
    if(shape <= 0 | rate <=0) {
      stop("Shape or rate parameter negative in dinvgamma().\n")
    }
   
    alpha <- shape
    beta <- rate
    return(beta^alpha / gamma(alpha) * x^(-1*(alpha + 1)) * exp(-beta/x))
  }

# generate draws from the inverse gamma density (using
# the gamma simulator)
#
# Kevin Rompala 5/6/2003

"rinvgamma" <-
  function(n, shape, rate = 1) {
    return(1 / rgamma(n, shape, rate))
  }

##
## Dirichlet (Multivariate Beta)
##

# ddirichlet evaluates the density of the Dirichlet at
# vector x given shape parameter vector (or matrix)
# alpha.
#
# note: this code is taken verbatim from the R-package
# "Greg's Miscellaneous Functions" maintained by
# Gregory R. Warnes <Gregory_R_Warnes@groton.pfizer.com>
#
# Kevin Rompala 5/6/2003

"ddirichlet" <-
  function(x, alpha) {

    dirichlet1 <- function(x, alpha) {
      logD <- sum(lgamma(alpha)) - lgamma(sum(alpha))
      s <- sum((alpha-1)*log(x))
      exp(sum(s)-logD)
    }

    # make sure x is a matrix
    if(!is.matrix(x))
      if(is.data.frame(x))
        x <- as.matrix(x)
      else
        x <- t(x)
    if(!is.matrix(alpha))
      alpha <- matrix( alpha, ncol=length(alpha), nrow=nrow(x), byrow=TRUE)

    if( any(dim(x) != dim(alpha)) )
      stop("Mismatch between dimensions of x and alpha in ddirichlet().\n")

    pd <- vector(length=nrow(x))
    for(i in 1:nrow(x))
      pd[i] <- dirichlet1(x[i,],alpha[i,])

    # Enforce 0 <= x[i,j] <= 1, sum(x[i,]) = 1
    pd[ apply( x, 1, function(z) any( z <0 | z > 1)) ] <- 0
    pd[ apply( x, 1, function(z) all.equal(sum( z ),1) !=TRUE) ] <- 0
    return(pd)
  }


# rdirichlet generates n random draws from the Dirichlet at
# vector x given shape parameter vector (or matrix)
# alpha.
#
# note: this code is taken verbatim from the R-package
# "Greg's Miscellaneous Functions" maintained by
# Gregory R. Warnes <Gregory_R_Warnes@groton.pfizer.com>
#
# Kevin Rompala 5/6/2003

"rdirichlet" <-
  function(n, alpha) {
    l<-length(alpha);
    x<-matrix(rgamma(l*n,alpha),ncol=l,byrow=TRUE);
    sm<-x%*%rep(1,l);
    return(x/as.vector(sm));
  }

##
## Non-Central Hypergeometric
##

# code to evaluate the noncentral hypergeometric density (at a single point
# or at all defined points).
#
# parameters:
#
#    n1, n2 -- number of subjects in group 1 and 2
#
#    Y1, Y2 -- number of subjects with positive outcome [unobserved]
#
#    psi -- odds ratio
#
#    m1 -- sum of observed values of Y1 and Y2 (Y1 + Y2)
#   
# output:
#
#   pi -- Pr(Y1 = x | Y1 + Y2 = m1) x=ll,...,uu
#
#   for ll = max(0, m1-n2) and uu = min(n1, m1)
#  
# if x is NA, then a matrix is returned, with the first column the possible
# values of x, and the second columns the probabilities.  if x is a scalar, 
# the density is evaluated at that point.
#
# ADM on 5/8/2003
#
# note: code adapted from R code published in conjunction with:
#
# Liao, J.G. And Rosen, O. (2001) Fast and Stable Algorithms for Computing and 
# Sampling from the Noncentral Hypergeometric Distribution.  The American
# Statistician 55, 366-369.
#

"dnoncenhypergeom" <-
  function (x = NA, n1, n2, m1, psi) {

    ##
    ## AUXILIARY FUNCTIONS
    ##

    mode.compute <- function(n1, n2, m1, psi, ll, uu) {
      a <- psi - 1
      b <- -( (m1+n1+2)*psi + n2-m1 )     
      c <- psi*(n1+1)*(m1+1)
      q <- b + sign(b)*sqrt(b*b-4*a*c)
      q <- -q/2
                         
      mode <- trunc(c/q) 
      if(uu>=mode && mode>=ll) return(mode)
      else return( trunc(q/a) )      
    }

    r.function <- function(n1, n2, m1, psi, i) {
      (n1-i+1)*(m1-i+1)/i/(n2-m1+i)*psi
    }

    ##
    ## MAIN FUNCTION
    ##

    # upper and lower limits for density evaluation
    ll <- max(0, m1-n2)
    uu <- min(n1, m1)

    # check parameters
    if(n1 < 0 | n2 < 0) {
       stop("n1 or n2 negative in dnoncenhypergeom().\n")
    }
    if(m1 < 0 | m1 > (n1 + n2)) {
       stop("m1 out of range in dnoncenhypergeom().\n")
    }
    if(psi <=0) {
       stop("psi [odds ratio] negative in dnoncenhypergeom().\n")
    }
    if(!is.na(x) & (x < ll | x > uu)) {
       stop("x out of bounds in dnoncenhypergeom().\n")
    }
    if(!is.na(x) & length(x) > 1) {
       stop("x neither missing or scalar in dnoncenhypergeom().\n")
    }  
  
    # evaluate density using recursion (from mode)
    mode <- mode.compute(n1, n2, m1, psi, ll, uu)
    pi <- array(1, uu-ll+1)
    shift <- 1-ll
    
    if(mode<uu) { # note the shift of location
      r1 <- r.function( n1, n2, m1, psi, (mode+1):uu )       
      pi[(mode+1 + shift):(uu + shift)] <- cumprod(r1)       
    }
   
    if(mode>ll) {
       r1 <- 1/r.function( n1, n2, m1, psi, mode:(ll+1) )
       pi[(mode-1 + shift):(ll + shift)] <- cumprod(r1)
    }
            
    pi <- pi/sum(pi)
    if(is.na(x)) return(cbind(ll:uu,pi))
    else return(pi[x + shift])
}

# code to generate random deviates from the noncentral hypergeometric density 
#
# parameters:
#
#    n -- the number of draws to make
#
#    n1, n2 -- number of subjects in group 1 and 2
#
#    Y1, Y2 -- number of subjects with positive outcome [unobserved]
#
#    psi -- odds ratio
#
#    m1 -- sum of observed values of Y1 and Y2 (Y1 + Y2)
#   
# output:
#
#   output -- a list of length n of random deviates
#  
#
# ADM on 5/9/2003
#
# note: code adapted from R code published in conjunction with:
#
# Liao, J.G. And Rosen, O. (2001) Fast and Stable Algorithms for Computing and 
# Sampling from the Noncentral Hypergeometric Distribution.  The American
# Statistician 55, 366-369.
#

"rnoncenhypergeom" <-
  function (n, n1, n2, m1, psi) {

    ##
    ## AUXILIARY FUNCTIONS
    ##  

    mode.compute <- function(n1, n2, m1, psi, ll, uu) {
      a <- psi - 1
      b <- -( (m1+n1+2)*psi + n2-m1 )     
      c <- psi*(n1+1)*(m1+1)
      q <- b + sign(b)*sqrt(b*b-4*a*c)
      q <- -q/2
                         
      mode <- trunc(c/q) 
      if(uu>=mode && mode>=ll) return(mode)
      else return( trunc(q/a) )
      
    }  
  
    sample.low.to.high <- function(lower.end, ran, pi, shift) { 
      for(i in lower.end:uu) {                                
        if(ran <= pi[i+shift]) return(i)
        ran <- ran - pi[i+shift]
        }                                
    }
       
    sample.high.to.low <- function(upper.end, ran, pi, shift) {
      for(i in upper.end:ll) {                              
        if(ran <= pi[i+shift]) return(i)
        ran <- ran - pi[i+shift]
      } 
    }
    
    single.draw <- function(n1, n2, m1, psi, ll, uu, mode, pi) {
      ran <- runif(1)
      shift <- 1-ll  
      if(mode==ll) return(sample.low.to.high(ll, ran, pi, shift))            
      if(mode==uu) return(sample.high.to.low(uu, ran, pi, shift))                                         
      if(ran < pi[mode+shift]) return(mode)             
      ran <- ran - pi[mode+shift]
      lower <- mode - 1                                                                            
      upper <- mode + 1
          
      repeat {           
        if(pi[upper + shift] >= pi[lower + shift]) {              
          if(ran < pi[upper+shift]) return(upper)
          ran <- ran - pi[upper+shift]
          if(upper == uu) return( sample.high.to.low(lower, ran, pi, shift) )
          upper <- upper + 1                            
        }
        else {
          if(ran < pi[lower+shift]) return(lower)
          ran <- ran - pi[lower+shift]
          if(lower == ll) return( sample.low.to.high(upper, ran, pi, shift) )
          lower <- lower - 1                   
        }     
      }
    }
  
    ##
    ## MAIN FUNCTION
    ##

    # upper and lower limits for density evaluation
    ll <- max(0, m1-n2)
    uu <- min(n1, m1)
    
    # check parameters
    if(n1 < 0 | n2 < 0) {
       stop("n1 or n2 negative in rnoncenhypergeom().\n")
    }
    if(m1 < 0 | m1 > (n1 + n2)) {
       stop("m1 out of range in rnoncenhypergeom().\n")
    }
    if(psi <=0) {
       stop("psi [odds ratio] negative in rnoncenhypergeom().\n")
    }


    # get density and other parameters
    mode <- mode.compute(n1, n2, m1, psi, ll, uu) 
    pi <- dnoncenhypergeom(NA, n1, n2, m1, psi)[,2]
    
    output <- array(0,n)
    for(i in 1:n) output[i] <- single.draw(n1, n2, m1, psi, ll, uu, mode, pi)    
    return(output)
  }



########## Helper Functions for MCMC Simulations ##########

# check MCMC parameters for conformability
#
# Kevin Rompala 5/1/2002

"check.parameters" <-
  function(burnin, mcmc, thin, fcn, tune=NA) {

    if(mcmc %% thin != 0) {
      cat("Gibbs interval not evenly divisible by thinning interval.\n")
      stop("Please respecify and call ", fcn, "() again.\n")
    }
    if(mcmc < 0) {
      cat("Gibbs interval negative.\n")
      stop("Please respecify and call ", fcn, "() again.\n")
    }
    if(burnin < 0) {
      cat("Burnin interval negative.\n")
      stop("Please respecify and call ", fcn, "() again.\n")
    }
    if(thin < 0) {
      cat("Thinning interval negative.\n")
      stop("Please respecify and call ", fcn, "() again.\n")
    }
    if(!is.na(tune) & tune <= 0) {
      cat("Tuning parameter negative.\n")
      stop("Please respecify and call ", fcn, "() again.\n")      
    }
    
    return(0)
  }
########## Functions to Manipulate mcmc Objects ##########

# mcmc2 creates mcmc objects.  note: taken almost verbatim from
# the coda package of Plummer, Best, Cowles, and Vines.
#
# KQ 11/10/2002

"mcmc2" <-
  function (data = NA, start = 1, end = numeric(0), thin = 1) {
    if (is.matrix(data)) {
      niter <- nrow(data)
      nvar <- ncol(data)
    }
    else {
      niter <- length(data)
      nvar <- 1
    }
    thin <- round(thin)
    if (length(start) > 1) 
      stop("Invalid start in mcmc2().\n")
    if (length(end) > 1) 
      stop("Invalid end in mcmc2().\n")
    if (length(thin) != 1) 
      stop("Invalid thin in mcmc2().\n")
    if (missing(end)) 
      end <- start + (niter - 1) * thin
    else if (missing(start)) 
      start <- end - (niter - 1) * thin
    nobs <- floor((end - start)/thin + 1.0) # only change from coda mcmc()
    if (niter < nobs) 
      stop("Start, end and thin incompatible with data in mcmc2().\n")
    else {
      end <- start + thin * (nobs - 1)
      if (nobs < niter) 
        data <- data[1:nobs, , drop = FALSE]
    }
    attr(data, "mcpar") <- c(start, end, thin)
    attr(data, "class") <- "mcmc"
    data
  }



# mcmc2dataframe converts an mcmc object to a dataframe (requires
# coda package)
#
# KQ 11/10/2002

"mcmc2dataframe" <-
  function(obj){
    if (!is.mcmc(obj))
      stop("Input object not of type mcmc in mcmc2dataframe().\n")

    objdf <- as.data.frame(matrix(obj, nrow(obj), ncol(obj)))
    colnames(objdf) <- varnames(obj)
    rownames(objdf) <- seq(from=start(obj), to=end(obj), by=thin(obj))
    return(objdf)
  }
########## Scythe Inter-Operation Functions ##########


# writes a matrix out to an ASCII file that can be read by Scythe.
# it puts the number of rows and columns in the first row
# followed by the data.
#
# ADM 1/29/2003

"write.Scythe" <-
  function(outmatrix, outfile = NA, overwrite=FALSE) {
    outmatrix <- as.matrix(outmatrix)
   
    if(is.na(outfile)) {
      stop("Please specify a file name in the write.Scythe() call.\n")
    }
    if(overwrite==FALSE & file.exists(outfile)) {
      cat("File already exists in the write.Scythe() call.\n")
      stop("Either delete the file, or flip the overwrite switch.\n")
    }
   
    outfile <- file(outfile, "w")
    cat(dim(outmatrix), "\n", file=outfile)
    write.table(outmatrix, file=outfile,
                row.names=FALSE, col.names=FALSE, quote=FALSE)
    close(outfile)
    return(0)
  } 


# reads in a matrix from an ASCII file written by Scythe.
# the number of rows and columns should be in the first row followed
# by the data.
#
# Kevin Rompala 5/1/2003

"read.Scythe" <-
  function(infile = NA) {
    
    if(is.na(infile)) {
      stop("Please specify a file name in the read.Scythe() call.\n")
    }
    if(!file.exists(infile)) {
      stop("Specified source file does not exist in read.Scythe() call.\n")
    }

    infile <- file(infile, "r")
    dimensions <- scan(file=infile,n=2)
    inputdata <- scan(file=infile)
    close(infile)
    matrix(data=inputdata,
           nrow=dimensions[1], ncol=dimensions[2], byrow=TRUE)
    return(0) 
  }
########## Tomography Plots for Ecological Inference ##########

# produces tomography plots (see King, 1997, A Solution to the
# Ecological Inference Problem, Princeton University Press)
#
# KQ 11/9/2002

"tomogplot" <-
  function(r0, r1, c0, c1, 
           xlab="fraction of r0 in c0 (p0)",
           ylab="fraction of r1 in c0 (p1)",
           bgcol="white", ...) {
    if (length(r0) != length(r1)) {
      stop("r0 and r1 different lengths in tomogplot().\n")
    }
    if (length(r0) != length(c0)) {
      stop("r0 and c0 different lengths in tomogplot().\n")
    }
    if (length(r0) != length(c1)) {
      stop("r0 and c1 different lengths in tomogplot().\n")
    }
    
    intercept <-  c0/r1
    slope <- -1 * r0/r1
    N <- length(r0)
    
    par(pty="s")
    plot(0:1, 0:1, type="n", main="", xlab=xlab, ylab=ylab)
    rect(0, 0, 1, 1, col=bgcol, lty=0)
    
    for (year in 1:N) {
      abline(intercept[year], slope[year])
    }
    
    rect(-0.05, -0.05, 1.05, 0, col="white", lty=0)
    rect(-0.05, -0.05, 0, 1.05, col="white", lty=0)
    rect(-0.05, 1, 1.05, 1.05, col="white", lty=0)
    rect(1, -0.05, 1.05, 1.05, col="white", lty=0)
    box()
    return(0)
  }

# produces temporally organized tomography plots
# (see King, 1997, A Solution to the Ecological Inference
# Problem, Princeton University Press)
#
# KQ 11/9/2002

"dtomogplot" <-
  function(r0, r1, c0, c1, time.vec=NA, 
           xlab="fraction of r0 in c0 (p0)",
           ylab="fraction of r1 in c0 (p1)",
           color.palette=heat.colors,
           bgcol="black", ...) {
    if (length(r0) != length(r1)){
      stop("r0 and r1 different lengths in dtomogplot().\n")
    }
    if (length(r0) != length(c0)){
      stop("r0 and c0 different lengths in dtomogplot().\n")
    }
    if (length(r0) != length(c1)){
      stop("r0 and c1 different lengths in dtomogplot().\n")
    }
    if (length(r0) != length(time.vec) & !is.na(time.vec)[1]){
      stop("r0 and time.vec different lengths in dtomogplot().\n")
    }
  
    intercept <-  c0/r1
    slope     <- -1 * r0/r1
    N <- length(r0)
    if (is.na(time.vec)[1])
      time.vec <- 1:N
    col.vec <- color.palette(N)

    mar.orig <- (par.orig <- par(c("mar", "las", "mfrow")))$mar
    on.exit(par(par.orig))
    w <- (3 + mar.orig[2]) * par("csi") * 2.54
    layout(matrix(c(2,1), nc=2), widths=c(1,lcm(w)))
    par(las=1)
    mar <- mar.orig
    mar[4] <- mar[2]
    mar[2] <- 1
    par(mar=mar)
    par(pty="m")
    plot.new()
    plot.window(xlim=c(0,1), ylim=range(time.vec), xaxs="i",
                yaxs="i")
    rect(0, time.vec[-length(time.vec)], 1, time.vec[-1], col=col.vec)
    axis(4)
    box()
    mar <- mar.orig
    mar[4] <- 1
    par(mar=mar)
    par(pty="s")   
    plot(0:1, 0:1, type="n", main="", xlab=xlab, ylab=ylab)
    rect(0, 0, 1, 1, col=bgcol, lty=0)
  
    for (year in 1:N) {
      abline(intercept[year], slope[year], col=col.vec[year])
    }

    rect(-0.05, -0.05, 1.05, 0, col="white", lty=0)
    rect(-0.05, -0.05, 0, 1.05, col="white", lty=0)
    rect(-0.05, 1, 1.05, 1.05, col="white", lty=0)
    rect(1, -0.05, 1.05, 1.05, col="white", lty=0)
    box()  
    return(0)
  }
########## Utility Functions ##########

# takes a symmetric matrix x and returns lower diagonal
# note: does not check for symmetry
#
# ADM 4/18/2003 

"vech" <-
  function (x) {
    x <- as.matrix(x)
    if (dim(x)[1] != dim(x)[2]) {
      stop("Non-square matrix passed to vech().\n")
    }
    output <- x[lower.tri(x, diag = TRUE)]
    dim(output) <- NULL
    return(output)
  }

# takes vector x and returns an nrow times nrow symmetric matrix
# this will recycle the elements of x as needed to fill the matrix
#
# ADM 4/18/2003
# ADM 11/13/2003 [bug fix]

"xpnd" <-
  function (x, nrow) {
    dim(x) <- NULL
    output <- matrix(0, nrow, nrow)
    output[lower.tri(output, diag = TRUE)] <- x
    hold <- output
    hold[upper.tri(hold, diag=TRUE)] <- 0
    output <- output + t(hold)    
    return(output)
  }
.First.lib <- function(lib, pkg)
{
   cat("##\n## Markov chain Monte Carlo Package (MCMCpack)\n")
   cat("## Copyright (C) 2003 Andrew D. Martin and Kevin M. Quinn\n##\n")
   require(coda)
   require(MASS)
   library.dynam("MCMCpack", pkg, lib)
   
}

