crosstable

library(magrittr)
library(stringr)

# Función utilizada en Rkward para unir tablas.
bind.tables <- function (...) {
  if (is.list(..1)) tables <- ..1
  else tables <- list(...)
  output <- unlist(tables)
  dim (output) <- c(dim(tables[[1]]), length(tables))
  dimnames(output) <- c (dimnames(tables[[1]]), list("statistic"=names(tables)))
  output
}

crosstable <- function(..., data=parent.frame(), row.vars = NULL, col.vars = NULL, stats = "freq", col.total = FALSE, row.total = FALSE, stats.on.cols = TRUE, digits = 2) {
  # This function will use table or xtabs to make an R table
  # can recive as arguments a couple of vectors or an already made table
  if (is.table(..1))
    table1 <- ..1
  else if (class(..1)=="formula")
    table1 <- xtabs(..1, data=data)
  else
    table1 <- table(...)

  # We should build the arguments col.vars or row.vars if not defined
  if(xor(is.null(col.vars), is.null(row.vars))) {
    if (is.null(row.vars)) {
      if (is.character(col.vars))
        col.vars <- which(names(dimnames(table1)) %in% col.vars)
      row.vars <- 1:length(dim(table1))
      row.vars <- row.vars[-col.vars]
    } else if (is.null(col.vars)) {
      if (is.character(row.vars))
        row.vars <- which(names(dimnames(table1)) %in% row.vars)
      col.vars <- 1:length(dim(table1))
      col.vars <- col.vars[-row.vars]
    }
  } else if(is.null(col.vars) & is.null(row.vars)) {
    col.vars <- length(dim(table1))
    row.vars <- 1:(length(dim(table1))-1)
  }

  # The table to print will be a list of tables made with prop.table
  # the main table is frequency other tables are percentajes
  tablePrint <- lapply(stats, function(x) {
    if (x == "count")
      table1
    else if (x == "total")
      prop.table(table1)*100
    else if (x == "row")
      prop.table(table1, col.vars)*100
    else if (x == "column")
      prop.table(table1, row.vars)*100
  })

  # This will define the names of the stats columns
  f <- stats %in% c("column","row","total")
  tableNames <- stats
  tableNames[f] <- paste("% of", tableNames[f])

  names(tablePrint) <- tableNames
  tablePrint <- bind.tables(tablePrint)

  # The table is the main table to perform chisq.
  # The tablePrint is an attribute only to show.
  structure(table1,
            tablePrint = tablePrint,
            arguments = list(row.vars = row.vars, col.vars = col.vars, stats = stats, stats.on.cols = stats.on.cols, digits = digits),
            class="crosstable")
}

