Nothing
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 ) }
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.