In clinDataReview: Clinical Data Review Tool

library(knitr)
knitr::opts_chunk$set(
    echo = FALSE, 
    warning = FALSE, error = FALSE, message = FALSE, 
    results = "asis"
)

knitr::knit_hooks$set(
    message = function(x, options) {
      paste('\n\n<div class="alert alert-info">',
          gsub('##', '\n', x),
          '</div>', sep = '\n')
    }
)

# print warnings where they occur (warn = 0 by default)
options(warn = 1)

attach(params)

if(!exists("comparisonTableType"))  comparisonTableType <- "none"
if(comparisonTableType != "none" & 
    (!exists("pathDataFolderOld") || !file.exists(file.path(pathDataFolderOld, dataFileName)))
    ){
  warning("No comparison table is included because data from previous batch is not available.")
  comparisonTableType <- "none"
}

if(!exists("patientProfilePath"))   patientProfilePath <- NULL
if(!exists("loopingVar")) loopingVar <- NULL
if(!exists("loopingTotal")) loopingTotal <- TRUE

library(clinDataReview)
library(clinUtils)
library(inTextSummaryTable)
library(plyr)# for dlply, rbind.fill
library(tools)
library(htmltools)

if(!exists("reportTitleLevel")) reportTitleLevel <- 1

# Create a header at the wanted depth
cat(getMdHeader(title = reportTitle, level = reportTitleLevel))

# Load data
if(comparisonTableType != "none") {

  pathsData <- c(
      "currentData" = pathDataFolder,
      "previousData" = pathDataFolderOld
  ) 

} else pathsData <- c("currentData" = pathDataFolder)

dataList <- sapply(names(pathsData), function(dataBatch) {

    pathDataBatch <- pathsData[[dataBatch]]

    pathData <- file.path(pathDataBatch, dataFileName)
    dataAll <- clinUtils::loadDataADaMSDTM(pathData, verbose = FALSE)
    data <- do.call(plyr::rbind.fill, dataAll)

      # Extract label information
      labelVars <- attr(dataAll, "labelVars")

      if(exists("dataProcessing")){
#        msg <- capture.output(
        data <- processData(
                data = data, 
                dataPath = pathDataBatch,
                processing = dataProcessing,
                verbose = TRUE,
                labelVars = labelVars
            )
#       , type = "message")
#        message(paste(collapse = "\n", msg))
        # Labels updated with extra annotation:
        labelVars <- attr(data, "labelVars")
      }

      # Create URL to patient profiles
      if(!is.null(patientProfilePath))
        data <- createPatientProfileVar(
            data = data, 
            patientProfilePath = patientProfilePath,
            checkExist = FALSE
        )

      # only subset of the data if requested
      if(!is.null(loopingVar) && exists("loopingNMax") &&   is.integer(loopingNMax)){

        data <- merge(
            x = data,
            y = unique(data[, loopingVar, drop = FALSE])[seq_len(loopingNMax), , drop = FALSE],
            all = FALSE
        )

      }

      ## total          
      if(exists("dataTotalFileName")) {

        # Load data
        pathDataTotal <- file.path(pathDataBatch, dataTotalFileName)
        dataTotalAll <- clinUtils::loadDataADaMSDTM(pathDataTotal, verbose = FALSE)
        dataTotal <- dataTotalAll[[1]]

        # Extract label information
        labelVarsTotal <- attr(dataTotalAll, "labelVars")

        # Total data processing
        if(exists("dataTotalProcessing")){
          dataTotal <- processData(
              data = dataTotal, 
              dataPath = pathDataBatch, 
              processing = dataTotalProcessing,
              verbose = TRUE,
              labelVars = labelVarsTotal,
              labelData = "total data"
          )
        }

      }else dataTotal <- data

#      attr(data, "message") <- msg

      list(
          data = data,
          dataTotal = dataTotal                 
      )

    }, simplify = FALSE)

labelVars <- attr(dataList$currentData$data, "labelVars")
#messages <- attr(dataList$currentData$data, "message")

dataCurrent <- dataList$currentData$data
dataPrevious <- dataList$previousData$data

# TODO: check what happens if a group is in old but not in new data

dataCurrent <- ddply(dataCurrent, loopingVar, function(dataCurrentI){

    # get old table
    if(!is.null(loopingVar)){
        dataPreviousI <- merge(
            x = unique(dataCurrentI[, loopingVar, drop = FALSE]),
            y = dataPrevious,
            by = loopingVar,
            all = FALSE
        )
    }else   dataPreviousI <- dataPrevious

    argsCompTable <- comparisonTableParams

    argsCompTable$newData <- dataCurrentI
    argsCompTable$oldData <- dataPreviousI
    argsCompTable$outputType <- "newData-diff"

    do.call(clinUtils::compareTables, argsCompTable)

})

