reporthtml.rmd

---
output: 
  html_document:
    toc: true
    toc_float: true
params:
  allTables: "Tables"
  extraFiles: "extraFiles"
  tableOfVariables: "tableOfVariables"
  datasetSummary: "datasetSummary"
  errorSummary: "errorSummary"
  highLevel: "highLevel"
  badCodes: "badCodes"
  missingSummary: "missingSummary"
  missingSummaryByGroup: "missingSummaryByGroup"
  unknownCodeSummaryByGroup: "unknownCodeSummaryByGroup"
  appearanceSummary: "appearanceSummary"
  errorTable: "errorTable"
  plotList: "plotList"
  includeDataSummary: "includeDataSummary"
  includeHistograms: "includeHistograms"
  includeErrorSummary: "includeErrorSummary"
  region: "region"
  userDetails: "userDetails"
  toReport: "toReport"
  programsInReport: "programsInReport"
  reportOutput: "reportOutput"
  errorSummaryTables: "errorSummaryTables"
  groupVar: "groupVar"
  indexTableName: "indexTableName"
  patientVar: "patientVar"
  patientVarSym: "patientVarSym"
---
```{r datasetLabel, echo = FALSE, warning=FALSE}
tableData <- params$allTables
groupVar <- params$groupVar
groupVarSE <- rlang::sym(groupVar)
userDetails <- params$userDetails
region <- params$region 
userDetails <- params$userDetails
indexTableName <- params$indexTableName
if (userDetails$uploadconcept_mr == "MR000"){
  headerMessage <- NULL
} else headerMessage <- paste0("Dataset submitted for Concept ", userDetails$uploadconcept_mr)


if (userDetails$uploaduser_id == ""){
  regionMessage <- NULL
} else regionMessage <- paste0("from IeDEA Region ", region)


# max number of characters in x label in heat map for labels to be horizontal
maxNumberOfHeatMapCharX <- 10

```


# `r knitr::include_graphics("project_logo_50_20.png")` Harmonist Data Toolkit Report

`r headerMessage` `r regionMessage`

Report date: `r Sys.Date()`
```{r setup, include=FALSE}
knitr::opts_chunk$set(
	echo = FALSE,
	message = FALSE,
	warning = FALSE
)
```

### Dataset Summary

Total number of patients in dataset: `r format(params$datasetSummary$totalPatients, scientific = FALSE, big.mark = ",")`

```{r summary2, echo=FALSE, fig.align='left', message=FALSE, warning=FALSE, results='asis'}
sumTables <- params$datasetSummary$tableSummaryKable
sumSRN <- params$datasetSummary$srnSummaryKable
```

```{r listOfPrograms, echo=FALSE, message=FALSE, warning=FALSE, results='asis'}
groups <- sort(unique(tableData[[indexTableName]][[groupVar]]))
groups <- groups[groups != "Missing"]
# use groups variable in later chunks
# if no valid groups in dataset, don't include summary of groups
if (is_empty(groups)){
  sumGroups <- NULL
  numberInGroup <- NULL
} else {
  numberInGroup <- map_dbl(groups, 
                           ~nrow(unique(select(
                             filter(tableData[[indexTableName]], 
                                    (!! rlang::sym(groupVar)) == .), 
                             params$patientVarSym))))
  
  groupSummary <- data.frame("GroupName" = groups, "Patients" = numberInGroup)
  names(groupSummary)[[1]] <- groupVar
  
  sumGroups <- kbl(groupSummary, col.names = c(groupVar,"Patients"), 
                   caption = paste0(groupVar, " in Dataset"),longtable = T, 
                   format = "html") %>% 
    kable_styling(full_width = FALSE, position = "left", "bordered")
}
```

```{r attempt, echo=FALSE, message=FALSE, warning=FALSE, results='asis'}

sumTables %>% kable_styling(position = "left") 
cat("\n")

if (!is.null(sumSRN)){
  sumSRN
}
cat("\n")

if (!is.null(sumGroups)){
  sumGroups
  cat("\n")
}


```

```{r summarytable, echo=FALSE, message=FALSE, warning=FALSE, results='asis'}
# removeHTML removes html formatting from a character string--------------

tableToShow <-params$tableOfVariables
sumVars <- kbl(tableToShow, "html",caption = "Summary of Uploaded Tables", longtable = T) %>% kable_styling(full_width = FALSE, position = "left", "bordered")
if (length(params$tableOfVariables) == 4){
  sumVars <- sumVars %>% column_spec(3, width = "25em",border_left = T) %>% column_spec(4, "10em",border_left = T)
} else sumVars <- sumVars %>% column_spec(3, width = "30em")

sumVars


if (!is_empty(params$extraFiles)){
  cat("####","Note that the following non-IeDEA files were uploaded but were not included in data quality checks: ", paste(params$extraFiles, collapse = ", "),"\n")
}
```

