### convert a real valued array to a binary array by thresholding at zero

ra2ba <- function(x) {

  retval <- as.numeric(x>0)
  dim(retval) <- dim(x)
  retval
}


### generate multivariate binary data by direct conversion
### from multivariate normals   

rmvbin <- function (n, margprob,
                      commonprob=diag(margprob),
                      bincorr=diag(length(margprob)),
                      sigma=diag(length(margprob)),                      
                      colnames=NULL, simulvals=NULL) {

  if(missing(sigma))
    {
      if(!missing(commonprob))
        {
          if (missing(margprob))
            margprob <- diag(commonprob)
          sigma <- commonprob2sigma(commonprob, simulvals)
        }
      else if(!missing(bincorr))
        {
          commonprob <- bincorr2commonprob(margprob, bincorr)
          sigma <- commonprob2sigma(commonprob, simulvals)
        }
    }
  else if (any(eigen(sigma)$values<0))
    stop ("Sigma is not positive definite.")
  
  retval <- rmvnorm(n, qnorm(margprob), as.matrix(sigma))
  retval <- ra2ba(retval)
  dimnames(retval) <- list(NULL, colnames)
  retval
}


### convert binary correlation matrix to matrix of joint probabilities

bincorr2commonprob <- function(margprob, bincorr) {

  retval <- 0 * bincorr

  for(k in 1:ncol(retval)){
    for(l in 1:ncol(retval)){
      retval[k,l] <- bincorr[k,l] *
        sqrt(margprob[k]*(1-margprob[k])*margprob[l]*(1-margprob[l])) +
        margprob[k]*margprob[l]
    }
  }

  retval
}
      
### convert matrix of joint probabilities to covariance matrix of normal
### distribution 

commonprob2sigma <- function(commonprob, simulvals=NULL) {

  if(is.null(simulvals)){
    if(!("SimulVals" %in% ls(envir=.GlobalEnv)))
      eval(data(SimulVals, package="bindata"), envir=.GlobalEnv)

    simulvals <- eval(SimulVals, envir=.GlobalEnv)
  }
      
  
  margprob <- diag(commonprob)
  
  if(!(check <- check.commonprob(commonprob))){
    cat(attr(check, "message"), sep="\n")
    stop("Matrix commonprob not admissible.")
  }
  
  sigma <- diag(nrow(commonprob))
  
  for(m in 1:(ncol(commonprob)-1)){
    for(n in (m+1):nrow(commonprob)){
      x <- cbind(margprob[m], margprob[n],
                 as.numeric(dimnames(simulvals)[[3]]))
      y <- interpolate(x, simulvals)
      f <- approxfun(y, x[,3])
      sigma[m,n] <- sigma[n,m] <- f(commonprob[m,n])
    }
  }
  if(any(is.na(sigma)))
    stop("Extrapolation occurred ... margprob and commonprob not compatible?")
  if (any(eigen(sigma)$values < 0))
    {
      cat ("Warning: Resulting covariance matrix is not positive definite.\n")
      cat ("         Smallest eigenvalue equals", min(eigen(sigma)$values),
           ".\n")
      cat ("         Please check whether the results are still useful.\n")
    }
  
  sigma
}




### compute the conditional probabilities P(x_i|x_j)

condprob <- function (x) {

  x <- as.matrix(x)
  nc <- ncol(x)

  retval <- matrix(0, nrow=nc, ncol=nc)
  for(k in 1:nc){
    retval [k,] <- apply(x[x[,k]!=0,], 2, mean)
  }
  dimnames(retval) <- list(colnames(x), colnames(x))
  retval
}
      

### check the matrix of common probabilities