print.crosstable <- function(x) {
  invisible(x)
  #-------------------#
  # GENERAL VARIABLES #
  #-------------------#
  tablePrint <- attr(x, "tablePrint")
  arguments <- attr(x, "arguments")

  tableDimNames <- dimnames(tablePrint)
  tablePrint.names <- names(dimnames(tablePrint))

  if(arguments$stats.on.cols) {
    col.vars <- c(arguments$col.vars, (length(dim(x))+1):length(dim(tablePrint)))
    row.vars <- arguments$row.vars
  }else{
    col.vars <- arguments$col.vars
    row.vars <- c(arguments$row.vars, (length(dim(x))+1):length(dim(tablePrint)))
  }

  row.names <- tablePrint.names[row.vars]
  row.dim <- dim(tablePrint)[row.vars]
  col.names <- tablePrint.names[col.vars]
  col.dim <- dim(tablePrint)[col.vars]

  #-------------------------#
  # MAKE THE TABLE TO PRINT #
  #-------------------------#
  dimTable <- dim(tablePrint)

  # Index of original table to make
  s <- sapply(1:prod(dimTable[(length(dimTable)-1):length(dimTable)]),rep,prod(dimTable[-((length(dimTable)-1):length(dimTable))]))
  dim(s) <- dimTable
  s <- apply(s, col.vars[length(col.vars)], c)
  s <- sort(s, index.return=TRUE)$ix

  tablePrint %<>%
    round(arguments$digits) %>%
    apply(col.vars[length(col.vars)], format)

  #Now we sort the table using the s index
  tablePrint <- as.vector(tablePrint)[s]
  dim(tablePrint) <- dimTable

  f <- arguments$stats %in% c("column","row","total")
  tableFormat <- rep(" ", length(arguments$stats))
  tableFormat[f] <- "%"

  # The Sweep function should add % to the cells
  "%p%" <- function(x,y) paste0(x,y)
  tablePrint <- sweep(tablePrint, length(dimTable), tableFormat, "%p%")
  dim(tablePrint) <- dimTable

  #colHeaders
  colHeaders <- tableDimNames[col.vars]
  # Table Width for columns based on the length of var labels
  tableWidth <- 0
  for (i in length(colHeaders):1) {
    # Ajustment of the column width by the variable label
    if (nchar(names(colHeaders)[i]) > sum(nchar(colHeaders[[i]]))) {
      dif <- nchar(names(colHeaders)[i]) - sum(nchar(colHeaders[[i]]))
      extraChar <- round(dif*(nchar(colHeaders[[i]])/sum(nchar(colHeaders[[i]]))))
      if (sum(extraChar) < dif)
        extraChar <- extraChar + ceiling((dif-sum(extraChar))*(nchar(colHeaders[[i]])/sum(nchar(colHeaders[[i]]))))
      colWidth <- nchar(colHeaders[[i]]) + extraChar
    } else {
      colWidth <- nchar(colHeaders[[i]])
    }
    # Ajustment of the lower level vars by the upper level vars
    if(sum(colWidth) > sum(tableWidth) & sum(tableWidth) > 0) {
      sapply(1:length(colWidth),
             function(x) {
               if(colWidth[x] > sum(tableWidth)) {
                 dif <- colWidth[x] - sum(tableWidth)
                 extraChar <- round(dif*(tableWidth/sum(tableWidth)))
                 if (sum(extraChar) < dif)
                   extraChar <- extraChar + ceiling((dif-sum(extraChar))*(tableWidth/sum(tableWidth)))
                 tableWidth + extraChar
               } else {
                 tableWidth
               }
             }
      ) -> tableWidth
    } else if (sum(tableWidth) == 0) {
      tableWidth <- colWidth
    } else {
      tableWidth <- rep(tableWidth, length(colWidth))
    }
  }

  # Turn table in to ftable and format it to be printed
  tablePrint <- ftable(tablePrint, col.vars = col.vars)
  tableWidth <- pmax(tableWidth, nchar(apply(tablePrint,2,max)))
  tablePrint <- mapply(function(x,y) format(tablePrint[,x], justify ="right", width=y), 1:prod(col.dim), tableWidth)
  dimnames(tablePrint) <- NULL

  # A matrix with row headers.
  mapply(
    function(x) {
      rvalue <- character(0)
      for (i in tableDimNames[[row.names[x]]]) {
        rvalue <- c(rvalue,i,rep("", prod(c(row.dim,1)[(x+1):(length(row.dim)+1)])-1))
      }
      rep(rvalue, prod(row.dim[1:x])/row.dim[x])
    }
    , 1:length(row.dim)
  )  -> rowHeaders
  for(i in 1:ncol(rowHeaders)) rowHeaders[,i] <- format(rowHeaders[,i], width=nchar(row.names)[i])
  dim(rowHeaders) <- c(prod(row.dim),length(row.dim))
  rowHeaders.nchar <- nchar(rowHeaders[1,])

  # Start of the table
  cat("|", strrep("-", sum(rowHeaders.nchar+1,tableWidth+1)-1), "|\n", sep="")

  #Print the table col headers
  colHeaders <- tableDimNames[col.vars]
  for (i in 1:length(col.dim)) {
    iColRep <- prod(c(1,col.dim)[1:i])
    iColDim <- iColRep*length(colHeaders[[i]])
    sapply(
      1:iColRep,
      function(x)
        sum(tableWidth[1:(length(tableWidth)/iColRep)+(length(tableWidth)/iColRep)*(x-1)])
    ) -> iColWidthLab
    sapply(
      1:iColDim,
      function(x)
        sum(tableWidth[1:(length(tableWidth)/iColDim)+(length(tableWidth)/iColDim)*(x-1)])
    ) -> iColWidth
    nSep <- prod(c(col.dim,1)[(i+1):(length(col.dim)+1)])

    cat("|", paste0(strrep(" ", c(rowHeaders.nchar)), "|"), sep="")
    cat(paste0(stringr::str_pad(rep(names(colHeaders)[i],iColRep),iColWidthLab+nSep*col.dim[i]-1, "both"), "|"), "\n", sep="")
    cat("|", paste0(strrep(" ", c(rowHeaders.nchar)), "|"), strrep("-", sum(tableWidth+1)-1), "|\n", sep="")

    if (i==length(col.dim)) {
      cat("|", paste0(stringr::str_pad(row.names,rowHeaders.nchar,"both", " "),"|"), sep="")
    } else {
      cat("|", paste0(strrep(" ", c(rowHeaders.nchar)), "|"), sep="")
    }
    cat(paste0(stringr::str_pad(rep(colHeaders[[i]],iColRep),iColWidth+nSep-1, "both"), "|"), "\n", sep="")
    if (i<length(col.dim))
      cat("|", paste0(strrep(" ", c(rowHeaders.nchar)), "|"), strrep("-", sum(tableWidth+1)-1), "|\n", sep="")
  }

  # Printing the final table
  cat("|", paste0(strrep("-", c(rowHeaders.nchar,tableWidth)), "|"),"\n", sep="")
  for (i in 1:prod(row.dim)) {
    cat("|", paste0(rowHeaders[i,],"|"), sep="")
    cat(paste0(tablePrint[i,], "|"), sep="")
    cat("\n")
  }

  # Close of the table
  cat("|", strrep("-", sum(rowHeaders.nchar+1,tableWidth+1)-1), "|\n", sep="")
}

## Prueba con dos variables generadas aleatoriamente
gender <- sample(c(1,2), 131, replace=TRUE) %>%
  factor(levels=c(1,2), labels=c("Man", "Woman"))
strata <- sample(c(1,2,3), 131, replace=TRUE) %>%
  factor(levels=c(1,2,3), labels=c("Low", "Middle", "High"))
party <- sample(c(1,2), 131, replace=TRUE) %>%
  factor(levels=c(1,2), labels=c("Right", "Left"))

crosstable(gender, strata, party, stats=c("count", "column", "row"))