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
if(!exists("listingDocx"))  listingDocx <- FALSE

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

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

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

if(comparisonTableType != "none") {

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

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

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

    pathDataBatch <- pathsData[[dataBatch]]

    # Load data
    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")

    # Data processing 
    if(exists("dataProcessing")){
        data <- processData(
            data = data, 
            dataPath = pathDataBatch,
            processing = dataProcessing,
            verbose = TRUE,
            labelVars = labelVars
        )
        # 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)){

        # format label for 'knitPrintClinDataReview'
        data[, loopingVar] <- colwise(function(x) gsub("\\.", "", x))(data[, loopingVar, drop = FALSE])

        if(exists("loopingNMax") && is.integer(loopingNMax)){
            data <- merge(
                x = data,
                y = unique(data[, loopingVar, drop = FALSE])[seq_len(loopingNMax), , drop = FALSE],
                all = FALSE
            )
        }

    }

    attr(data, "labelVars") <- labelVars
    data

}, simplify = FALSE)

dataPrevious <- dataList$previousData
dataCurrent <- dataList$currentData
labelVars <- attr(dataCurrent, "labelVars")

getListingPath <- function(loopingVar, data){

    fileListing <- sprintf("listing_%s.docx",
        strtrim(
            gsub(" ", "_", gsub("[[:punct:]]", "", reportTitle)), 30
        )
    )

    if(!is.null(loopingVar)){
        fileListing <- paste0(
            tools::file_path_sans_ext(fileListing), 
            "_", formatLabel(unique(dataCurrentI[,loopingVar])), ".",
            tools::file_ext(fileListing)
        )
    }
    fileListing <- file.path("tables", fileListing)
    return(fileListing)

}

exportListing <- function(data, file){

    colnames(data) <- clinUtils::getLabelVar(var = colnames(data), labelVars = labelVars)

    # create listing as flextable
    ft <- getListing(
        data = data,
        includeRownames = FALSE,
        landscape = TRUE
    )

    # export to docx
    exportFlextableToDocx(object = ft, file = file, landscape = TRUE)

}

data <- dlply(dataCurrent, loopingVar, function(dataCurrentI){

    # parameters for the interactive table:     
    argsTable <- c(
        list(
            data = dataCurrentI, 
            labelVars = labelVars,
            pathVar = if(!is.null(patientProfilePath))  "patientProfilePath",
            pathLab = labelVars["USUBJID"]
        ),
        tableParams
    )

    # Export listing to Word
    if(isTRUE(listingDocx)){

        fileListing <- getListingPath(data = dataCurrentI, loopingVar = loopingVar)

        dataListing <- dataCurrentI
        if(!is.null(tableParams$tableVars)){
            dataListing <- dataListing[, tableParams$tableVars, drop = FALSE]
        }
        exportListing(data = dataListing, file = fileListing)

        # add link in caption of interactive table
        argsTable$tablePars$caption <- htmltools::tags$caption(
            htmltools::a("Complete listing in .docx format", target="_blank", href = fileListing),
            br(),
            argsTable$tablePars$caption
        )

    }

    do.call("tableClinData", argsTable)

})

knitPrintClinDataReview(data, level = reportTitleLevel + 1)