```{r newline, echo=FALSE, message=FALSE, warning=FALSE, results='asis'}
cat("<br>")
cat("\n")
```


```{r uploadStats, echo=FALSE, fig.align='left', message=FALSE, warning=FALSE, results='asis'}
if (params$includeDataSummary && !is.null(params$datasetSummary$statsSummaryTable)){
  cat("###"," Summary Statistics","\n")

    cat(params$datasetSummary$statsSummaryTable)
      
  cat(params$datasetSummary$visitStatsSummaryTable)
  cat("<br>")
  cat("\n")
    #print(params$datasetSummary$otherStatsTable)

}
```

```{r function to generate heat map, echo=FALSE, fig.height=5, fig.width=5, message=FALSE, warning=FALSE}
generateHeatMapStoplightPercent <- function(df, xVar, yVar, titleText=NULL, reverse=FALSE){
  # this function generates heatmaps where 100 is good and 0 is bad. 
  # we take the "floor" of each percent so that anything less than 100.00000 appears
  # different from 100. We use 80 as the midpoint color 
  df$percent <- floor(as.numeric(df$percent))
  addColor <- scale_fill_gradientn(
    colors = c("red", 
               "red",
               "yellow", 
               muted("green", l = 70, c = 100),
               muted("green", l = 60, c = 100)),
    values = rescale(c(0, 20, 80, 99, 100)),
    limits = c(0,100),
    na.value = "grey50"
  )

  df$percent[is.na(df$percent)] <- 0
  df[[yVar]] <- fct_rev(factor(df[[yVar]], unique(df[[yVar]])))
  
  max_x_char <- max(nchar(unique(as.character(df[[xVar]]))))
  if (max_x_char > maxNumberOfHeatMapCharX){
    xAxisTextInfo <- element_text(angle = 45, hjust = 0.1, size = 9)
  } else xAxisTextInfo <- element_text(size = 9)
  
    p <- ggplot(data = df, aes_string(x = xVar, y = yVar)) +
    geom_tile(aes(fill = percent), colour = "white", size = 0.01) +
    labs(x="",y="") +
    geom_text(aes(label = percent), size = 3) +
    scale_y_discrete(expand=c(0,0))+
    #define new breaks on x-axis
    scale_x_discrete(expand=c(0,0), position = "top") +
    geom_text(data = df %>% filter(is.na(percent)),
             label = "N/A", size = 2) +
    addColor + 
  #  labs(title=titleText) +
    theme_grey(base_size=10)+
    theme(#axis.text.x=element_text(angle = 45, hjust = 1, size = 9),
      axis.text.y = element_text(size=9),
      plot.background = element_blank(),
      axis.ticks.y = element_blank(),
      axis.ticks.x = element_blank(),
      panel.border = element_blank(),
      legend.position = "none") 

  numX <- uniqueN(df[[xVar]])
  
  width <- ifelse(numX < 3, 5, 3 + 0.6 * numX)
  return(list(
    p = p,
    width = width, #2.2 + 0.5 * uniqueN(df[[xVar]]),
    height = 1.5 + 0.5 * uniqueN(df[[yVar]]))
  )
}
# If no heat map is generated (too few variables, etc) we still need (fake) height and width 
# arguments for the display code chunk options
setFakeFigureDim <- function(){
  df <- NULL
  df$height <- 1
  df$width <- 1
  df$p <- NULL
  return(df)
}

```

```{r appearanceBarPlotFunction, echo=FALSE, message=FALSE, warning=FALSE, results='asis'}

createAppearanceBarPlot <- function(df){
  tableName <- unique(df$table)
  df <-  df %>% select(-table)
  p <- ggplot(data = df, 
              aes(x= reorder( (!! rlang::sym(groupVar)),-percent), y=percent)) + 
    geom_bar(stat = "identity", fill = "lightgray") + 
    theme(legend.position="none",axis.text.x=element_text(size = 9), axis.text.y=element_text(size = 9)) + 
    xlab(groupVar) +
    ylab(paste0("percent from ", indexTableName, " included in ", tableName)) +
    coord_flip(ylim = c(0,100))
  width = 6
  height = 0.5 + 0.5 * uniqueN(df[[groupVar]])
  return(list(
    p = p,
    width = width,
    height = height)
  )
}
```

