Zelig4: Everyone's Statistical Software

#' Print a Zelig Object
#' @S3method print zelig
print.zelig <- function (x, ...) {
  name <- x$name
  package.name <- x$package.name
  call <- x$call

  cat("Model Name: ", name, "\n")
  cat("Package Name: ", package.name, "\n")
  cat("Call:\n")
  print(call)

  # 
  message("\nFor information about the fitted model, use the summary() function.")

  # Return invisibly
  invisible(x)
}
#' Print a Bundle of Data-sets
#'
#' @S3method print setx.mi
#' @usage \method{print}{setx.mi}(x, ...)
#' @param x a \code{setx} object to print
#' @param ... ignored parameters
#' @return the \code{setx} object (invisibly)
#' @author Matt Owen \email{mowen@@iq.harvard.edu}
print.setx.mi <- function(x, ...) {
  # Store size for readability
  size <- length(x)

  for (k in 1:size) {
    # Print object
    print(x[[k]])

    # If this is not the last element, print a new-line
    if (k < size)
      cat("\n")
  }

  invisible(x)
}
#' Print values of `setx' objects
#'
#' Print a ``setx'' object in human-readable form.
#' @usage \method{print}{setx}(x, ...)
#' @S3method print setx
#' @param x a `setx' object
#' @param ... ignored parameters
#' @return the value of x (invisibly)
#' @export
#' @author Matt Owen \email{mowen@@iq.harvard.edu}
print.setx <- function(x, ...) {
  model <- x$name
  formula <- x$formula
  label <- x$label

  cat("Call:\n")
  print(x$call)

  cat("Model name = ", model, "\n")
  cat("Formula    = ")
  print(formula)

  cat("\nComplete data.frame:\n")
  print(x$updated)

  cat("\nModel Matrix (Design Matrix):\n")
  print(x$matrix)

  invisible()
}
#' @S3method print summary.setx
print.summary.setx <- function (x, ...) {
  cat("\nModel name =", x$model.name, "\n")
  cat("Label      =", x$label, "\n")
  cat("Formula    = ")
  print(x$formula)

  cat("\nCall:\n")
  print(x$call)

  cat("\nModel Matrix (Design Matrix):\n")
  print(x$model.matrix)

  invisible(x)
}
#' Print values of `sim' objects
#' 
#' This function is currently unimplemented, and included for future development
#' @usage \method{print}{sim}(x, ...)
#' @S3method print sim
#' @param x a `sim' object (ignored)
#' @param ... ignored parameters
#' @return NULL (invisibly)
#' @author Matt Owen \email{mowen@@iq.harvard.edu}
print.sim <- function(x, ...) {
  o <- x
  class(o) <- 'list'
  print(o)
}
#' Print a Summary MCMCZelig Object
#'
#' This method prints a summary object for \code{MCMCZelig} objects
#' @param x an "MCMCZelig" object
#' @param digits a numeric specifying the precision of the summary object
#' @param ... ignored parameters
#' @return a \code{summary.MCMCZelig} object
#' @S3method print summary.MCMCZelig
print.summary.MCMCZelig <- function(x, digits=max(3, getOption("digits") - 
3), ...) {
  cat("\nCall: ") 
  print(x$call) 
  cat("\n", "Iterations = ", x$start, ":", x$end, "\n", sep = "")
  cat("Thinning interval =", x$thin, "\n")
  cat("Number of chains =", x$nchain, "\n")
  cat("Sample size per chain =", (x$end -
  x$start)/x$thin + 1, "\n")
  cat("\n", "Mean, standard deviation, and quantiles for marginal posterior distributions.", "\n")
  print(round(x$summary, digits=digits))
  cat("\n")
}
print.summary.glm.robust <-
    function (x, digits = max(3, getOption("digits") - 3),
	      symbolic.cor = x$symbolic.cor,
	      signif.stars = getOption("show.signif.stars"), ...)
{
  class(x) <- "summary.glm"
  print(x)
  cat("\nRobust standard errors computed using", x$robust)
  cat("\n")
  invisible(x)
}
#' Print a Summary of a Set of Pooled Simulated Interests
#'
#' Prints the summary information from a set of pooled simulated interests. This
#' method assumes that quantities of interest are kept in a data type which can
#' be used with ``rbind''.
#' @usage \method{print}{summary.pooled.sim}(x, ...)
#' @S3method print summary.pooled.sim
#' @param x a ``summary.pooled.sim'' object, containing summarized information
#' about simulated quantities of interest
#' @param ... Optional parameters that will be passed onward to ``print.matrix''
#' (the matrix printing function)
#' @return a ``summary.pooled.sim'' object storing the quantities of interest
#' @author Matt Owen \email{mowen@@iq.harvard.edu}
print.summary.pooled.sim <- function (x, ...) {
  # los labels... kinda like spanish for "the labels"
  # labels is function name in base, so we needed a name that said "labels,"
  # without using "labels". You know?
  los.labels <- x$labels
  los.titles <- x$titles

  # Pooled summarized data
  for (title in los.titles) {

    # This will implicity become a matrix
    m <- NULL

    for (label in los.labels)
      m <- rbind(m, x$stats[[label]][[title]])

    rownames(m) <- paste("[", los.labels, "]", sep="")

    cat(title, "\n")
    print(m)
    cat("\n\n")
  }
}
#' Print Summary of a Rare-event Logistic Model
#'
#' Prints the 
#' @usage
#' \method{print}{summary.relogit}(x, digits = max(3, getOption("digits") - 3), ...)
#' @S3method print summary.relogit
#' @param x an ``relogit.summary'' object produced by the ``summary'' method.
#' @param digits an integer specifying the number of digits of precision to
#' specify
#' @param ... parameters passed forward to the ``print.glm'' function
#' @return x (invisibly)
print.summary.relogit <- function(
                                  x,
                                  digits = max(3, getOption("digits") - 3),
                                  ...

                                  ) {
  # Straight-forwardly print the model using glm's method
  ## Was:
  ##stats:::print.glm(x, digits = digits, ...)

  ##  ":::" not allowed by CRAN
  ## Copied from Stats Internals
  ## Temporary Patch / Need to write print method now

 print.relogitglm<-function (x, digits = max(3L, getOption("digits") - 3L), ...)
  {
    cat("\nCall:  ", paste(deparse(x$call), sep = "\n", collapse = "\n"), 
        "\n\n", sep = "")
    if (length(coef(x))) {
        cat("Coefficients")
        if (is.character(co <- x$contrasts)) 
            cat("  [contrasts: ", apply(cbind(names(co), co), 
                1L, paste, collapse = "="), "]")
        cat(":\n")
        print.default(format(x$coefficients, digits = digits), 
            print.gap = 2, quote = FALSE)
    }
    else cat("No coefficients\n\n")
    cat("\nDegrees of Freedom:", x$df.null, "Total (i.e. Null); ", 
        x$df.residual, "Residual\n")
    if (nzchar(mess <- naprint(x$na.action))) 
        cat("  (", mess, ")\n", sep = "")
    cat("Null Deviance:\t   ", format(signif(x$null.deviance, 
        digits)), "\nResidual Deviance:", format(signif(x$deviance, 
        digits)), "\tAIC:", format(signif(x$aic, digits)))
    cat("\n")
    invisible(x)
}

 print.relogitglm(x, digits = digits, ...)
  
  

  #  Additional slots

  # Prior co
  if (x$prior.correct) 
    cat("\nPrior correction performed with tau =", x$tau, "\n")

  # Weighting? Sure, if it exists, we'll print it.
  if (x$weighting) 
    cat("\nWeighting performed with tau =", x$tau, "\n")

  # If there is bias-correction
  if (x$bias.correct)
    cat("Rare events bias correction performed\n")

  # If robust errors are computed...
  if (!is.null(x$robust))
    cat("\nRobust standard errors computed using", x$robust, "\n")

  # This is not a mutator assignment!
  class(x) <- "summary.glm"

  # Return object to be printed invisibly
  invisible(x)  
}
#' Print Summary of a Rare-event Logistic Model
#'
#' ...
#' @usage
#' \method{print}{summary.relogit2}(x, digits = max(3, getOption("digits") - 3), ...)
#' @S3method print summary.relogit2
#' @param x the object to print
#' @param digits an integer specifying the number of digits of precision
#' @param ... ignored parameters
#' @return x (invisibly)
print.summary.relogit2 <- function(x,
                                   digits = max(3, getOption("digits") - 3),
                                  ...
                                  ) {
  cat("\nCall:\n", deparse(x$call), "\n\n", sep = "")
  print(x$lower.estimate)
  print(x$upper.estimate)
}
#' Print Values of a Summarized ``sim'' Object
#'
#' Print values of simulated quantities of interest (stored in a ``summary.sim''
#' object.
#' @usage \method{print}{summary.sim}(x, ...)
#' @S3method print summary.sim
#' @param x a 'summary.sim' object
#' @param ... ignored parameters
#' @return the value of the `summary.sim' object (invisibly)
#' @author Matt Owen \email{mowen@@iq.harvard.edu}
print.summary.sim <- function(x, ...) {
  # Rename 'x' 'summary'
  summary <- x

  obj <- summary$zeligcall
  model <- summary$model
  x <- summary$x
  x1 <- summary$x1
  stats <- summary$stats
  num <- summary$num

  # Error if there are no statistics to display
  if (is.null(stats))
    stop("stats object cannot be NULL")

  # new-line
  cat("\n")

  # Print model name
  cat("Model: ", model, "\n")

  # Print number of simulations
  cat("Number of simulations: ", num, "\n")

  # new-line
  cat("\n")

  # Display information about the X setx object
  # This should probably be reconsidered in the future
  if (!is.null(x$matrix)) {
    cat("Values of X\n")
    print(as.matrix(x$matrix))

    # new-line
    cat("\n")
  }
  else if (is.list(x$s.x)) {
    # add special hooks here?
  }

  # Display information about the X1 setx object
  # This should probably be reconsidered in the future
  if (!is.null(x1$matrix)) {
    cat("Values of X1\n")
    print(as.matrix(x1$matrix))

    # new-line
    cat("\n")
  }

  # Decrementing the size of the list will give us an easy way to print
  size <- length(stats)

  # Loop across all qi's
  for (key in names(stats)) {
    # Create variable for code clarity
    val <- stats[[key]]

    if (!is.qi(val))
      next

    # Display Title
    cat(key, "\n")

    # Round value if numeric
    if (is.numeric(val))
      print(round(val*(1000))/1000)

    # Simply print if anything else
    else
      print(val)

    # Print a new-line between qi's
    if (size <- size - 1) {
      cat("\n")
    }
  }

  # Return invisibly
  invisible(x)
}
#' Print Multiply Imputed Simulations Summary
#'
#' Prints summary information about Multiply Imputed Fits
#' @usage \method{print}{summarySim.MI}(x, digits=3, ...)
#' @S3method print summarySim.MI
#' @param x a 'summarySim.MI' object
#' @param digits an integer specifying the number of digits of precision to
#'   print
#' @param ... ignored parameters
#' @author Matt Owen \email{mowen@@iq.harvard.edu}
print.summarySim.MI <- function(x, digits=3, ...) {
  for (qi.name in names(x)) {
    if (!is.valid.qi.list(x[[qi.name]]))
      next

    summed.qi <- qi.summarize(qi.name, x[[qi.name]])
    print(summed.qi)
    cat("\n")
  }

  invisible(x)
}