data <- dlply(dataCurrent, loopingVar, function(dataCurrentI){

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

    ## input parameters for compareTables function:
    argsCompTable <- comparisonTableParams

    ## input parameters for exportDiffData function:
    argsExportDiff <- list()

    # extract variables to display in the table + and labels 
    tableVars <- tableParams$tableVars
    if(is.null(tableVars))  tableVars <- colnames(dataCurrentI)
    tableLab <- clinUtils::getLabelVar(var = tableVars, labelVars = labelVars, label = tableParams$tableLab)
    if(!is.null(patientProfilePath)){
        tableVars <- c(tableVars, "patientProfileLink")
        tableLab <- c(tableLab, setNames(tableLab["USUBJID"], "patientProfileLink"))
    }
    dataCurrentI <- subset(dataCurrentI, select = tableVars)
    dataPreviousI <- subset(dataPreviousI, select = tableVars)

    # set columns to labels (if available)
    argsExportDiff$colnames <- setNames(names(tableLab), tableLab)

    # formatting for patient profiles
    getArgsPatientProfiles <- function(data, argsExportDiff){
        argsExportDiff <- c(argsExportDiff,
            list(
                # escape it in the table    
                escape = match("patientProfileLink", colnames(data))-1,
                # doesn't display USUBJID
                nonVisibleVar = "USUBJID"
            )
        )
        return(argsExportDiff)
    }

    # convert character columns as factor (as requested)
    convertColToFact <- function(data){
        idxColChar <- which(sapply(data, is.character))
        idxColChar <- setdiff(idxColChar, match("patientProfileLink", colnames(data)))
        if(length(idxColChar) > 0)
            data[, idxColChar] <- lapply(data[, idxColChar], as.factor)
        return(data)
    }

    res <- switch(comparisonTableType, 

        `newData-diff-interactive` = {

            argsCompTable[["outputType"]] <- "newData-diff-interactive"

            # convert character columns as factor (as requested)
            dataCurrentI <- convertColToFact(dataCurrentI)
            dataPreviousI <- convertColToFact(dataPreviousI)

            # formatting for patient profiles:
            if(!is.null(patientProfilePath)){

                # set patient profile link column just after USUBJID
                dataCurrentI <- reorderColumns(
                    data = dataCurrentI, 
                    vars = c("patientProfileLink" = match("USUBJID", colnames(dataCurrentI))+1)
                )
                # getClinDT params-specific for patient profile
                argsExportDiff <- getArgsPatientProfiles(
                    data = dataCurrentI, 
                    argsExportDiff = argsExportDiff
                )

            }

            # add link in caption of interactive table
            if(isTRUE(listingDocx)){
                fileListing <- getListingPath(data = dataCurrentI, loopingVar = loopingVar)
                argsCompTable$caption <- htmltools::tags$caption(
                    htmltools::a("Complete listing in .docx format", target="_blank", href = fileListing),
                    br(),
                    argsCompTable$caption
                )
                argsCompTable[["outputType"]] <- c(argsCompTable[["outputType"]], "newData-diff")
            }

            # create comparison table
            argsCompTable <- c(
                argsCompTable,
                 list(
                    newData = dataCurrentI,
                    oldData = dataPreviousI
                 ),
                 argsExportDiff
            )
            tableComparison <- do.call(clinUtils::compareTables, argsCompTable)

            # export comparison table to docx
            if(isTRUE(listingDocx)){

                dataListing <- tableComparison[["newData-diff"]]
                dataListing <- subset(dataListing, 
                    select = setdiff(colnames(dataListing), "patientProfileLink")
                )
                exportListing(data = dataListing, file = fileListing)

                # extract interactive table as output
                tableComparison <- tableComparison[["newData-diff-interactive"]]
            }

            tableComparison

        },

        `table-comparison-interactive` = {

            ## extract comparison table
            argsCompTable <- c(
                argsCompTable,
                list(
                    outputType = "table-comparison",
                    newData = dataCurrentI,
                    oldData = dataPreviousI
                )
            )
            tableComparison <- do.call(clinUtils::compareTables, argsCompTable)
            tableCompAttr <- attributes(tableComparison)[c("referenceVars", "changeableVars")]

            ## export to docx
            if(isTRUE(listingDocx)){

                fileListing <- getListingPath(data = dataCurrentI, loopingVar = loopingVar)

                # export comparison table to docx
                exportListing(data = tableComparison, file = fileListing)

                # add link in caption of interactive table
                argsExportDiff$caption <- htmltools::tags$caption(
                    htmltools::a("Complete listing in .docx format", target="_blank", href = fileListing),
                    br(),
                    argsExportDiff$caption
                )
            }

            ## export to DT

            # convert character columns as factor (as requested)
            tableComparison <- convertColToFact(tableComparison)

            # formatting for patient profiles:
            if(!is.null(patientProfilePath)){

                # add patient profiles to diff table:
                tableComparison$patientProfileLink <- dataCurrentI[
                    match(tableComparison$USUBJID, dataCurrentI$USUBJID),
                    "patientProfileLink"
                ]

                # set patient profile link column just after USUBJID
                tableComparison <- reorderColumns(
                    data = tableComparison, 
                    vars = c("patientProfileLink" = match("USUBJID", colnames(tableComparison))+1)
                )

                # getClinDT params-specific for patient profile
                argsExportDiff <- getArgsPatientProfiles(
                    data = tableComparison, 
                    argsExportDiff = argsExportDiff
                )

            }

            argsExportDiff <- c(
                list(diffData = tableComparison),
                tableCompAttr,
                argsExportDiff
            )
            tableComparisonDT <- do.call(exportDiffData, argsExportDiff)

        }

    )

})

knitPrintClinDataReview(data, level = reportTitleLevel + 1)