adding seperate shiny for validation of covid model

Covid19ValidatingCovVulIndex/PLPViewer.Rproj

@@ -0,0 +1,13 @@
+Version: 1.0
+
+RestoreWorkspace: Default
+SaveWorkspace: Default
+AlwaysSaveHistory: Default
+
+EnableCodeIndexing: Yes
+UseSpacesForTab: Yes
+NumSpacesForTab: 2
+Encoding: UTF-8
+
+RnwWeave: Sweave
+LaTeX: pdfLaTeX

Covid19ValidatingCovVulIndex/data/settings.csv

@@ -0,0 +1,5 @@
+outcomeId,cohortId,modelSettingsId,analysisId,devDatabase,populationSettingId,modelSettingId,covariateSettingId,modelSettingName,addExposureDaysToStart,riskWindowStart,addExposureDaysToEnd,riskWindowEnd,plpDataFolder,studyPopFile,plpResultFolder,cohortName,outcomeName
+2001,1001,8,8,mdcr,1,1,1,Covid Vul Index,0,0,0,30,T:/AtlasResults/TestSkeleton/PlpData_L1_T10631,T:/AtlasResults/TestSkeleton/StudyPop_L1_T10631_O10082.rds,T:/AtlasResults/TestSkeleton/Analysis_8,flu or covid or symptoms outpatient visit no prior symptoms,hospitalization with pneumonia
+2001,1001,8,1008,mdcr,1,1,1,Covid Vul Index,0,0,0,30,T:/AtlasResults/TestSkeleton/PlpData_L1_T10631,T:/AtlasResults/TestSkeleton/StudyPop_L1_T10631_O10082.rds,T:/AtlasResults/TestSkeleton/Analysis_8,flu or covid or symptoms 2020 outpatient visit no prior symptoms,hospitalization with pneumonia
+2001,1002,8,2008,mdcr,1,1,1,Covid Vul Index,0,0,0,30,T:/AtlasResults/TestSkeleton/PlpData_L1_T10631,T:/AtlasResults/TestSkeleton/StudyPop_L1_T10631_O10082.rds,T:/AtlasResults/TestSkeleton/Analysis_8,covid or symptoms 2020 outpatient visit no prior symptoms,hospitalization with pneumonia
+2001,1003,8,3008,mdcr,1,1,1,Covid Vul Index,0,0,0,30,T:/AtlasResults/TestSkeleton/PlpData_L1_T10631,T:/AtlasResults/TestSkeleton/StudyPop_L1_T10631_O10082.rds,T:/AtlasResults/TestSkeleton/Analysis_8,covid 2020 outpatient visit no prior symptoms,hospitalization with pneumonia

Covid19ValidatingCovVulIndex/global.R

@@ -0,0 +1,32 @@
+# uncomment if running standalone
+##runPlp <- readRDS(file.path("data","results.rds"))
+##validatePlp <- readRDS(file.path("data","extValidation.rds"))
+source("processing.R")
+
+if(is.null(.GlobalEnv$shinySettings$result)){
+  result <- 'data'
+  print('Extracting results from data folder')
+} else{
+  result <- .GlobalEnv$shinySettings$result
+  print('Extracting results from .GlobalEnv$shinySettings')
+}
+
+if(is.null(.GlobalEnv$shinySettings$validation)){
+  validation <- NULL
+} else{
+  validation <- .GlobalEnv$shinySettings$validation
+}
+
+inputType <- checkPlpInput(result) # this function checks 
+if(!class(validation)%in%c('NULL', 'validatePlp')){
+  stop('Incorrect validation class')
+}
+if(inputType == 'file' & !is.null(validation)){
+  warning('Validation input ignored when result is a directory location')
+}
+
+summaryTable <- getSummary(result, inputType, validation)
+
+
+
+

Covid19ValidatingCovVulIndex/helpers.R