dataList$currentData$data <- dataCurrent
dataList$previousData <- NULL

summaryTableList <- sapply(names(dataList), function(dataBatch) {

    ## Extract from list
    data <- dataList[[dataBatch]][["data"]]         
    dataTotal <- dataList[[dataBatch]][["dataTotal"]]

    # format label for 'knitPrintClinDataReview'
    if(!is.null(loopingVar)){
        data[, loopingVar] <- colwise(function(x) gsub("\\.", "", x))(data[, loopingVar, drop = FALSE])
        dataTotal[, loopingVar] <- colwise(function(x) gsub("\\.", "", x))(dataTotal[, loopingVar, drop = FALSE])
    }

    # statistics for patient profiles
    statsPP <- if(!is.null(patientProfilePath))
        setNames(list(quote(statPatientProfileLink)), labelVars["USUBJID"])
    statsExtraPP <- if(!is.null(patientProfilePath))
        list(
            statPatientProfilePath = function(data) 
                toString(sort(unique(data$patientProfilePath))),
            statPatientProfileLink = function(data)
                toString(sort(unique(data$patientProfileLink)))
    )

    ## Create tables
    summaryTable <- dlply(data, loopingVar, function(dataI){

        # extract total dataset
        dataTotalI <- dataTotal
        if(!is.null(loopingVar) && loopingTotal){
            if(any(!loopingVar %in% colnames(dataTotalI)))
                stop("Looping variable(s) are not available in the total dataset. ",
                    "Are you sure you want to compute the total by 'loopingVar'? (see 'loopingTotal').")
                dataTotalI <- merge(
                    x = unique(dataI[, loopingVar, drop = FALSE]), 
                    y = dataTotal, 
                    by = loopingVar, 
                    all = FALSE # only include data if present in y
                )
            }

        ## Params for the table
        argsTable <- tableParams

        # evaluate !r-lazy parameters
        argsTable <- forceParams(argsTable)

        # combine all paths across patients
        # the paths should be collapsed with: ', '
        argsTable$statsExtra <- c(argsTable$statsExtra, statsExtraPP)

        # get specific set of statistics + stats with subjects profiles path
        statsCustom <- argsTable$stats
        if(is.character(statsCustom)) # support old specification
            statsCustom <- eval(expr = parse(text = statsCustom))
        # if statistics are specified for each variable separately:
        if(any(names(statsCustom) %in% argsTable$var)){
            argsTable$stats <- sapply(statsCustom, c, statsPP, simplify = FALSE)
        }else{
            argsTable$stats <- c(statsCustom, statsPP)
        }

        # create table with descriptive statistics (data.frame format)
        argsTable <- c(
            argsTable,
            list(
                data = dataI, 
                labelVars = labelVars,
                dataTotal = dataTotalI
            )
        )
        summaryTable <- do.call(computeSummaryStatisticsTable, argsTable)

    })

    list(
        summaryTable = summaryTable,
        statsPP = statsPP
    )

}, simplify = FALSE)

groups <- lapply(lapply(summaryTableList, "[[", "summaryTable"), names)
groups <- Reduce(union, groups)

summaryTableCombineGroups <- sapply(groups, function(group){

    idx <- ifelse(!is.null(loopingVar), group, 1)
    sumTableCurrent <- summaryTableList$currentData$summaryTable[[idx]]
    sumTableOld <- summaryTableList$previousData$summaryTable[[idx]]

    summaryTableCombine <- inTextSummaryTable::combine(
        Previous = sumTableOld, 
        Current = sumTableCurrent,
        combineVar = "Version",
        combineDir = "col"
    )

}, simplify = FALSE)

summaryTableList <- list(
    currentData = list(
        summaryTable = summaryTableCombineGroups,
        statsPP = summaryTableList$currentData$statsPP
    )
)

## Format messages
#messages <- gsub(" (based on).*", ".", messages)

summaryTable <- summaryTableList$currentData$summaryTable
statsPP <- summaryTableList$currentData$statsPP

if(!exists("tableParamsDocx"))  tableParamsDocx <- list()
tableParamsDocx$outputType <- "flextable"

if(!exists("tableParamsDT"))    tableParamsDT <- list()
tableParamsDT$outputType <- "DT"
tableParamsDT$expandVar <- tableParamsDT$noEscapeVar <- names(statsPP)

