R/ltx_table_design.r

In RichardHooijmaijers/R3port: Report Functions to Create HTML and PDF Files

#------------------------------------------ ltx_table_design ------------------------------------------
#' Designs a table based on a object returned by the table_prep function
#'
#' This function designs the a latex table based on the data frame list returned by the table_prep function.
#'
#' @param dfl list generated by the table_prep function which serves as the base of the table to be generated
#' @param uselabel logical indicating if labels should be used for the x variable(s).
#'    If set to TRUE, the function will try to use the label attribute for the display of x variable(s).
#' @param yhead logical indicating if the y variable should also be set as header in the table.
#' @param footnote character string with the footnote to be placed in the footer of the page (LaTeX coding can be used for example to create line breaks)
#' @param tablenote character string with the table note to be placed directly below the table (LaTeX coding can be used for example to create line breaks)
#' @param mancol character string to define manual column alignment. in case argument is NULL, a sensible default will be set.
#' @param size character string to define the font size of the table
#' @param title character string to define the title of the table which will be added to the caption
#' @param titlepr character string to define the prefix of the table title. Can be used to create custom table numbering
#' @param xabove logical indicating if the first unique x variable should be placed in the table row above. Mostly used to save space on a page
#' @param group number indicating which x variables should be grouped (displayed in table with a certain white space) and interpreted as x[1:group]
#' @param xrepeat logical indicating if duplicate x values should be repeated in the table or not
#' @param hyper logical indicating if a hypertarget should be set used for bookmarks
#' @param tabenv character with the table environment to use. Currently "longtable" and "tabular" are supported
#' @param label character with the label to add after the caption for referencing the table in text
#' @param flt character with the type of floating environment to use (onyl applicable for tabular environment)
#'
#' @details This function designs a latex pivot table based on the results of the table_prep output. This means that the function
#'   Should always be used in conjunction with this function.
#' @return The function returns a vector that defines the entire latex table. This vector can be adapted manually
#'   however it is intended to be used in a print function to add to a latex document.
#'
#' @export
#' @examples
#'
#' \dontrun{ltx_table_design(lstobject)}