@@ -0,0 +1,147 @@
+# this function finds the filter index
+getFilter <- function(summaryTable,input){
+  ind <- 1:nrow(summaryTable)
+  if(input$devDatabase!='All'){
+    ind <- intersect(ind,which(as.character(summaryTable$Dev)==input$devDatabase))
+  }
+  if(input$valDatabase!='All'){
+    ind <- intersect(ind,which(as.character(summaryTable$Val)==input$valDatabase))
+  }
+  if(input$T!='All'){
+    ind <- intersect(ind,which(summaryTable$T==input$T))
+  }
+  if(input$O!='All'){
+    ind <- intersect(ind,which(summaryTable$O==input$O))
+  }
+  if(input$modelSettingName!='All'){
+    ind <- intersect(ind,which(as.character(summaryTable$Model)==input$modelSettingName))
+  }
+  if(input$riskWindowStart!='All'){
+    ind <- intersect(ind,which(summaryTable$`TAR start`==input$riskWindowStart))
+  }
+  if(input$riskWindowEnd!='All'){
+    ind <- intersect(ind,which(summaryTable$`TAR end`==input$riskWindowEnd))
+  }
+
+  return(ind)
+}
+
+
+getPlpResult <- function(result,validation,summaryTable, inputType,filterIndex, selectedRow){
+  if(inputType == 'plpResult'){
+    i <- filterIndex[selectedRow]
+    if(i ==1){
+      tempResult <- result
+      tempResult$type <- 'test'
+    }else{
+      tempResult <- validation$validation[[i-1]]
+      tempResult$type <- 'validation'
+    }
+    tempResult$log <- 'log not available'
+  }else if(inputType == 'plpNoClass'){
+    tempResult <- result
+    tempResult$type <- 'validation'
+    tempResult$log <- 'log not available'
+  }else if( inputType == 'file') {
+    tempResult <- NULL
+    loc <- summaryTable[filterIndex,][selectedRow,]$plpResultLocation
+    locLoaderFunc <- summaryTable[filterIndex,][selectedRow,]$plpResultLoad
+    logLocation <- gsub('plpResult','plpLog.txt', gsub('validationResult.rds','plpLog.txt',gsub('plpResult.rds','plpLog.txt', as.character(loc))))
+    if(file.exists(logLocation)){
+      txt <- readLines(logLocation)
+    } else{
+      txt <- 'log not available'
+    }
+    if(file.exists(as.character(loc))){
+      tempResult <- do.call(as.character(locLoaderFunc), list(as.character(loc)))
+      tempResult$log <- txt
+      tempResult$type <- ifelse(length(grep('/Validation',loc))>0,'validation','test')
+    }
+  }else {
+    stop('Incorrect class')
+  }
+  return(tempResult)
+}
+
+
+
+# format modelSettings
+formatModSettings <- function(modelSettings){
+  modelset <- data.frame(Setting = c('Model',names(modelSettings[[2]])),
+                         Value = c(modelSettings[[1]], unlist(lapply(modelSettings[[2]], 
+                                                                     function(x) paste0(x, collapse='')))))
+  row.names(modelset) <- NULL
+  return(modelset)
+}
+
+# format covariateSettings
+formatCovSettings <- function(covariateSettings){
+  if(class(covariateSettings)=='list'){
+    #code for when multiple covariateSettings
+    covariates <- c() 
+    for(i in 1:length(covariateSettings)){
+      if(attr(covariateSettings[[i]],'fun')=='getDbDefaultCovariateData'){
+        covariatesTemp <- data.frame(covariateName = names(covariateSettings[[i]]), 
+                                     SettingValue = unlist(lapply(covariateSettings[[i]], 
+                                                                  function(x) paste0(x, 
+                                                                                     collapse='-'))))
+      } else{
+        covariatesTemp <- data.frame(covariateName = covariateSettings[[i]]$covariateName,
+                                     SettingValue = ifelse(sum(names(covariateSettings[[i]])%in%c("startDay","endDay"))>0,
+                                                           paste(names(covariateSettings[[i]])[names(covariateSettings[[i]])%in%c("startDay","endDay")],
+                                                                 covariateSettings[[i]][names(covariateSettings[[i]])%in%c("startDay","endDay")], sep=':', collapse = '-'),
+                                                           "")
+        )
+
+      }
+      covariates  <- rbind(covariates,covariatesTemp)
+    }
+  } else{
+    covariates <- data.frame(covariateName = names(covariateSettings), 
+                             SettingValue = unlist(lapply(covariateSettings, 
+                                                          function(x) paste0(x, 
+                                                                             collapse='-'))))
+  }
+  row.names(covariates) <- NULL
+  return(covariates)
+}
+
+# format populationSettings
+formatPopSettings <- function(populationSettings){
+  population <- populationSettings
+  population$attrition <- NULL # remove the attrition as result and not setting
+  population <- data.frame(Setting = names(population), 
+                           Value = unlist(lapply(population, 
+                                                 function(x) paste0(x, 
+                                                                    collapse='-')))
+  ) 
+  row.names(population) <- NULL
+  return(population)
+}
+
+
+# format covariate summary table
+formatCovariateTable <- function(covariateSummary){
+  for(coln in c('covariateValue','CovariateMeanWithOutcome','CovariateMeanWithNoOutcome','StandardizedMeanDiff')){
+    if(sum(colnames(covariateSummary)==coln)>0){
+      covariateSummary[,coln] <- format(round(covariateSummary[,coln], 4), nsmall = 4)
+      class(covariateSummary[,coln]) <- "numeric"
+    }
+  }
+  return(covariateSummary)
+}
+
+
+
+editCovariates <- function(covs){
+  if(!is.null(covs$StandardizedMeanDiff)){
+    return(list(table = formatCovariateTable(covs[,c('covariateName','covariateValue','CovariateCount','CovariateMeanWithOutcome','CovariateMeanWithNoOutcome','StandardizedMeanDiff')]),
+                colnames = c('Covariate Name', 'Value','Count', 'Outcome Mean', 'Non-outcome Mean','Std Mean Diff')
+    ))
+  } else{
+    return(list(table = formatCovariateTable(covs[,c('covariateName','covariateValue','CovariateCount','CovariateMeanWithOutcome','CovariateMeanWithNoOutcome')]),
+                colnames = c('Covariate Name', 'Value','Count', 'Outcome Mean', 'Non-outcome Mean')
+    ))
+  }
+}
+