```{r appearanceHeatmap, echo=FALSE, fig.align='left', message=FALSE, warning=FALSE, results='asis', dev='svg'}
# if tblBAS was the only table with PATIENT as a main ID, don't create a heatmap
if (is.null(params$appearanceSummary)) {
  appearanceHeatmap <- setFakeFigureDim()
} else {
  # at least one table with PATIENT was shared in addition to tblBAS
 # cat("<br>")
 # cat("  \n  ")
  cat("### Percent of Patients from", indexTableName, "Included  ")

  # if appearance summary includes a message that means
  # every patient is included in patient-linked tables, so don't create heatmap
  if ("message" %in% names(params$appearanceSummary)){
    appearanceHeatmap <- setFakeFigureDim()
    # replace heatmap with message about all patients appearing in tables
    appearanceHeatmap$p <- params$appearanceSummary$message[[1]]
  } else {
    df <- params$appearanceSummary
    df <- tidyr::complete(df, (!! groupVarSE), table)
    # if only one additional table was shared, create a bar plot instead of heat map
    if (length(unique(df$table)) == 1){
      appearanceHeatmap <- createAppearanceBarPlot(df)
    }
    if (length(unique(df$table)) > 1) {
      titleText <- "Percent of Patients Included in Tables"
      xOrder <- names(params$allTables)
      df[["table"]] <- factor(df[["table"]], levels = xOrder)
      appearanceHeatmap <- generateHeatMapStoplightPercent(df, "table", groupVar)
    }
  }
}


```

```{r showAppearance, echo=FALSE, fig.height=appearanceHeatmap$height, fig.width=appearanceHeatmap$width, message=FALSE, warning=FALSE, results='asis', dev='svg'}
if (!is.character(appearanceHeatmap$p) &&
    !is.null(appearanceHeatmap$p)){
    appearanceHeatmap$p
}

```

```{r showAppearanceMsg, echo=FALSE, message=FALSE, warning=FALSE, results='asis'}
# if every patient appears in every table display that message
if (is.character(appearanceHeatmap$p)){
  cat(appearanceHeatmap$p)
} 

```


```{r calcHistHeight, echo = FALSE, message=FALSE, warning= FALSE, results='asis'}
if (params$includeHistograms){
  cat("## Histograms of important dates by ", groupVar, "  ")
  # check first to see if all plots were empty, indicated by text message
  if (is.character(params$plotList)){
    histHeight <- 1
  } else {
    numberOfGraphs <- length(levels(params$plotList[[1]]$data$DateName))
    if (numberOfGraphs == 1){
      histHeight <- 2.44
    }
    else if (numberOfGraphs == 6){
      histHeight <- 4.35
    } else histHeight <- numberOfGraphs*0.57 + 1.425
  }
} else histHeight <- 1 #dummy value since histograms not included

```

```{r PlotDates, echo=FALSE, fig.height=histHeight, fig.width=6, message=FALSE, warning=FALSE, results='asis', dev='svg'}

if (params$includeHistograms){
    if (!is.character(params$plotList)){
    for (groupName in names(params$plotList)){
      print(params$plotList[[groupName]])
    }
  } else {
    cat(params$plotList, "\n")
  }
}
cat("\n")

```



```{r kable, echo=FALSE, message=FALSE, warning=FALSE, results='asis'}
if (params$includeErrorSummary){
  errorSummaryToDisplay <- params$errorSummary
  cat("## Data Quality Summary  ")
  cat("\n")

  highLevelSummary <- params$highLevel
  if (nrow(highLevelSummary) >0 ){
    highLevel <- "Note: Download Error Detail spreadsheet from the Toolkit for more information  "
    # highLevel <- kable(highLevelSummary, row.names = FALSE, caption = "Error/Warning Overview",
    #                    longtable = TRUE,
    #                    col.names = c("Error Code","Count"),
    #                    format = "html") %>% 
    #   kable_styling(full_width = FALSE, position = "left")
  } else highLevel <- "No errors in dataset"
  cat(highLevel, "  ","\n")
  
  if (nrow(params$errorTable$errorOnlySummary) > 0){
    # errorSummary <- kable(params$errorTable$errorOnlySummary, row.names = FALSE, caption = "Error Summary",
    #     longtable = TRUE, 
    #     format = "html") %>% 
    #   kable_styling(full_width = FALSE, position = "left")
    # print(errorSummary)
    cat("\n")
    cat("#### Summary of Errors  ")
    cat("\n")
    cat(params$errorSummaryTables$errors)

  }
  
  if (nrow(params$errorTable$warnOnlySummary) > 0){
       # warnSummary <- kable(params$errorTable$warnOnlySummary, row.names = FALSE, caption = "Warning Summary",
       #   longtable = TRUE, 
       #   format = "html") %>% 
       #   kable_styling(full_width = FALSE, position = "left")
       #  print(warnSummary)
    cat("#### Summary of Warnings")
    cat("\n")
    cat(params$errorSummaryTables$warnings)


  }
}
```