ltx_table_design <- function(dfl,uselabel=TRUE,yhead=FALSE,footnote="",tablenote="",mancol=NULL,size="\\normalsize",title="table",titlepr=NULL,
                             xabove=TRUE,group=NULL,xrepeat=FALSE,hyper=TRUE,tabenv="longtable",label=NULL,flt="h"){

  # Create pre-table attributes
  tbl <- NULL
  if(hyper & !is.null(titlepr)) tbl <- c(tbl,paste0("\\hypertarget{",title,"}{} \\bookmark[dest=",title,",level=0]{",titlepr,": ",title,"}"))
  if(hyper & is.null(titlepr))  tbl <- c(tbl,paste0("\\hypertarget{",title,"}{} \\bookmark[dest=",title,",level=0]{",title,"}"))
  if(!is.null(titlepr))  tbl <- c(tbl,paste0("\\renewcommand{\\tablename}{} \\renewcommand\\thetable{{",titlepr,"}}"))
  if(footnote!="") tbl <- c(tbl,paste0("\\lfoot{\\footnotesize ",footnote,"}"))

  coldef  <- ifelse(is.null(mancol),paste((c(rep("l",length(dfl$tblo$x)),rep("r",ncol(dfl$tbld)-length(dfl$tblo$x)))),collapse=""),mancol)
  labdef  <- ifelse(is.null(label),"",paste0("\\label{",label,"}"))
  if(tabenv=="longtable") tbl <- c(tbl,paste0("\\begingroup",size,"\\begin{longtable}{",coldef,"}\n\\caption{",title,"}",labdef,"\\\\"))
  if(tabenv=="tabular")   tbl <- c(tbl,paste0("\\begin{table}[",flt,"]\n\\caption{",title,"}",labdef," ",size,"\\begin{tabular}{",coldef,"}\n"))

  # Create header (check for future if hdr can be provided as argument (to create non standard tables))
  hdrl <- plyr::llply(1:length(dfl$tblo$y),function(num){
    hdrd <- dfl$tblh
    hdrd <- hdrd[!duplicated(do.call("paste",hdrd[1:num])),]
    hdr  <- NULL
    if(yhead==TRUE){
      ylb <- dfl$tblo$y[num]
      if(uselabel) ylb <- ifelse(is.null(attr(dfl$odata[,ylb],'label')),ylb,attr(dfl$odata[,ylb],'label'))
      hdr <- c(hdr,paste(rep("&",length(dfl$tblo$x)),collapse=""))
      hdr <- c(hdr,paste("\\multicolumn{",sum(hdrd[,paste0("yn",num)]),"}{c}{",ylb,"}","\\\\"))
      hdr <- c(hdr,paste0("\\cmidrule(lr){",min(hdrd[,paste0("ystr",num)]),"-",max(hdrd[,paste0("ystp",num)]),"}"))
    }
    if(num!=length(dfl$tblo$y)){
      hdr <- c(hdr,paste(rep("&",length(dfl$tblo$x)),collapse=""))
      hdr <- c(hdr,paste(paste("\\multicolumn{",hdrd[,paste0("yn",num)],"}{c}{",hdrd[,paste0("y",num)],"}",collapse="&",sep=""),"\\\\"))
      hdr <- c(hdr,paste("\\cmidrule(lr){",hdrd[,paste0("ystr",num)],"-",hdrd[,paste0("ystp",num)],"}",collapse=" ",sep=""))
    }else{
      xlb <- dfl$tblo$x
      if(uselabel) xlb <- sapply(xlb,function(lbls) ifelse(is.null(attr(dfl$odata[,lbls],'label')),lbls,attr(dfl$odata[,lbls],'label')))
      hdr <- c(hdr,paste(paste(xlb,collapse= " & "),"&", paste(hdrd[,paste0("y",num)], collapse= " & "),"\\\\"))
      hdr <- c(hdr,"\\hline")
    }
    return(hdr)
  })

  if(tabenv=="longtable"){
    tbl <- c(tbl,"\\toprule",unlist(hdrl),"\\endfirsthead")
    tbl <- c(tbl,paste0("\\multicolumn{",ncol(dfl$tbld),"}{c}{\\tablename~\\thetable{}: (continued)}\\\\\\\\"))
    tbl <- c(tbl,"\\toprule",unlist(hdrl),"\\endhead \\hline \\endfoot \\hline","\\endlastfoot")
  }else{
    tbl <- c(tbl,"\\hline",unlist(hdrl))
  }

  # Add data and close off
  dup1 <- !duplicated(dfl$tbld[,dfl$tblo$x[1]])
  if(!is.null(group)) dup2 <- !duplicated(dfl$tbld[,1:group,drop=FALSE],fromLast=TRUE)
  if(!xrepeat){
    duplst <- plyr::llply(1:length(dfl$tblo$x),function(coln){duplicated(do.call("paste",dfl$tbld[,1:coln,drop=FALSE]))})
    plyr::l_ply(1:length(duplst),function(coln){dfl$tbld[unlist(duplst[coln]),coln] <<- ""})
  }

  dtal <- plyr::llply(1:nrow(dfl$tbld),function(num){
    if(xabove & dup1[num]==TRUE){
      dta <- paste("\\multicolumn{",ncol(dfl$tbld)-1,"}{l}{\\textit{",dfl$tbld[num,1],"}}\\\\")
      dta <- c(dta,paste("&",paste(dfl$tbld[num,-1], collapse= " & "),"\\\\"))
    }else{
      dta <- paste(paste(dfl$tbld[num,], collapse= " & "),"\\\\")
    }
    if(!is.null(group)){if(dup2[num]==TRUE) dta <- c(dta,"[2ex]")}
    return(dta)
  })
  tbl <- c(tbl,unlist(dtal))
  if(tabenv=="longtable") {
    tbl <- c(tbl,"\\end{longtable}",tablenote,"\\endgroup")
  }else{
    tbl <- c(tbl,"\\hline\\end{tabular}\\\\",tablenote,"\\end{table}")
  }
  return(tbl)
}