Covid19ValidatingCovVulIndex/html/DataInfo.html

@@ -0,0 +1,4 @@
+<h3>Description</h3>
+  <p> This button provides information about the data used in the app </p>
+
+

Covid19ValidatingCovVulIndex/html/Description.html

@@ -0,0 +1,3 @@
+<h3>Description</h3>
+  <p> Information about the study and links to the code used to run the study </p>
+

Covid19ValidatingCovVulIndex/html/Help.html

@@ -0,0 +1,5 @@
+<h3>Description</h3>
+  <p> This button provides a link to a YouTube video with a demonstration of the shiny app </p>
+
+
+

Covid19ValidatingCovVulIndex/html/Log.html

@@ -0,0 +1,4 @@
+<h3>Description</h3>
+  <p> This button shows the log when the model was developed or validated </p>
+
+

Covid19ValidatingCovVulIndex/html/Model.html

@@ -0,0 +1,10 @@
+<h3>Description</h3>
+  <p> The model button shows a plot and table with the characteristics of the patients with and without the outcome during the time-at-risk. </p>
+
+  <h3>Interpretation</h3>
+  <ul>
+  <li>The plots show each covariate as a dot (binary covariates on the left side plot and measurements on the right side plot).  The x-axis is the fraction of patients (or mean value) with the covariate in the patients without the outcome and the y-axis is the fraction of patients (or mean value) with the covariate in the patients with the outcome.  Dots above the x=y line are more common in patients with the outcome and dots below the line are more common in patients without the outcome.</li>
+  <li>The table shows the covariate name, the variable importance or coefficient value, the mean value in those with and without the outcome and the standardized mean difference.</li>
+  </ul>  
+
+

Covid19ValidatingCovVulIndex/html/Performance.html

@@ -0,0 +1,10 @@
+<h3>Description</h3>
+  <p> The performance of the model including the operating characteristics at different risk cutoffs, the overall discrimination and the overall calibration. </p>
+
+  <h3>Tabs</h3>
+  <p>The three tabs are:</p>
+  <ul>
+  <li>The 'Summary' tab shows the prediction question being explores and various operating characteristics for a range of risk cutoffs (the threshold bar is interactive and enables you to explore different values by moving the bar left or right) </li>
+  <li>The 'Discrimination' tab shows the AUROC, AUPRC, predicted risk distributions and F1 score</li>
+  <li>The 'Calibration' tab shows the generic calibration plot and the calibration per age group and gender.</li>
+  </ul>