``` {r invalidCodes, results= 'asis', echo=FALSE}
if (params$includeErrorSummary ) {
  cat("#### Summary of Invalid Codes")
  cat("\n")
  if (nrow(params$badCodes) == 0){
    cat("All coded variables had valid codes")
  } else{
    # kable(params$badCodes, row.names = FALSE, caption = "Summary of Invalid Codes",
    #     longtable = TRUE,
    #     format = "html") %>% 
    # kable_styling(full_width = FALSE, position = "left")
    cat(params$errorSummaryTables$badCodes)

  }
  
  }
```



``` {r missing, results= 'asis', echo=FALSE}

if (params$includeErrorSummary & (nrow(params$missingSummary)>0)){
  cat("### Summary of Missing Variable Entries")
  cat("\n")
  #remove errorType (column 4) from table
  missingSummary <- params$missingSummary %>% select(-category)
    kbl(missingSummary, row.names = FALSE, caption = "Summary of Important Missing Variable Entries",
          longtable = TRUE,
        format = "html") %>% 
    kable_styling(full_width = FALSE, position = "left")
          #, col.names = c("Table","Variable Name","# of Missing Values","% of Table with Missing Values" ))
}



```


```{r PlotMissing, echo=FALSE, fig.height=5, fig.width=7, message=FALSE, warning=FALSE, results='asis', dev='svg'}
if (params$includeErrorSummary &
    (nrow(params$missingSummary) > 1)) {
 
    df <- params$missingSummaryByGroup
    df <- df %>% filter(!is.na( (!! rlang::sym(groupVar))))
    dfTest <- tidyr::complete(df, (!! rlang::sym(groupVar)), variable)
    # if only one variable was missing at all, make a bar chart instead of heat map,
    # but don't make either if less than 2% missing; not interesting
    if (uniqueN(dfTest$variable) == 1){
      if (max(dfTest$percent) < 2) missingHeatmap <- setFakeFigureDim()
      else {
        # update to reflect percent NOT missing
        dfTest$percent <- 100 - dfTest$percent
         missingHeatmap <- ggplot(dfTest, aes_string(groupVar, "percent")) + 
           geom_bar(stat = "identity") + ylim(0, yaxis)
      }
    } else {
              # update to reflect percent NOT missing

      dfTest$percent <- 100 - dfTest$percent
       missingHeatmap <- generateHeatMapStoplightPercent(dfTest, "variable", groupVar, titleText="Percent Variable Entries Complete (Not Missing)", TRUE)
    }

   
    # ggplot(data = params$missingSummaryByGroup, aes(x = PROGRAM, y = variable)) + geom_tile(aes(fill = percent)) +
    #   scale_fill_gradient(low = "white", high = "red") + labs(title = "Percent Missing Variable Entries", x = sortBy) +
    #   theme(axis.text.x = element_text(angle = 90, vjust = 0.5))
    # #ggplotly(p)
} else missingHeatmap <- setFakeFigureDim()
```

```{r showMissing, echo=FALSE, fig.height=missingHeatmap$height, fig.width=missingHeatmap$width, message=FALSE, warning=FALSE, results='asis', dev='svg'}
# if (!is.null(missingHeatmap$p)){
#   cat("### Summary of Missing Variables by Group")
#   cat("\n")
#   missingHeatmap$p
# }
```


```{r PlotMissingAndUnknown, echo=FALSE, fig.height=5, fig.width=9, message=FALSE, warning=FALSE, results='asis', dev='svg'}
if (params$includeErrorSummary &&
    (nrow(params$errorTable$missingAndUnknownByGroup) > 0)) {
  cat("\n")
  cat("### Percent Variable Entries Complete (Not Missing/Unknown)")
  cat("\n")
  
  dataset <- params$errorTable$missingAndUnknownByGroup %>% filter(!endsWith(variable,"D_A")) 
  df <- dataset
  df$percent <- 100 - df$percent
  df <- df %>% filter(!is.na( (!! rlang::sym(groupVar)) ))
  df <- tidyr::complete(df, (!! rlang::sym(groupVar)), variable)
  # update to show percent NOT missing or unknown
  df$percent[is.na(df$percent)] <- 100 
  missingAndUnknownHeatmap <- generateHeatMapStoplightPercent(df, "variable", groupVar, "Percent Variable Entries Complete (Not Missing or Unknown)")
} else missingAndUnknownHeatmap <- setFakeFigureDim()
```


```{r showMissingAndUnknown, echo=FALSE, fig.height=missingAndUnknownHeatmap$height, fig.width=missingAndUnknownHeatmap$width, message=FALSE, warning=FALSE, results='asis', dev='svg'}
if (!is.null(missingAndUnknownHeatmap$p)){
  missingAndUnknownHeatmap$p
}
 
```