#' Row-bind Matrices and Lists
#' @param x a list or a matrix
#' @param y a list or a matrix
#' @return a matrix
#' @author Matt Owen \email{mowen@@iq.harvard.edu}
.bind <- function (x, y) {

  # Get names for future columns

  if (!is.matrix(x))
    x <- matrix(x, nrow=1, ncol=length(x), dimnames=list(NULL, names(x)))

  if (missing(y))
    return(x)

  if (!is.matrix(y))
    y <- matrix(y, nrow=1, ncol=length(y), dimnames-list(NULL, names(y)))

  names <- unique(c(colnames(x), colnames(y)))

  ncol <- length(names)

  X <- matrix(NA, nrow=nrow(x), ncol=ncol, dimnames=list(NULL, names))
  Y <- matrix(NA, nrow=nrow(y), ncol=ncol, dimnames=list(NULL, names))

  X[, colnames(x)] <- x
  Y[, colnames(y)] <- y

  rbind(X, Y)
}

#' Check If Object Is a List of Valid Quantities of Interest
#' @param x an object to be tested
#' @return TRUE or FALSE
#' @author Matt Owen \email{mowen@@iq.harvard.edu}
is.valid.qi.list <- function (x) {

  # if it is not a list or that list has no entries
  if (!(is.list(x) && length(x)))
    return(FALSE)

  # if any are not a matrix

  for (val in x) {

    if (is.matrix(val) && !(ncol(val) && ncol(val)))
      return(FALSE)

    else if (is.list(val) && !length(val))
      return(FALSE)
  }

  TRUE
}
#' Print values of ``zelig'' objects
#'
#' Print the zelig object as a list
#' @usage \method{print}{zelig}(x, ...)
#' @S3method print zelig
#' @param x a `zelig' object
#' @param ... ignored parameters
#' @return the `zelig' object (invisibly)
#' @export 
#' @author Matt Owen \email{mowen@@iq.harvard.edu}
print.zelig <- function(x, ...) {
  class(x) <- "list"
  print(x)
}