Covid19ValidatingCovVulIndex/html/Summary.html

@@ -0,0 +1,25 @@
+<h3>Description</h3>
+  <p>A table showing summary information for each validation result. Each row corresponds to a model applied to a specific target population, outcome and time-at-risk triple for a specific database.  Summary details include the validation data size (target population and outcome counts) and discriminative performance. </p>
+
+  <h3>Options</h3>
+  <p>Click on a row to select it - this will show as the row will be highlighted.  This will populate the following parts of the app for further exploration:</p>
+  <ul>
+  <li>The complete performance of the result for the selected row can be viewed by clicking on the 'Performance' button in the left menu</li>
+  <li>The model corresponding to the result for the selected row can be viewed by clicking on the 'Model' button in the left menu</li>
+  <li>The log file corresponding to the result for the selected row can be viewed by clicking on the 'Log' button in the left menu (this is not always available)</li>
+    <li>The model development settings for the selected row can be viewed by clicking on the 'Model Settings' tab in the top menu (this is not always available)</li>
+    <li>The population settings (information about time-at-risk and exclusions) for the selected row can be viewed by clicking on the 'Population Settings' tab in the top menu (this is not always available)</li>
+    <li>The covariate settings (information about the model features) for the selected row can be viewed by clicking on the 'Covariate Settings' tab in the top menu (this is not always available)</li>
+  </ul>
+
+  <h3>Using the Filter</h3>
+  <p> Select a specific: </p>
+  <ul>
+  <li>development database - database used to develop the model being validated</li>
+  <li>validation database - database used to evaluate the model being validated</li>
+  <li>time-at-risk - time period relative to index where the outcome is being predicted</li> 
+  <li>target population - the patient population we are interested in predicting the outcome risk for </li> 
+  <li>outcome - the event being predicted</li>
+  <li>model - the type of model (e.g., logistic regression, decision tree)</li>
+  </ul>
+  <p>to filter the table rows of interest. </p> 

Covid19ValidatingCovVulIndex/html/boxHelp.html

@@ -0,0 +1,6 @@
+<h3>Description</h3>
+  <p> These plots show the box plots displaying the risk distributions for those with the outcome during the time-at-risk (class 1) and those without the outcome during the time-at-risk (class 0) </p>
+
+<h3>Interpretation</h3>
+  <p> If a model is able to discriminate between those with and without the outcome then it should be assigning a higher risk to those with the outcome, so the box plot for class 1 should be shifted to the right relative to the box plot for class 0. If the model is not able to discriminate then the box plots will look similar. </p>
+

Covid19ValidatingCovVulIndex/html/calHelp.html

@@ -0,0 +1,6 @@
+<h3>Description</h3>
+  <p> The calibration plots show how closely the predicted risk matched the true observed risk.  The calibration plot is calculated (using labelled data) by partitioning the patients into deciles based on predicted risk and then within each decile the mean predicted risk is calculated and the fraction of patients with the outcome (the observed risk) is calculated.  The calibration plot is then generated by plotting the observed risk against the mean predicted risk for each decile. </p>
+
+<h3>Interpretation</h3>
+  <p> If a model is well calibrated the mean predicted risk should be approximately the same as the observed risk.  Therefor all 10 dots should fall on the x=y line.  If the dots fall above the x=y line then there is a higher oberved risk than predicted, so our model is assigning lower than the true risk to patients (underestimated risk). If the dots fall below the x=y line then there is a lower observed risk than predicted, so our model is assigning higher than the true risk to patients (overestimated risk).</p>  
+

Covid19ValidatingCovVulIndex/html/demoHelp.html