summaryTableDT <- sapply(names(summaryTable), function(group){

      idx <- ifelse(!is.null(loopingVar), group, 1)
      sumTable <- summaryTable[[idx]]

      # export to docx      
      tableParamsDocxI <- tableParamsDocx
      tableParamsDocxI$summaryTable <- sumTable

      tableParamsDocxI$file <- 
          sprintf("table_%s.docx",
              strtrim(
                  gsub(" ", "_", gsub("[[:punct:]]", "", reportTitle)
                  ), 30))
      if(!is.null(loopingVar))
        tableParamsDocxI$file <- paste0(
            tools::file_path_sans_ext(tableParamsDocxI$file), 
            "_", formatLabel(group), ".",
            tools::file_ext(tableParamsDocxI$file)
        )
      tableParamsDocxI$file <- file.path("tables", tableParamsDocxI$file)

      if(is.null(tableParamsDocxI$statsVar))
        tableParamsDocxI$statsVar <-  attr(sumTable, "summaryTable")$statsVar
      tableParamsDocxI$statsVar <- setdiff(tableParamsDocxI$statsVar, names(statsPP))       
      ft <- do.call(exportSummaryStatisticsTable, tableParamsDocxI)

      # export to data.table
      tableParamsDTI <- tableParamsDT
      tableParamsDTI$summaryTable <- sumTable
      if(is.null(tableParamsDTI$statsVar))
        tableParamsDTI$statsVar <- attr(sumTable, "summaryTable")$statsVar
      tableParamsDTI$statsVar <- unique(c(tableParamsDTI$statsVar, names(statsPP)))
      tableParamsDTI$title <- htmltools::tags$caption(
          htmltools::a("Summary table in .docx format", target="_blank", href = tableParamsDocxI$file),
          br(),
          tableParamsDTI$footer,
          if(!is.null(loopingVar) && loopingTotal)  
            tagList(
                br(),
                paste0("Totals (percentages) are considered by ", 
                    toString(clinUtils::getLabelVar(loopingVar, labelVars = labelVars)), 
                    "."
                )
            )
      )          
      summaryTableDT <- do.call(exportSummaryStatisticsTable, tableParamsDTI)

#      collapsedText <- collapseHtmlContent(
#          do.call(tags$ul, lapply(messages, tags$li))
#      )

#      res <- list(summaryTable = summaryTableDT, table = collapsedText)
#      class(res) <- c("clinDataReview", class(res))
#      res
      summaryTableDT

    }, simplify = FALSE)
#summaryTableDT <- do.call(c, summaryTableDT)

knitPrintClinDataReview(
    list = summaryTableDT,
    level = reportTitleLevel + 1
)

if(!exists("comparisonTableParams"))    comparisonTableParams <- NULL

summaryTableDT <- sapply(names(summaryTableList$currentData$summaryTable), function(group){

      idx <- ifelse(!is.null(loopingVar), group, 1)
      sumTableCurrent <- summaryTableList$currentData$summaryTable[[idx]]
      sumTableOld <- summaryTableList$previousData$summaryTable[[idx]]

      # By default, reference variables are all row/column variables of the table
      argsCompTable <- comparisonTableParams
      if(is.null(argsCompTable$referenceVars))
        argsCompTable$referenceVars <- unname(unlist(attr(sumTableCurrent, "summaryTable")[c("rowVar", "colVar")]))

      # By default: changeable variables are the statistics
      if(is.null(argsCompTable$changeableVars)){
        argsCompTable$changeableVars <- unname(setdiff(
                attr(sumTableCurrent, "summaryTable")$statsVar,
                names(summaryTableList$currentData$statsPP)
            ))
      }

      argsCompTable$newData <- sumTableCurrent
      argsCompTable$oldData <- sumTableOld
      argsCompTable$outputType <- comparisonTableType
      argsCompTable$pageLength <- Inf
      if(!is.null(labelVars))
          argsCompTable$colnames <- setNames(names(labelVars), labelVars)

      argsCompTable$caption <- if(!is.null(loopingVar) && loopingTotal){
        htmltools::tags$caption(
            paste0("Totals (percentages) are considered by ", 
                toString(clinUtils::getLabelVar(loopingVar, labelVars = labelVars)),
                ".")
        )
      }

      outputComparison <- do.call(clinUtils::compareTables, argsCompTable)

}, simplify = FALSE)

summaryTableDT <- summaryTableDT[!sapply(summaryTableDT, is.null)]

if(length(summaryTableDT) > 0){

  knitPrintClinDataReview(
      list = summaryTableDT,
      level = reportTitleLevel + 1
  )

}