check.commonprob <- function (commonprob)
{
  retval <- TRUE
  message <- character(0)
  nm <- 0
  
  if ((any(commonprob < 0)) || (any(commonprob > 1))){
    retval <- FALSE
    message[nm<-nm+1] <- "Not all probabilities are between 0 and 1."
  }
  
  n <- dim(commonprob)[1]
  if (n != dim(commonprob)[2]){
    retval <- FALSE
    message[nm<-nm+1] <- "Matrix of common probabilities is not quadratic."
  }
  
  ## check pairwise conditions
  for (i in 1:(n-1)){
    for (j in 2:n)
      {
        ul <- min(commonprob[i,i], commonprob[j,j])
        ll <- max(commonprob[i,i]+commonprob[j,j]-1, 0)
        if ((commonprob[i,j] > ul) || (commonprob[i,j] < ll))
          {
            retval <- FALSE
            message[nm<-nm+1] <- 
              paste("Error in Element (",i,",",j,
                    "): Admissible values are in [",
                    ll,",",ul,"].")
          }
      }
  }
  
  ## check triple conditions
  if (n > 2)
    for (i in 1:(n-2))
      for (j in (i+1):(n-1))
        for (k in (j+1):n)
          {
            l <- commonprob[i,i]+commonprob[j,j]+commonprob[k,k]-1
            if (commonprob[i,j]+commonprob[i,k]+commonprob[j,k] < l)
              {
                retval <- FALSE
                message[nm<-nm+1] <-
                  paste("The sum of the common probabilities of",i,",",
                        j,",",k,"must be at least",l,".")
              }
          }

  attr(retval, "message") <- message
  retval
}

### compute for all combinations of correlations corr and
### margin probabilities mp the value of P(A,B)

simul.commonprob <- function(margprob, corr=0,
                             method="integrate", n1=10^5,n2=10)
{
  require("e1071")

  lm <- length(margprob)
  lr <- length(corr)
  
  z <- array(0, dim=c(lm,lm,lr))

  method <- pmatch(method, c("integrate", "monte carlo"))
  if(is.na(method))
    stop("invalid method")

  for(k in 1:lr){
    sigma <- matrix(c(1,corr[k],corr[k],1), ncol=2)
    for(m in 1:lm){
      q1 <- qnorm(margprob[m])
      for(n in m:lm){
        cat(corr[k], margprob[m], margprob[n], ": ")
        q2 <- qnorm(margprob[n])

        if(corr[k]==-1){
          z[m,n,k] <- max(margprob[m] + margprob[n] -1, 0)
          cat("done\n")
        }
        else if(corr[k]==0){
          z[m,n,k] <- margprob[m] * margprob[n]
          cat("done\n")
        }
        else if(corr[k]==1){
          z[m,n,k] <- min(margprob[m], margprob[n])
          cat("done\n")
        }
        else if(margprob[m] * margprob[n] == 0){
          z[m,n,k] <- 0
          cat("done\n")
        }
        else if(margprob[m] == 1){
          z[m,n,k] <- margprob[n]
          cat("done\n")
        }
        else if(margprob[n] == 1){
          z[m,n,k] <- margprob[m]
          cat("done\n")
        }
        else if(method==1){
          require("integrate")
          a <- adapt(2, funct=dmvnorm,
                     lo=c(0,0), up=c(10,10), min=100, max=100000, eps=0.0001,
                     mu = c(q1,q2), sigma=sigma)
          if(a$ifail){
            z[m,n,k] <- NA
          }
          else{
            z[m,n,k] <- a$finest
          }
        }
        else{
          x2 <- rep(0,n2)
          for(l in 1:n2){
            x1 <- rmvnorm(n1, mu = c(q1,q2), sigma=sigma)
            x2[l] <- sum( (x1[,1] > 0) & (x1[,2] > 0))/n1
          }
          z[m,n,k] <- mean(x2)
          cat("done\n")
        }
        z[n,m,k] <- z[m,n,k]
      }
    }
  }
  dimnames(z)<-list(margprob, margprob, corr)
  z
}
.First.lib <- function(lib, pkg) require("e1071")
