gistfile1.txt

myformatCats <- function (tab, nam, tr, type, group.freq, npct, pctdig, exclude1, 
                          long, prtest, latex = FALSE, testUsed = character(0), npct.size = "scriptsize", 
                          pdig = 3, eps = 0.001, footnoteTest = TRUE, dotchart = FALSE) 
{
  gnames <- names(group.freq)
  nr <- nrow(tab)
  if (ncol(tab) < length(group.freq)) {
    tabfull <- matrix(NA, nrow = nr, ncol = length(group.freq), 
                      dimnames = list(dimnames(tab)[[1]], gnames))
    tabfull[, dimnames(tab)[[2]]] <- tab
    tab <- tabfull
  }
  denom <- if (type == 1) apply(tab, 1, sum)
  else group.freq
  pct <- 100 * (if (ncol(tab) > 1) 
    sweep(tab, 1, denom, FUN = "/")
                else tab/denom)
  cpct <- paste(format(round(pct, pctdig)), if (latex) 
    "\\%"
                else "%", sep = "")
  denom.rep <- matrix(rep(format(denom), nr), nrow = nr, byrow = TRUE)
  if (npct != "none") 
    cpct <- paste(cpct, if (latex) 
      switch(npct, numerator = paste("{\\", npct.size, 
                                     " (", format(tab), ")}", sep = ""), denominator = paste("{\\", 
                                                                                             npct.size, " of", denom.rep, "}"), both = paste("{\\", 
                                                                                                                                             npct.size, " $\\frac{", format(tab), "}{", denom.rep, 
                                                                                                                                             "}$}", sep = ""))
                  else switch(npct, numerator = paste("(", format(tab), 
                                                      ")", sep = ""), denominator = paste("of", denom.rep), 
                              both = paste(format(tab), "/", denom.rep, sep = "")))
  if (latex) 
    cpct <- sedit(cpct, " ", "~")
  dim(cpct) <- dim(pct)
  dimnames(cpct) <- dimnames(pct)
  cpct[is.na(pct)] <- ""
  lev <- dimnames(pct)[[1]]
  exc <- exclude1 && (nr == 2) && (type == 1)
  rl <- casefold(dimnames(pct)[[1]])
  binary <- type == 1 && exc && (all(rl %in% c("0", "1")) | 
    all(rl %in% c("false", "true")) | all(rl %in% c("absent", 
                                                    "present")))
  if (binary) 
    long <- FALSE
  jstart <- if (exc) 
    2
  else 1
  nw <- if (lg <- length(group.freq)) 
    lg
  else 1
  lab <- if (binary) 
    nam
  else if (long) 
    c(nam, paste("   ", lev[jstart:nr]))
  else c(paste(nam, ":", lev[jstart]), if (nr > jstart) paste("   ", 
                                                              lev[(jstart + 1):nr]))
  cs <- matrix("", nrow = long + (if (exc) 
    nr - 1
                                  else nr), ncol = nw + (length(tr) > 0), dimnames = list(lab, 
                                                                                          c(gnames, if (length(tr)) "" else NULL)))
  if (nw == 1) 
    cs[(long + 1):nrow(cs), 1] <- cpct[jstart:nr, ]
  else cs[(long + 1):nrow(cs), 1:nw] <- cpct[jstart:nrow(cpct), 
                                             gnames]
  if (latex && dotchart && ncol(pct) <= 3) {
    locs <- c(3, -3, 5, -5, 7, -7, 9, -9)
    points <- c("\\circle*{4}", "\\circle{4}", "\\drawline(0,2)(-1.414213562,-1)(1.414213562,-1)(0,2)")
    point.loc <- sapply(jstart:nrow(pct), function(i) {
      paste(ifelse(is.na(pct[i, ]), "", paste("\\put(", 
                                              pct[i, ], ",0){", points[1:ncol(pct)], "}", sep = "")), 
            collapse = "")
    })
    error.loc <- character(nrow(tab) - exc)
    k <- 0
    for (i in jstart:ncol(tab)) {
      if (i > jstart) {
        p1prime <- (tab[, i] + 1)/(denom[i] + 2)
        d1 <- p1prime * (1 - p1prime)/denom[i]
        for (j in jstart:(i - 1)) {
          k <- k + 1
          p2prime <- (tab[, j] + 1)/(denom[j] + 2)
          error <- 196 * sqrt(d1 + p2prime * (1 - p2prime)/denom[j])
          bar <- ifelse(is.na(error), "", paste("\\put(", 
                                                (pct[, i] + pct[, j])/2 - error, ",", locs[k], 
                                                "){\\line(1,0){", error * 2, "}}", sep = ""))
          error.loc <- paste(error.loc, bar, sep = "")
        }
      }
    }
    scale <- character(nrow(tab) - exc)
    scale[1] <- "\\multiput(0,2)(25,0){5}{\\color[gray]{0.5}\\line(0,-1){4}}\\put(-5,0){\\makebox(0,0){\\tiny 0}}\\put(108,0){\\makebox(0,0){\\tiny 1}}"
    cl <- paste("\\setlength\\unitlength{1in/100}\\begin{picture}(100,10)(0,-5)", 
                scale, "\\put(0,0){\\color[gray]{0.5}\\line(1,0){100}}", 
                point.loc, error.loc, "\\end{picture}", sep = "")
    cs[(long + 1):nrow(cs), ncol(cs)] <- cl
  }
  if (length(tr)) {
    ct <- formatTestStats(tr, type == 3, if (type == 1) 
      1
                          else 1:nr, prtest, latex = latex, testUsed = testUsed, 
                          pdig = pdig, eps = eps, footnoteTest = footnoteTest)
    if (length(ct) == 1) 
      cs[1, ncol(cs)] <- ct
    else cs[(long + 1):nrow(cs), ncol(cs)] <- ct
  }
  cs
}