@@ -0,0 +1,8 @@
+<h3>Description</h3>
+  <p> The demographic calibration plots show how closely the predicted risk matched the true observed risk for each age/gender strata.  We partition the patients into age and gender groups, then calculate the mean predicted risk within each age/gender group and the fraction of patients within the group that actually had the outcome during the time-at-risk (observed risk).  We then plot the observed and predicted risk for each age group split by gender.  </p>
+
+<h3>Interpretation</h3>
+  <p> If a model is well calibrated the mean predicted risk should be approximately the same as the observed risk for each age/gender.  Therefore, the observed risk and predicted risk plots should overlap.  If there is deviation between the predicted risk and observed risk for a certain age group, then this tells us the model is not well calibrated for that age group.  This may indicate the need to fit a model specifically for that age group if there is sufficient data.</p>
+
+<p> In addition, this plot shows us the age trend of risk  (e.g., you can see whether the risk increases as patients age) and it shows us how males and females differ in terms of risk of the outcome during the time-at-risk.</p> 
+

Covid19ValidatingCovVulIndex/html/f1Help.html

@@ -0,0 +1,13 @@
+<h3>Description</h3>
+  <p> The F1 score plot shows the F1 score for each risk threshold. Click <a href="https://en.wikipedia.org/wiki/F1_score">here</a> for more information about the F1 score.  </p>
+
+<h3>Interpretation</h3>
+  <p> The F1-score combines the sensitivity and precision of the model into a single measure of accuracy.</p>
+
+<h3>Definitions</h3>
+  <ul> 
+  <li> Sensitivity - probability that somebody with the outcome will be identified as having the outcome by the model at a specified cutoff (e.g., their predicted risk >= specified cutoff)  
+  </li>
+   <li> Precision (positive predictive value) - probability that somebody identified by the model as having the outcome at a specified cutoff truly has the outcome 
+   </li>
+  </ul>

Covid19ValidatingCovVulIndex/html/prcHelp.html

@@ -0,0 +1,19 @@
+<h3>Description</h3>
+  <p> The precision recall (PR) curve shows the trade-off between precision (positive predictive value) and recall (sensitivity) for all possible risk cutoffs. The area below the curve is a measure of overall discriminative performance. Click <a href="https://acutecaretesting.org/en/articles/precision-recall-curves-what-are-they-and-how-are-they-used">here</a> for more information.  </p>
+
+<h3>Interpretation</h3>
+  <p> The red dashed line shows the fraction of the target population who have the outcome (the average risk). The main line shows the relationship between the precision and recall.  If the main line is above the red dashed line, then this means the model is able to identify a group of patients who have a higher risk than the average risk, the higher the line is above the red dashed line, the higher the relative risk we can identify for some subset of patients. 
+</p>
+
+<h3>Notes</h3>
+  <p> If the outcome is rare (so the data are imbalanced) a precision recall curve (PRC) gives an insight into the clinical utility of the model as it tells you about the precision of the model </p>  
+
+<h3>Definitions</h3>
+  <ul> 
+  <li> Sensitivity (recall) - probability that somebody with the outcome will be identified as having the outcome by the model at a specified cutoff (e.g., their predicted risk >= specified cutoff)  
+  </li>
+<li> 
+   Specificity - probability that somebody without the outcome will be identified as a non-outcome by the model at a specified cutoff (e.g., their predicted risk < specified cutoff) </li> 
+   <li> Precision (positive predictive value) - probability that somebody identified by the model as having the outcome at a specified cutoff truly has the outcome 
+   </li>
+  </ul> 

Covid19ValidatingCovVulIndex/html/predDistHelp.html

@@ -0,0 +1,6 @@
+<h3>Description</h3>
+  <p> These plots show the probability density function for those with the outcome (red) and those without the outcome (green) </p>
+
+<h3>Interpretation</h3>
+  <p> If a prediction model is able to discriminate between those who and without the outcome during the time-at-risk then these distributions should be disjoint.  The more overlap between the distributions, the worse the discrimination. </p>
+

Covid19ValidatingCovVulIndex/html/prefDistHelp.html

@@ -0,0 +1,6 @@
+<h3>Description</h3>
+  <p> These plots show the preference score density function for those with the outcome (red) and those without the outcome (green) </p>
+
+<h3>Interpretation</h3>
+  <p> If a prediction model is able to discriminate between those who and without the outcome during the time-at-risk then these distributions should be disjoint.  The more overlap between the distributions, the worse the discrimination. </p>
+