R/make.tables.R

In carlopacioni/HexSimR: An R Package For Post HexSim Simulation Analysis

#' Make a table from HexSimR results
#'
#' \code{make.table} reads the result files generated by HexSimR and compiles a
#' table after having rounded the decimal digits.
#'
#' \code{make.table} can process either descriptive statistics (generated using
#' \code{collate.census}, \code{ranges} or \code{move}) or statistical
#' comparisons generated using \code{SSMD.census}, \code{SSMD.ranges} or
#' \code{SSMD.move}), but only one type of result in any one time. For each run
#' of \code{make.table} a sheet is created as output in a .xls file. If the name
#' of the xls file is kept equal, the new sheet is added to the existing file.
#' \strong{ATTENTION:} If the name of the new sheet is the same of an existing
#' one, the data will be pasted over in the existing sheet, possibly making the
#' results incomprehensible.
#'
#' When processing census data, several files can be passed at once by passing a
#' character vector of length > 1 to \code{fnames}. Note that the extension
#' (.csv) of the file is used to identify whether it was requested to process
#' descriptive statistics generated by movement reports. If you have changed the
#' extensions of the result files, this function may have impredictable results.
#'
#' When more than one scenario is processed, then \code{make.table} assumes
#' that, within each scenario, the result file name is the same. The only
#' exception is when processing the descriptive statistics of census data. In
#' this case, the name of scenario is automatically added to the suffix. In
#' these cases, the suffix of the files has to be passed to \code{fnames} (i.e.
#' \emph{"[ncensus].all.xlsx"}, where \emph{"ncensus"} is the number of the
#' census event, and \emph{".comb.xlsx"} is the standard suffix that HexSimR
#' adds to all files generated with \code{collate.census}.
#'
#' \code{colh} is used to pass the headings of the columns to be processed. It
#' \strong{MUST} be passed as a list, with an element for each file that was
#' passed with \code{fnames}.
#'
#' If \code{SSMD=TRUE} and \code{scenarios="all"}, R may throw an error because
#' the base scenario is included in \code{scenarios} (unless it was manually
#' removed) but it is not present in the result file. When \code{SSMD=TRUE} a
#' character vector has to be passed to \code{scenarios}.
#'
#' When \code{SSMD=TRUE}, currently, only p-values are reported in the table.
#'
#' Note that when \code{SSMD=TRUE}, and the function is pointed to a SSMD
#' comparison of ranges report statistics, the appropriate setting for the time
#' step is \code{time.steps=NULL} (default) because these are already subsetted
#' when the SSMD comparison is done, unless all time steps were kept when
#' calling \code{ranges} or \code{multi.reports}. Also, when this function is
#' used to summarise descriptive statistics from ranges or movement data, this
#' argument must be NULL because there are no time steps in these outputs.
#'
#' By default, the sheet in the xls file takes name "Descriptive" or "SSMD",
#' depending on whether \code{SSMD=FALSE} or \code{SSMD=TRUE} respectively. This
#' behaviour can be altered by passing a character vector to \code{tab.name}.
#'
#'
#' @param fnames The name(s) of the output file(s) to be processed. If more the
#'   one scenario is passed, the output file names have to be all equal
#' @param time.steps A numeric vector with the time steps to include. If NULL
#'   (default), all time steps are included. See details for more information
#' @param SSMD Whether the data being processed are SSMD comparisons (default:
#'   FALSE)
#' @param colh A list with as many elements as the length of fnames. Each
#'   element is a character vector with the names of the column headings to be
#'   considered for the relative fnames (default: ranges' headings)
#' @param vround The number of digits the variable (e.g. the mean, the p-values)
#'   should be rounded to
#' @param sdround If SSMD=FALSE, the number of digits the standard deviation
#'   should be rounded to
#' @param table.name The name of the file where to save the table
#' @param tab.name The name of the tab to be saved in the xls file. By default,
#'   "Descriptive" or "SSMD", depending on whether \code{SSMD=FALSE} or
#'   \code{SSMD=TRUE} respectively.
#' @param save2disk Whether to save to disk the table
#' @param dir.out The directory where to save the table. If NULL (default), the
#'   file will be written in the 'Results' folder
#' @inheritParams collate.census
#' @seealso \code{\link{collate.census}}, \code{\link{ranges}},
#'   \code{\link{move}}, \code{\link{SSMD.census}}, \code{\link{SSMD.ranges}},
#'   \code{\link{SSMD.move}}
#' @import XLConnect
#' @import data.table
#' @return A data.frame (data.table) with the compiled table. If save2disk=TRUE
#'   an xls file is also saved to disk.
#' @export
  make.table <- function(path.results=NULL, scenarios="all", fnames, SSMD=FALSE, 
                colh=list(c("GroupSize", "Resources",	"nGroups", "ha", "sqkm")), 
                vround=1, sdround=1, time.steps=NULL, table.name="Tables.xlsx", 
                tab.name=NULL, save2disk=TRUE, 
                dir.out=NULL) {
  #----------------------------------------------------------------------------#
  # Helper functions
  #----------------------------------------------------------------------------#
  
  combine <- function(i, data_r, data_sd_r) {
    comb <- paste0(data_r[[i]], " (", data_sd_r[[paste0(i, "_sd")]], ")")
    return(comb)
  }
  
  read_res <- function(scenario, path.results, fname, SSMD, time.steps, colh, vround, 
                        sdround, dir.out) {
    nC_fname <- nchar(fname)
    ext <- substr(fname, nC_fname - 3, nC_fname)
    if(SSMD == FALSE & ext == ".csv") {
      tab <- fread(paste(path.results, scenario, fname, sep="/"))
      setkey(tab, V1)
      data <- tab["Mean", colh, with=FALSE]
      data_sd <- tab["Std", colh, with=FALSE]
      sds <- paste0(colh, "_sd")
      setnames(data_sd, sds)
      data <- cbind(data, data_sd)
      colh <- make.names(colh)
      sds <- make.names(sds)
      setnames(data, c(colh, sds))
    } else {
      if(substr(fname, nC_fname - 8, nC_fname) == "comb.xlsx") {
        fname <- paste(scenario, fname, sep=".") 
      } 
      wb <- loadWorkbook(paste(path.results, 
                               if(SSMD == FALSE) scenario, 
                               fname,
                               sep="/"))
      if(SSMD == FALSE) {
        tab <- data.table(readWorksheet(wb, sheet="means"))
      } else {
        if(nchar(scenario) > 25) {
          scen_short <- substr(scenario, nchar(scenario) - 24, nchar(scenario)) 
        } else {
          scen_short <- scenario
        }
        tab <- data.table(readWorksheet(wb, sheet=paste0("pval_", scen_short)))
      }
      if(is.null(time.steps)) {
        data <- tab[, colh, with=FALSE]
      } else {
        setkey(tab, Time.Step)
        data <- tab[J(time.steps), colh, with=FALSE]
      }
      
      if(SSMD == FALSE) {
        tab <- data.table(readWorksheet(wb, sheet="sd"))
        if(is.null(time.steps)) {
          data_sd <- tab[, colh, with=FALSE]
        } else {
          setkey(tab, Time.Step)
          data_sd <- tab[J(time.steps), colh, with=FALSE]
        }
        
        sds <- paste0(colh, "_sd")
        setnames(data_sd, sds)
        data <- cbind(data, data_sd)
      }
    }
    
    data_r <- data[, lapply(.SD, round, vround), .SDcols=colh]
    
    if(SSMD == FALSE) {
      data_r[, (colh) := lapply(colh, 
                                combine, data_r,
                                data[, lapply(.SD, round, sdround), .SDcols=sds])]
    }

    data_r[, Scenario := scenario]
    if(!is.null(time.steps))  data_r[, TimeStep := time.steps]
    
    setcolorder(data_r, c("Scenario", if(!is.null(time.steps)) "TimeStep",  colh))
    
    return(data_r)
  }
  #----------------------------------------------------------------------------#
  
  txt <- "Please, select the 'Results' folder within the workspace"
  if(is.null(path.results)) path.results <- tk_choose.dir(caption = txt)
  if(length(scenarios) == 1) {
    if(scenarios == "all") 
      scenarios <- list.dirs(path=path.results, full.names=FALSE, recursive=FALSE)
  }
  
  if(is.null(tab.name)) {
    if(SSMD) tab.name <- "SSMD" else tab.name <- "descriptive"
    }

  ldat <- list()
  i <- 0
  for(fname in fnames) {
    i <- i + 1
    ldat[[i]] <- lapply(scenarios, read_res, path.results, fname=fname, SSMD, 
                        time.steps, colh[[i]], vround, sdround, dir.out)
    ldat[[i]] <- rbindlist(ldat[[i]], use.names=T)
  }
  data <- do.call(cbind, ldat)
  scen_inst <- grep("Scenario", names(data))
  if(length(scen_inst) > 1) {
    data[, scen_inst[2:length(scen_inst)] := NULL]
  }
  
  time_inst <- grep("TimeStep", names(data))
  if(length(time_inst) > 1) {
    data[, time_inst[2:length(time_inst)] := NULL]
  }
 
  if(save2disk == TRUE) {
    dir.create(paste(path.results, dir.out, sep="/"), showWarnings=FALSE, 
               recursive=TRUE)
    wb <- loadWorkbook(paste(path.results, dir.out, table.name, sep="/"), 
                       create=TRUE)
    createSheet(wb, name=tab.name)
    writeWorksheet(wb, data, sheet=tab.name)
    saveWorkbook(wb)
  }
  return(data)
  }