diff --git a/Covid19ValidatingCovVulIndex/PLPViewer.Rproj b/Covid19ValidatingCovVulIndex/PLPViewer.Rproj
new file mode 100644
index 00000000..8e3c2ebc
--- /dev/null
+++ b/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
diff --git a/Covid19ValidatingCovVulIndex/data/Analysis_8/plpResult.rds b/Covid19ValidatingCovVulIndex/data/Analysis_8/plpResult.rds
new file mode 100644
index 00000000..6f3341f6
Binary files /dev/null and b/Covid19ValidatingCovVulIndex/data/Analysis_8/plpResult.rds differ
diff --git a/Covid19ValidatingCovVulIndex/data/Validation/HIRA/Analysis_1008/validationResult.rds b/Covid19ValidatingCovVulIndex/data/Validation/HIRA/Analysis_1008/validationResult.rds
new file mode 100755
index 00000000..c5c2039c
Binary files /dev/null and b/Covid19ValidatingCovVulIndex/data/Validation/HIRA/Analysis_1008/validationResult.rds differ
diff --git a/Covid19ValidatingCovVulIndex/data/Validation/HIRA/Analysis_2008/validationResult.rds b/Covid19ValidatingCovVulIndex/data/Validation/HIRA/Analysis_2008/validationResult.rds
new file mode 100755
index 00000000..4e133184
Binary files /dev/null and b/Covid19ValidatingCovVulIndex/data/Validation/HIRA/Analysis_2008/validationResult.rds differ
diff --git a/Covid19ValidatingCovVulIndex/data/Validation/HIRA/Analysis_3008/validationResult.rds b/Covid19ValidatingCovVulIndex/data/Validation/HIRA/Analysis_3008/validationResult.rds
new file mode 100755
index 00000000..a65af5d7
Binary files /dev/null and b/Covid19ValidatingCovVulIndex/data/Validation/HIRA/Analysis_3008/validationResult.rds differ
diff --git a/Covid19ValidatingCovVulIndex/data/Validation/HIRA/Analysis_8/validationResult.rds b/Covid19ValidatingCovVulIndex/data/Validation/HIRA/Analysis_8/validationResult.rds
new file mode 100755
index 00000000..0f178138
Binary files /dev/null and b/Covid19ValidatingCovVulIndex/data/Validation/HIRA/Analysis_8/validationResult.rds differ
diff --git a/Covid19ValidatingCovVulIndex/data/Validation/Tufts/Analysis_1008/validationResult.rds b/Covid19ValidatingCovVulIndex/data/Validation/Tufts/Analysis_1008/validationResult.rds
new file mode 100755
index 00000000..09aca628
Binary files /dev/null and b/Covid19ValidatingCovVulIndex/data/Validation/Tufts/Analysis_1008/validationResult.rds differ
diff --git a/Covid19ValidatingCovVulIndex/data/Validation/Tufts/Analysis_2008/validationResult.rds b/Covid19ValidatingCovVulIndex/data/Validation/Tufts/Analysis_2008/validationResult.rds
new file mode 100755
index 00000000..16f91e14
Binary files /dev/null and b/Covid19ValidatingCovVulIndex/data/Validation/Tufts/Analysis_2008/validationResult.rds differ
diff --git a/Covid19ValidatingCovVulIndex/data/Validation/Tufts/Analysis_8/validationResult.rds b/Covid19ValidatingCovVulIndex/data/Validation/Tufts/Analysis_8/validationResult.rds
new file mode 100755
index 00000000..acdd3b62
Binary files /dev/null and b/Covid19ValidatingCovVulIndex/data/Validation/Tufts/Analysis_8/validationResult.rds differ
diff --git a/Covid19ValidatingCovVulIndex/data/Validation/ausom/Analysis_8/validationResult.rds b/Covid19ValidatingCovVulIndex/data/Validation/ausom/Analysis_8/validationResult.rds
new file mode 100755
index 00000000..ea8cc4ec
Binary files /dev/null and b/Covid19ValidatingCovVulIndex/data/Validation/ausom/Analysis_8/validationResult.rds differ
diff --git a/Covid19ValidatingCovVulIndex/data/Validation/ccae/Analysis_8/validationResult.rds b/Covid19ValidatingCovVulIndex/data/Validation/ccae/Analysis_8/validationResult.rds
new file mode 100644
index 00000000..cfa9c517
Binary files /dev/null and b/Covid19ValidatingCovVulIndex/data/Validation/ccae/Analysis_8/validationResult.rds differ
diff --git a/Covid19ValidatingCovVulIndex/data/Validation/jmdc/Analysis_8/validationResult.rds b/Covid19ValidatingCovVulIndex/data/Validation/jmdc/Analysis_8/validationResult.rds
new file mode 100644
index 00000000..210b23f0
Binary files /dev/null and b/Covid19ValidatingCovVulIndex/data/Validation/jmdc/Analysis_8/validationResult.rds differ
diff --git a/Covid19ValidatingCovVulIndex/data/Validation/mdcd/Analysis_8/validationResult.rds b/Covid19ValidatingCovVulIndex/data/Validation/mdcd/Analysis_8/validationResult.rds
new file mode 100644
index 00000000..4a8950f4
Binary files /dev/null and b/Covid19ValidatingCovVulIndex/data/Validation/mdcd/Analysis_8/validationResult.rds differ
diff --git a/Covid19ValidatingCovVulIndex/data/Validation/optumDod/Analysis_8/validationResult.rds b/Covid19ValidatingCovVulIndex/data/Validation/optumDod/Analysis_8/validationResult.rds
new file mode 100644
index 00000000..59ecb09b
Binary files /dev/null and b/Covid19ValidatingCovVulIndex/data/Validation/optumDod/Analysis_8/validationResult.rds differ
diff --git a/Covid19ValidatingCovVulIndex/data/Validation/optumEhr/Analysis_8/validationResult.rds b/Covid19ValidatingCovVulIndex/data/Validation/optumEhr/Analysis_8/validationResult.rds
new file mode 100644
index 00000000..3cd13dd9
Binary files /dev/null and b/Covid19ValidatingCovVulIndex/data/Validation/optumEhr/Analysis_8/validationResult.rds differ
diff --git a/Covid19ValidatingCovVulIndex/data/settings.csv b/Covid19ValidatingCovVulIndex/data/settings.csv
new file mode 100644
index 00000000..2624b3b5
--- /dev/null
+++ b/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
\ No newline at end of file
diff --git a/Covid19ValidatingCovVulIndex/global.R b/Covid19ValidatingCovVulIndex/global.R
new file mode 100644
index 00000000..d407ea0e
--- /dev/null
+++ b/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)
+
+
+
+
diff --git a/Covid19ValidatingCovVulIndex/helpers.R b/Covid19ValidatingCovVulIndex/helpers.R
new file mode 100644
index 00000000..6c1feebc
--- /dev/null
+++ b/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')
+ ))
+ }
+}
+
diff --git a/Covid19ValidatingCovVulIndex/html/DataInfo.html b/Covid19ValidatingCovVulIndex/html/DataInfo.html
new file mode 100644
index 00000000..2b8e163f
--- /dev/null
+++ b/Covid19ValidatingCovVulIndex/html/DataInfo.html
@@ -0,0 +1,4 @@
+Description
+ This button provides information about the data used in the app
+
+
\ No newline at end of file
diff --git a/Covid19ValidatingCovVulIndex/html/Description.html b/Covid19ValidatingCovVulIndex/html/Description.html
new file mode 100644
index 00000000..72e455ca
--- /dev/null
+++ b/Covid19ValidatingCovVulIndex/html/Description.html
@@ -0,0 +1,3 @@
+Description
+ Information about the study and links to the code used to run the study
+
\ No newline at end of file
diff --git a/Covid19ValidatingCovVulIndex/html/Help.html b/Covid19ValidatingCovVulIndex/html/Help.html
new file mode 100644
index 00000000..68c76d85
--- /dev/null
+++ b/Covid19ValidatingCovVulIndex/html/Help.html
@@ -0,0 +1,5 @@
+Description
+ This button provides a link to a YouTube video with a demonstration of the shiny app
+
+
+
\ No newline at end of file
diff --git a/Covid19ValidatingCovVulIndex/html/Log.html b/Covid19ValidatingCovVulIndex/html/Log.html
new file mode 100644
index 00000000..3edf488b
--- /dev/null
+++ b/Covid19ValidatingCovVulIndex/html/Log.html
@@ -0,0 +1,4 @@
+Description
+ This button shows the log when the model was developed or validated
+
+
\ No newline at end of file
diff --git a/Covid19ValidatingCovVulIndex/html/Model.html b/Covid19ValidatingCovVulIndex/html/Model.html
new file mode 100644
index 00000000..c8c2e73e
--- /dev/null
+++ b/Covid19ValidatingCovVulIndex/html/Model.html
@@ -0,0 +1,10 @@
+Description
+ The model button shows a plot and table with the characteristics of the patients with and without the outcome during the time-at-risk.
+
+ Interpretation
+
+ - 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.
+ - 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.
+
+
+
\ No newline at end of file
diff --git a/Covid19ValidatingCovVulIndex/html/Performance.html b/Covid19ValidatingCovVulIndex/html/Performance.html
new file mode 100644
index 00000000..9593c04b
--- /dev/null
+++ b/Covid19ValidatingCovVulIndex/html/Performance.html
@@ -0,0 +1,10 @@
+Description
+ The performance of the model including the operating characteristics at different risk cutoffs, the overall discrimination and the overall calibration.
+
+ Tabs
+ The three tabs are:
+
+ - 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)
+ - The 'Discrimination' tab shows the AUROC, AUPRC, predicted risk distributions and F1 score
+ - The 'Calibration' tab shows the generic calibration plot and the calibration per age group and gender.
+
diff --git a/Covid19ValidatingCovVulIndex/html/Summary.html b/Covid19ValidatingCovVulIndex/html/Summary.html
new file mode 100644
index 00000000..c34aa4ff
--- /dev/null
+++ b/Covid19ValidatingCovVulIndex/html/Summary.html
@@ -0,0 +1,25 @@
+Description
+ 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.
+
+ Options
+ 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:
+
+ - The complete performance of the result for the selected row can be viewed by clicking on the 'Performance' button in the left menu
+ - The model corresponding to the result for the selected row can be viewed by clicking on the 'Model' button in the left menu
+ - 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)
+ - 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)
+ - 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)
+ - 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)
+
+
+ Using the Filter
+ Select a specific:
+
+ - development database - database used to develop the model being validated
+ - validation database - database used to evaluate the model being validated
+ - time-at-risk - time period relative to index where the outcome is being predicted
+ - target population - the patient population we are interested in predicting the outcome risk for
+ - outcome - the event being predicted
+ - model - the type of model (e.g., logistic regression, decision tree)
+
+ to filter the table rows of interest.
diff --git a/Covid19ValidatingCovVulIndex/html/boxHelp.html b/Covid19ValidatingCovVulIndex/html/boxHelp.html
new file mode 100644
index 00000000..d9ff1b38
--- /dev/null
+++ b/Covid19ValidatingCovVulIndex/html/boxHelp.html
@@ -0,0 +1,6 @@
+Description
+ 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)
+
+Interpretation
+ 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.
+
diff --git a/Covid19ValidatingCovVulIndex/html/calHelp.html b/Covid19ValidatingCovVulIndex/html/calHelp.html
new file mode 100644
index 00000000..9013fc29
--- /dev/null
+++ b/Covid19ValidatingCovVulIndex/html/calHelp.html
@@ -0,0 +1,6 @@
+Description
+ 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.
+
+Interpretation
+ 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).
+
diff --git a/Covid19ValidatingCovVulIndex/html/demoHelp.html b/Covid19ValidatingCovVulIndex/html/demoHelp.html
new file mode 100644
index 00000000..2b6eaac5
--- /dev/null
+++ b/Covid19ValidatingCovVulIndex/html/demoHelp.html
@@ -0,0 +1,8 @@
+Description
+ 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.
+
+Interpretation
+ 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.
+
+ 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.
+
diff --git a/Covid19ValidatingCovVulIndex/html/f1Help.html b/Covid19ValidatingCovVulIndex/html/f1Help.html
new file mode 100644
index 00000000..e4c59cc6
--- /dev/null
+++ b/Covid19ValidatingCovVulIndex/html/f1Help.html
@@ -0,0 +1,13 @@
+Description
+ The F1 score plot shows the F1 score for each risk threshold. Click here for more information about the F1 score.
+
+Interpretation
+ The F1-score combines the sensitivity and precision of the model into a single measure of accuracy.
+
+Definitions
+
+ - 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)
+
+ - Precision (positive predictive value) - probability that somebody identified by the model as having the outcome at a specified cutoff truly has the outcome
+
+
diff --git a/Covid19ValidatingCovVulIndex/html/prcHelp.html b/Covid19ValidatingCovVulIndex/html/prcHelp.html
new file mode 100644
index 00000000..3416a13a
--- /dev/null
+++ b/Covid19ValidatingCovVulIndex/html/prcHelp.html
@@ -0,0 +1,19 @@
+Description
+ 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 here for more information.
+
+Interpretation
+ 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.
+
+
+Notes
+ 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
+
+Definitions
+
+ - 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)
+
+-
+ 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)
+ - Precision (positive predictive value) - probability that somebody identified by the model as having the outcome at a specified cutoff truly has the outcome
+
+
diff --git a/Covid19ValidatingCovVulIndex/html/predDistHelp.html b/Covid19ValidatingCovVulIndex/html/predDistHelp.html
new file mode 100644
index 00000000..bbccd858
--- /dev/null
+++ b/Covid19ValidatingCovVulIndex/html/predDistHelp.html
@@ -0,0 +1,6 @@
+Description
+ These plots show the probability density function for those with the outcome (red) and those without the outcome (green)
+
+Interpretation
+ 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.
+
diff --git a/Covid19ValidatingCovVulIndex/html/prefDistHelp.html b/Covid19ValidatingCovVulIndex/html/prefDistHelp.html
new file mode 100644
index 00000000..ba0339fa
--- /dev/null
+++ b/Covid19ValidatingCovVulIndex/html/prefDistHelp.html
@@ -0,0 +1,6 @@
+Description
+ These plots show the preference score density function for those with the outcome (red) and those without the outcome (green)
+
+Interpretation
+ 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.
+
diff --git a/Covid19ValidatingCovVulIndex/html/rocHelp.html b/Covid19ValidatingCovVulIndex/html/rocHelp.html
new file mode 100644
index 00000000..f11c74f8
--- /dev/null
+++ b/Covid19ValidatingCovVulIndex/html/rocHelp.html
@@ -0,0 +1,18 @@
+Description
+ The receiver operating characteristic (ROC) curve shows the trade-off between sensitivity and specificity for all possible risk cutoffs. The area below the curve is a measure of overall discriminative performance. Click here for more information.
+
+Interpretation
+ If a model is not able to discriminate then the curve will be approximately the x=y line. A perfectly discriminative model will go up vertically and then across.
+
+Notes
+ If the outcome is rare then the ROC curve doesn't provide insight into the precision of the model and a precision recall curve (PRC) should also be inspected.
+
+Definitions
+
+ - 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)
+
+-
+ 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)
+ - Precision (positive predictive value) - probability that somebody identified by the model as having the outcome at a specified cutoff truly has the outcome
+
+
diff --git a/Covid19ValidatingCovVulIndex/plots.R b/Covid19ValidatingCovVulIndex/plots.R
new file mode 100644
index 00000000..cd791438
--- /dev/null
+++ b/Covid19ValidatingCovVulIndex/plots.R
@@ -0,0 +1,423 @@
+#============ DYNAMIC PLOTS ======================
+#++++++++++++++++++++++++++++++++++++++++++++++++++
+
+plotShiny <- function(eval){
+
+ data <- eval$thresholdSummary[eval$thresholdSummary$Eval%in%c('test','validation'),]
+
+ rocobject <- plotly::plot_ly(x = 1-c(0,data$specificity,1)) %>%
+ plotly::add_lines(y = c(1,data$sensitivity,0),name = "hv",
+ text = paste('Risk Threshold:',c(0,data$predictionThreshold,1)),
+ line = list(shape = "hv",
+ color = 'rgb(22, 96, 167)'),
+ fill = 'tozeroy') %>%
+ plotly::add_trace(x= c(0,1), y = c(0,1),mode = 'lines',
+ line = list(dash = "dash"), color = I('black'),
+ type='scatter') %>%
+ plotly::layout(title = "ROC Plot",
+ xaxis = list(title = "1-specificity"),
+ yaxis = list (title = "Sensitivity"),
+ showlegend = FALSE)
+
+ popAv <- data$trueCount[1]/(data$trueCount[1] + data$falseCount[1])
+ probject <- plotly::plot_ly(x = data$sensitivity) %>%
+ plotly::add_lines(y = data$positivePredictiveValue, name = "hv",
+ text = paste('Risk Threshold:',data$predictionThreshold),
+ line = list(shape = "hv",
+ color = 'rgb(22, 96, 167)'),
+ fill = 'tozeroy') %>%
+ plotly::add_trace(x= c(0,1), y = c(popAv,popAv),mode = 'lines',
+ line = list(dash = "dash"), color = I('red'),
+ type='scatter') %>%
+ plotly::layout(title = "PR Plot",
+ xaxis = list(title = "Recall"),
+ yaxis = list (title = "Precision"),
+ showlegend = FALSE)
+
+ # add F1 score
+ f1object <- plotly::plot_ly(x = data$predictionThreshold) %>%
+ plotly::add_lines(y = data$f1Score, name = "hv",
+ text = paste('Risk Threshold:',data$predictionThreshold),
+ line = list(shape = "hv",
+ color = 'rgb(22, 96, 167)'),
+ fill = 'tozeroy') %>%
+ plotly::layout(title = "F1-Score Plot",
+ xaxis = list(title = "Prediction Threshold"),
+ yaxis = list (title = "F1-Score"),
+ showlegend = FALSE)
+
+ return(list(roc = rocobject,
+ pr = probject,
+ f1score = f1object))
+}
+
+getORC <- function(eval, pointOfInterest){
+
+ data <- eval$thresholdSummary[eval$thresholdSummary$Eval%in%c('test','validation'),]
+ pointOfInterest <- data[pointOfInterest,]
+
+ threshold <- pointOfInterest$predictionThreshold
+ TP <- pointOfInterest$truePositiveCount
+ TN <- pointOfInterest$trueNegativeCount
+ FP <- pointOfInterest$falsePositiveCount
+ FN <- pointOfInterest$falseNegativeCount
+ preferenceThreshold <- pointOfInterest$preferenceThreshold
+ return(list(threshold = threshold, prefthreshold=preferenceThreshold,
+ TP = TP, TN=TN,
+ FP= FP, FN=FN))
+}
+
+plotCovariateSummary <- function(covariateSummary){
+
+ #writeLines(paste(colnames(covariateSummary)))
+ #writeLines(paste(covariateSummary[1,]))
+ # remove na values
+ covariateSummary$CovariateMeanWithNoOutcome[is.na(covariateSummary$CovariateMeanWithNoOutcome)] <- 0
+ covariateSummary$CovariateMeanWithOutcome[is.na(covariateSummary$CovariateMeanWithOutcome)] <- 0
+ if(!'covariateValue'%in%colnames(covariateSummary)){
+ covariateSummary$covariateValue <- 1
+ }
+ if(sum(is.na(covariateSummary$covariateValue))>0){
+ covariateSummary$covariateValue[is.na(covariateSummary$covariateValue)] <- 0
+ }
+
+ # SPEED EDIT remove the none model variables
+ covariateSummary <- covariateSummary[covariateSummary$covariateValue!=0,]
+
+ # save dots based on coef value
+ covariateSummary$size <- abs(covariateSummary$covariateValue)
+ covariateSummary$size[is.na(covariateSummary$size)] <- 4
+ covariateSummary$size <- 4+4*covariateSummary$size/max(covariateSummary$size)
+
+ # color based on analysis id
+ covariateSummary$color <- sapply(covariateSummary$covariateName, function(x) ifelse(is.na(x), '', strsplit(as.character(x), ' ')[[1]][1]))
+
+ covariateSummary$times <- sapply(sapply(covariateSummary$covariateName, function(x) ifelse(is.na(x), '', strsplit(as.character(x), 'during day ')[[1]][2])),function(x) ifelse(is.na(x), '', strsplit(as.character(x), ': ')[[1]][1]))
+ covariateSummary$desc <- sapply(covariateSummary$covariateName, function(x) ifelse(is.na(x), '', strsplit(as.character(x), ': ')[[1]][2]))
+
+
+ l <- list(x = 0.01, y = 1,
+ font = list(
+ family = "sans-serif",
+ size = 10,
+ color = "#000"),
+ bgcolor = "#E2E2E2",
+ bordercolor = "#FFFFFF",
+ borderwidth = 1)
+
+ ind <- covariateSummary$CovariateMeanWithNoOutcome <=1 & covariateSummary$CovariateMeanWithOutcome <= 1
+ # create two plots -1 or less or g1
+ binary <- plotly::plot_ly(x = covariateSummary$CovariateMeanWithNoOutcome[ind],
+ #size = covariateSummary$size[ind],
+ showlegend = F) %>%
+ plotly::add_markers(y = covariateSummary$CovariateMeanWithOutcome[ind],
+ color=factor(covariateSummary$color[ind]),
+ hoverinfo = 'text',
+ text = ~paste(' Type: ', covariateSummary$color[ind],
+ ' Time: ', covariateSummary$times[ind],
+ ' Name: ', covariateSummary$desc[ind]),
+ showlegend = T
+ ) %>%
+ plotly::add_trace(x= c(0,1), y = c(0,1),mode = 'lines',
+ line = list(dash = "dash"), color = I('black'),
+ type='scatter', showlegend = FALSE) %>%
+ plotly::layout(#title = 'Prevalance of baseline predictors in persons with and without outcome',
+ xaxis = list(title = "Prevalance in persons without outcome",
+ range = c(0, 1)),
+ yaxis = list(title = "Prevalance in persons with outcome",
+ range = c(0, 1)),
+ #legend = l, showlegend = T,
+ legend = list(orientation = 'h', y = -0.3), showlegend = T)
+
+ if(sum(!ind)>0){
+ maxValue <- max(c(covariateSummary$CovariateMeanWithNoOutcome[!ind],
+ covariateSummary$CovariateMeanWithOutcome[!ind]), na.rm = T)
+ meas <- plotly::plot_ly(x = covariateSummary$CovariateMeanWithNoOutcome[!ind] ) %>%
+ plotly::add_markers(y = covariateSummary$CovariateMeanWithOutcome[!ind],
+ hoverinfo = 'text',
+ text = ~paste(' Type: ', covariateSummary$color[!ind],
+ ' Time: ', covariateSummary$times[!ind],
+ ' Name: ', covariateSummary$desc[!ind])) %>%
+ plotly::add_trace(x= c(0,maxValue), y = c(0,maxValue),mode = 'lines',
+ line = list(dash = "dash"), color = I('black'),
+ type='scatter', showlegend = FALSE) %>%
+ plotly::layout(#title = 'Prevalance of baseline predictors in persons with and without outcome',
+ xaxis = list(title = "Mean in persons without outcome"),
+ yaxis = list(title = "Mean in persons with outcome"),
+ showlegend = FALSE)
+ } else {
+ meas <- NULL
+ }
+
+ return(list(binary=binary,
+ meas = meas))
+}
+
+
+
+
+
+# adding plots from PLP temporarily as shiny deploy doesnt have PatientLevelPrediction
+
+plotPredictedPDF <- function(evaluation, type='test', fileName=NULL){
+ if(is.null(evaluation$thresholdSummary$Eval)){
+ evaluation$thresholdSummary$Eval <- type
+ }
+ ind <- evaluation$thresholdSummary$Eval==type
+
+ x<- evaluation$thresholdSummary[ind,c('predictionThreshold','truePositiveCount','trueNegativeCount',
+ 'falsePositiveCount','falseNegativeCount')]
+ x<- x[order(x$predictionThreshold,-x$truePositiveCount, -x$falsePositiveCount),]
+ x$out <- c(x$truePositiveCount[-length(x$truePositiveCount)]-x$truePositiveCount[-1], x$truePositiveCount[length(x$truePositiveCount)])
+ x$nout <- c(x$falsePositiveCount[-length(x$falsePositiveCount)]-x$falsePositiveCount[-1], x$falsePositiveCount[length(x$falsePositiveCount)])
+
+ vals <- c()
+ for(i in 1:length(x$predictionThreshold)){
+ if(i!=length(x$predictionThreshold)){
+ upper <- x$predictionThreshold[i+1]} else {upper <- min(x$predictionThreshold[i]+0.01,1)}
+ val <- x$predictionThreshold[i]+runif(x$out[i])*(upper-x$predictionThreshold[i])
+ vals <- c(val, vals)
+ }
+ vals[!is.na(vals)]
+
+ vals2 <- c()
+ for(i in 1:length(x$predictionThreshold)){
+ if(i!=length(x$predictionThreshold)){
+ upper <- x$predictionThreshold[i+1]} else {upper <- min(x$predictionThreshold[i]+0.01,1)}
+ val2 <- x$predictionThreshold[i]+runif(x$nout[i])*(upper-x$predictionThreshold[i])
+ vals2 <- c(val2, vals2)
+ }
+ vals2[!is.na(vals2)]
+
+ x <- rbind(data.frame(variable=rep('outcome',length(vals)), value=vals),
+ data.frame(variable=rep('No outcome',length(vals2)), value=vals2)
+ )
+
+ plot <- ggplot2::ggplot(x, ggplot2::aes(x=value,
+ group=variable,
+ fill=variable)) +
+ ggplot2::geom_density(ggplot2::aes(x=value, fill=variable), alpha=.3) +
+ ggplot2::scale_x_continuous("Prediction Threshold")+#, limits=c(0,1)) +
+ ggplot2::scale_y_continuous("Density") +
+ ggplot2::guides(fill=ggplot2::guide_legend(title="Class"))
+
+ if (!is.null(fileName))
+ ggplot2::ggsave(fileName, plot, width = 5, height = 4.5, dpi = 400)
+ return(plot)
+}
+
+
+
+
+plotPreferencePDF <- function(evaluation, type='test', fileName=NULL){
+ if(is.null(evaluation$thresholdSummary$Eval)){
+ evaluation$thresholdSummary$Eval <- type
+ }
+ ind <- evaluation$thresholdSummary$Eval==type
+
+ x<- evaluation$thresholdSummary[ind,c('preferenceThreshold','truePositiveCount','trueNegativeCount',
+ 'falsePositiveCount','falseNegativeCount')]
+ x<- x[order(x$preferenceThreshold,-x$truePositiveCount),]
+ x$out <- c(x$truePositiveCount[-length(x$truePositiveCount)]-x$truePositiveCount[-1], x$truePositiveCount[length(x$truePositiveCount)])
+ x$nout <- c(x$falsePositiveCount[-length(x$falsePositiveCount)]-x$falsePositiveCount[-1], x$falsePositiveCount[length(x$falsePositiveCount)])
+
+ vals <- c()
+ for(i in 1:length(x$preferenceThreshold)){
+ if(i!=length(x$preferenceThreshold)){
+ upper <- x$preferenceThreshold[i+1]} else {upper <- 1}
+ val <- x$preferenceThreshold[i]+runif(x$out[i])*(upper-x$preferenceThreshold[i])
+ vals <- c(val, vals)
+ }
+ vals[!is.na(vals)]
+
+ vals2 <- c()
+ for(i in 1:length(x$preferenceThreshold)){
+ if(i!=length(x$preferenceThreshold)){
+ upper <- x$preferenceThreshold[i+1]} else {upper <- 1}
+ val2 <- x$preferenceThreshold[i]+runif(x$nout[i])*(upper-x$preferenceThreshold[i])
+ vals2 <- c(val2, vals2)
+ }
+ vals2[!is.na(vals2)]
+
+ x <- rbind(data.frame(variable=rep('outcome',length(vals)), value=vals),
+ data.frame(variable=rep('No outcome',length(vals2)), value=vals2)
+ )
+
+ plot <- ggplot2::ggplot(x, ggplot2::aes(x=value,
+ group=variable,
+ fill=variable)) +
+ ggplot2::geom_density(ggplot2::aes(x=value, fill=variable), alpha=.3) +
+ ggplot2::scale_x_continuous("Preference Threshold")+#, limits=c(0,1)) +
+ ggplot2::scale_y_continuous("Density") +
+ ggplot2::guides(fill=ggplot2::guide_legend(title="Class"))
+
+ if (!is.null(fileName))
+ ggplot2::ggsave(fileName, plot, width = 5, height = 4.5, dpi = 400)
+ return(plot)
+}
+
+
+plotDemographicSummary <- function(evaluation, type='test', fileName=NULL){
+ if (!all(is.na(evaluation$demographicSummary$averagePredictedProbability))){
+ if(is.null(evaluation$demographicSummary$Eval)){
+ evaluation$demographicSummary$Eval <- type
+ }
+ ind <- evaluation$demographicSummary$Eval==type
+ x<- evaluation$demographicSummary[ind,colnames(evaluation$demographicSummary)%in%c('ageGroup','genGroup','averagePredictedProbability',
+ 'PersonCountAtRisk', 'PersonCountWithOutcome')]
+
+
+ # remove -1 values:
+ x$averagePredictedProbability[is.na(x$averagePredictedProbability)] <- 0
+ x <- x[x$PersonCountWithOutcome != -1,]
+ if(nrow(x)==0){
+ return(NULL)
+ }
+
+ x$observed <- x$PersonCountWithOutcome/x$PersonCountAtRisk
+
+
+ x <- x[,colnames(x)%in%c('ageGroup','genGroup','averagePredictedProbability','observed')]
+
+ # if age or gender missing add
+ if(sum(colnames(x)=='ageGroup')==1 && sum(colnames(x)=='genGroup')==0 ){
+ x$genGroup = rep('Non', nrow(x))
+ evaluation$demographicSummary$genGroup = rep('Non', nrow(evaluation$demographicSummary))
+ }
+ if(sum(colnames(x)=='ageGroup')==0 && sum(colnames(x)=='genGroup')==1 ){
+ x$ageGroup = rep('-1', nrow(x))
+ evaluation$demographicSummary$ageGroup = rep('-1', nrow(evaluation$demographicSummary))
+
+ }
+
+ x <- reshape2::melt(x, id.vars=c('ageGroup','genGroup'))
+
+ # 1.96*StDevPredictedProbability
+ ci <- evaluation$demographicSummary[ind,colnames(evaluation$demographicSummary)%in%c('ageGroup','genGroup','averagePredictedProbability','StDevPredictedProbability')]
+ ci$StDevPredictedProbability[is.na(ci$StDevPredictedProbability)] <- 1
+ ci$lower <- ci$averagePredictedProbability-1.96*ci$StDevPredictedProbability
+ ci$lower[ci$lower <0] <- 0
+ ci$upper <- ci$averagePredictedProbability+1.96*ci$StDevPredictedProbability
+ ci$upper[ci$upper >1] <- max(ci$upper[ci$upper <1])
+
+ x$age <- gsub('Age group:','', x$ageGroup)
+ x$age <- factor(x$age,levels=c(" 0-4"," 5-9"," 10-14",
+ " 15-19"," 20-24"," 25-29"," 30-34"," 35-39"," 40-44",
+ " 45-49"," 50-54"," 55-59"," 60-64"," 65-69"," 70-74",
+ " 75-79"," 80-84"," 85-89"," 90-94"," 95-99","-1"),ordered=TRUE)
+
+
+
+ x <- merge(x, ci[,c('ageGroup','genGroup','lower','upper')], by=c('ageGroup','genGroup'))
+ x <- x[!is.na(x$value),]
+
+ plot <- ggplot2::ggplot(data=x,
+ ggplot2::aes(x=age,
+ group=interaction(variable,genGroup))) +
+
+ ggplot2::geom_line(ggplot2::aes(y=value, group=variable,
+ color=variable,
+ linetype = variable))+
+ ggplot2::geom_ribbon(data=x[x$variable!='observed',],
+ ggplot2::aes(ymin=lower, ymax=upper
+ , group=genGroup),
+ fill="blue", alpha=0.2) +
+ ggplot2::facet_grid(.~ genGroup, scales = "free") +
+ ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 90, hjust = 1)) +
+ #ggplot2::coord_flip() +
+ ggplot2::scale_y_continuous("Fraction") +
+ ggplot2::scale_x_discrete("Age") +
+ ggplot2::scale_color_manual(values = c("royalblue4","red"),
+ guide = ggplot2::guide_legend(title = NULL),
+ labels = c("Expected", "Observed")) +
+
+ ggplot2::guides(linetype=FALSE)
+
+ if (!is.null(fileName))
+ ggplot2::ggsave(fileName, plot, width = 7, height = 4.5, dpi = 400)
+ return(plot)
+ }
+}
+
+
+
+plotSparseCalibration2 <- function(evaluation, type='test', fileName=NULL){
+ if(is.null(evaluation$calibrationSummary$Eval)){
+ evaluation$calibrationSummary$Eval <- type
+ }
+ ind <- evaluation$calibrationSummary$Eval==type
+
+ x<- evaluation$calibrationSummary[ind,c('averagePredictedProbability','observedIncidence', 'PersonCountAtRisk')]
+
+
+ cis <- apply(x, 1, function(x) binom.test(x[2]*x[3], x[3], alternative = c("two.sided"), conf.level = 0.95)$conf.int)
+ x$lci <- cis[1,]
+ x$uci <- cis[2,]
+
+ maxes <- max(max(x$averagePredictedProbability), max(x$observedIncidence))*1.1
+
+ # limits <- ggplot2::aes(ymax = x$uci, ymin= x$lci)
+ limits <- ggplot2::aes(ymax = uci, ymin= lci)
+
+ plot <- ggplot2::ggplot(data=x,
+ ggplot2::aes(x=averagePredictedProbability, y=observedIncidence
+ )) +
+ ggplot2::geom_point(size=2, color='black') +
+ ggplot2::geom_errorbar(limits) +
+ #ggplot2::geom_smooth(method=lm, se=F, colour='darkgrey') +
+ ggplot2::geom_line(colour='darkgrey') +
+ ggplot2::geom_abline(intercept = 0, slope = 1, linetype = 5, size=0.4,
+ show.legend = TRUE) +
+ ggplot2::scale_x_continuous("Average Predicted Probability") +
+ ggplot2::scale_y_continuous("Observed Fraction With Outcome") +
+ ggplot2::coord_cartesian(xlim = c(0, maxes), ylim=c(0,maxes))
+
+
+ if (!is.null(fileName))
+ ggplot2::ggsave(fileName, plot, width = 5, height = 3.5, dpi = 400)
+ return(plot)
+}
+
+
+plotPredictionDistribution <- function(evaluation, type='test', fileName=NULL){
+ if(is.null(evaluation$predictionDistribution$Eval)){
+ evaluation$predictionDistribution$Eval <- type
+ }
+ ind <- evaluation$predictionDistribution$Eval==type
+ x<- evaluation$predictionDistribution[ind,]
+
+ #(x=Class, y=predictedProbabllity sequence: min->P05->P25->Median->P75->P95->max)
+
+
+ non05 <- x$P05PredictedProbability[x$class==0]
+ non95 <- x$P95PredictedProbability[x$class==0]
+ one05 <- x$P05PredictedProbability[x$class==1]
+ one95 <- x$P95PredictedProbability[x$class==1]
+
+ plot <- ggplot2::ggplot(x, ggplot2::aes(x=as.factor(class),
+ ymin=MinPredictedProbability,
+ lower=P25PredictedProbability,
+ middle=MedianPredictedProbability,
+ upper=P75PredictedProbability,
+ ymax=MaxPredictedProbability,
+ color=as.factor(class))) +
+ ggplot2::coord_flip() +
+ ggplot2::geom_boxplot(stat="identity") +
+ ggplot2::scale_x_discrete("Class") +
+ ggplot2::scale_y_continuous("Predicted Probability") +
+ ggplot2::theme(legend.position="none") +
+ ggplot2::geom_segment(ggplot2::aes(x = 0.9, y = non05,
+ xend = 1.1, yend = non05), color='red') +
+ ggplot2::geom_segment(ggplot2::aes(x = 0.9, y = non95,
+ xend = 1.1, yend = non95), color='red') +
+ ggplot2::geom_segment(ggplot2::aes(x = 1.9, y = one05,
+ xend = 2.1, yend = one05)) +
+ ggplot2::geom_segment(ggplot2::aes(x = 1.9, y = one95,
+ xend = 2.1, yend = one95))
+
+
+ if (!is.null(fileName))
+ ggplot2::ggsave(fileName, plot, width = 5, height = 4.5, dpi = 400)
+ return(plot)
+}
+
diff --git a/Covid19ValidatingCovVulIndex/processing.R b/Covid19ValidatingCovVulIndex/processing.R
new file mode 100644
index 00000000..4b5a29a8
--- /dev/null
+++ b/Covid19ValidatingCovVulIndex/processing.R
@@ -0,0 +1,230 @@
+
+# this checked whether input is valid analysis location or plpResult
+checkPlpInput <- function(result){
+ if(class(result)=='runPlp'){
+ return('plpResult')
+ } else if(ifelse(class(result)=='character', dir.exists(result),F)){
+ return('file')
+ } else if(sum(names(result)%in%c("prediction","performanceEvaluation","inputSetting","executionSummary","model","analysisRef","covariateSummary"))==7){
+ return('plpNoClass')
+ } else {
+ stop('Incorrect class for input result')
+ }
+}
+
+
+
+getSummary <- function(result,inputType,validation){
+ if(inputType == 'plpResult' || inputType == 'plpNoClass'){
+ sumTab <- getSummaryFromObject(result,validation)
+ } else if( inputType == 'file') {
+ sumTab <- summaryPlpAnalyses(result)
+ }
+
+ #remove empty rows
+ emptyInd <- is.na(sumTab[,'AUC'])
+ if(sum(emptyInd)>0){
+ sumTab <- sumTab[!emptyInd,]
+ }
+
+ #sumTab <- sumTab[,c('analysisId','devDatabase','valDatabase','cohortName','outcomeName','modelSettingName','riskWindowStart', 'riskWindowEnd', 'AUC','AUPRC', 'populationSize','outcomeCount','incidence',
+ # 'addExposureDaysToStart','addExposureDaysToEnd','plpResultLocation', 'plpResultLoad')]
+ #colnames(sumTab) <- c('Analysis','Dev', 'Val', 'T', 'O','Model', 'TAR start', 'TAR end', 'AUC','AUPRC', 'T Size','O Count','O Incidence (%)', 'addExposureDaysToStart','addExposureDaysToEnd', 'plpResultLocation', 'plpResultLoad')
+ sumTab <- sumTab[,c('devDatabase','valDatabase','cohortName','outcomeName','modelSettingName','riskWindowStart', 'riskWindowEnd', 'AUC','AUPRC', 'populationSize','outcomeCount','incidence',
+ 'addExposureDaysToStart','addExposureDaysToEnd','plpResultLocation', 'plpResultLoad')]
+ colnames(sumTab) <- c('Dev', 'Val', 'T', 'O','Model', 'TAR start', 'TAR end', 'AUC','AUPRC', 'T Size','O Count','O Incidence (%)', 'addExposureDaysToStart','addExposureDaysToEnd', 'plpResultLocation', 'plpResultLoad')
+
+ return(sumTab)
+}
+
+
+getSummaryFromObject <- function(result,validation=NULL){
+
+ eval <- as.data.frame(result$performanceEvaluation$evaluationStatistics)
+ eval <- eval[eval$Eval %in% c('test',"validation"),]
+ allRes <- data.frame(analysisId = 1,
+ devDatabase = ifelse(is.null(result$inputSetting$dataExtrractionSettings$cdmDatabaseSchema),'Missing',result$inputSetting$dataExtrractionSettings$cdmDatabaseSchema),
+ valDatabase = ifelse(is.null(result$inputSetting$dataExtrractionSettings$cdmDatabaseSchema),'Missing',result$inputSetting$dataExtrractionSettings$cdmDatabaseSchema),
+ cohortName = 'T',
+ outcomeName = 'O',
+ modelSettingName = result$model$modelSettings$model,
+ riskWindowStart = ifelse(is.null(result$model$populationSettings$riskWindowStart), 'Missing',result$model$populationSettings$riskWindowStart),
+ riskWindowEnd = ifelse(is.null(result$model$populationSettings$riskWindowEnd), 'Missing',result$model$populationSettings$riskWindowEnd),
+ AUC = as.double(as.character(eval$Value[eval$Metric=='AUC.auc'])),
+ AUPRC = as.double(as.character(eval$Value[eval$Metric=='AUPRC'])),
+ populationSize = as.double(as.character(eval$Value[eval$Metric=='populationSize'])),
+ outcomeCount = as.double(as.character(eval$Value[eval$Metric=='outcomeCount'])),
+ incidence = as.double(as.character(eval$Value[eval$Metric=='outcomeCount']))/as.double(as.character(eval$Value[eval$Metric=='populationSize'])),
+ addExposureDaysToStart = ifelse(is.null(result$model$populationSettings$addExposureDaysToStart),'Missing',result$model$populationSettings$addExposureDaysToStart),
+ addExposureDaysToEnd = ifelse(is.null(result$model$populationSettings$addExposureDaysToEnd), 'Missing', result$model$populationSettings$addExposureDaysToEnd),
+ plpResultLocation = 'NULL',
+ plpResultLoad = 'NULL'
+ )
+
+ if(!is.null(validation)){
+ for(i in 1:length(validation$validation)){
+ eval <- as.data.frame(validation$validation[[i]]$performanceEvaluation$evaluationStatistics)
+ tempRes <-data.frame(analysisId = 1+i,
+ devDatabase = result$inputSetting$dataExtrractionSettings$cdmDatabaseSchema,
+ valDatabase = names(validation)[i],
+ cohortName = 'T',
+ outcomeName = 'O',
+ modelSettingName = result$model$modelSettings$model,
+ riskWindowStart = result$model$populationSettings$riskWindowStart,
+ riskWindowEnd = result$model$populationSettings$riskWindowEnd,
+ AUC = as.double(as.character(eval$Value[eval$Metric=='AUC.auc'])),
+ AUPRC = as.double(as.character(eval$Value[eval$Metric=='AUPRC'])),
+ populationSize = as.double(as.character(eval$Value[eval$Metric=='populationSize'])),
+ outcomeCount = as.double(as.character(eval$Value[eval$Metric=='outcomeCount'])),
+ incidence = as.double(as.character(eval$Value[eval$Metric=='outcomeCount']))/as.double(as.character(eval$Value[eval$Metric=='populationSize'])),
+ addExposureDaysToStart = result$model$populationSettings$addExposureDaysToStart,
+ addExposureDaysToEnd = result$model$populationSettings$addExposureDaysToEnd,
+ plpResultLocation = 'NULL',
+ plpResultLoad = 'NULL'
+ )
+ allRes <- rbind(tempRes, allRes)
+ }
+ }
+ return(allRes)
+}
+
+
+
+# old functions:
+
+summaryPlpAnalyses <- function(analysesLocation){
+ # loads the analyses and validations to get summaries
+ #========================================
+ settings <- read.csv(file.path(analysesLocation,'settings.csv'))
+ settings <- settings[,!colnames(settings)%in%c('plpDataFolder','studyPopFile','plpResultFolder')]
+ settings$analysisId <- paste0('Analysis_', settings$analysisId)
+
+ analysisIds <- dir(file.path(analysesLocation), recursive = F, full.names = T)
+ analysisIds <- analysisIds[grep('Analysis_',analysisIds)]
+ if(is.null(settings$devDatabase)){
+ settings$devDatabase <- 'Missing'
+ }
+ settings$valDatabase <- settings$devDatabase
+ devPerformance <- do.call(rbind,lapply(file.path(analysisIds), getPerformance))
+ devPerformance <- merge(settings[,c('analysisId','modelSettingsId', 'cohortName', 'outcomeName',
+ 'populationSettingId','modelSettingName','addExposureDaysToStart',
+ 'riskWindowStart', 'addExposureDaysToEnd',
+ 'riskWindowEnd','devDatabase','valDatabase')],
+ devPerformance, by='analysisId', all.x=T)
+
+ validationLocation <- file.path(analysesLocation,'Validation')
+ if(length(dir(validationLocation))>0){
+ valPerformances <- c()
+ valDatabases <- dir(validationLocation, recursive = F, full.names = T)
+ if(length(grep('plplog.txt', valDatabases))>0){
+ valDatabases <- valDatabases[-grep('plplog.txt', valDatabases)]
+ }
+ for( valDatabase in valDatabases){
+
+ valAnalyses <- dir(valDatabase, recursive = F, full.names = T)
+ valAnalyses <- valAnalyses[grep('Analysis_', valAnalyses)]
+ valPerformance <- do.call(rbind,lapply(file.path(valAnalyses), function(x) getValidationPerformance(x)))
+ valSettings <- settings[,c('analysisId','modelSettingsId', 'cohortName', 'outcomeName',
+ 'populationSettingId','modelSettingName','addExposureDaysToStart',
+ 'riskWindowStart', 'addExposureDaysToEnd',
+ 'riskWindowEnd','devDatabase')]
+ #valSettings$devDatabase <- settings$devDatabase[1]
+ valPerformance <- merge(valSettings,
+ valPerformance, by='analysisId')
+ valPerformance <- valPerformance[,colnames(devPerformance)] # make sure same order
+ valPerformances <- rbind(valPerformances, valPerformance)
+ }
+
+ if(ncol(valPerformances)==ncol(devPerformance)){
+ allPerformance <- rbind(devPerformance,valPerformances)
+ } else{
+ stop('Issue with dev and val performance data.frames')
+ }
+ } else {
+ allPerformance <- devPerformance
+ }
+
+ allPerformance$AUC <- as.double(allPerformance$AUC)
+ allPerformance$AUPRC <- as.double(allPerformance$AUPRC)
+ allPerformance$outcomeCount <- as.double(allPerformance$outcomeCount)
+ allPerformance$populationSize <- as.double(allPerformance$populationSize)
+ allPerformance$incidence <- as.double(allPerformance$incidence)
+ return(allPerformance)
+}
+
+getPerformance <- function(analysisLocation){
+ location <- file.path(analysisLocation, 'plpResult.rds')
+ if(!file.exists(location)){
+ # check for PLP file instead
+ locationPlp <- file.path(analysisLocation, 'plpResult')
+ if(!dir.exists(locationPlp)){
+
+ analysisId <- strsplit(analysisLocation, '/')[[1]]
+ return(data.frame(analysisId=analysisId[length(analysisId)],
+ AUC=0.000, AUPRC=0, outcomeCount=0,
+ populationSize=0,incidence=0,plpResultLocation=location,
+ plpResultLoad='loadPlpResult'))
+ } else {
+ require(PatientLevelPrediction)
+ res <- loadPlpResult(file.path(analysisLocation,'plpResult'))
+ res <- as.data.frame(res$performanceEvaluation$evaluationStatistics)
+ location <- file.path(analysisLocation, 'plpResult')
+ plpResultLoad <- 'loadPlpResult'
+
+ }
+ } else{
+ # read rds here
+ res <- readRDS(file.path(analysisLocation,'plpResult.rds'))
+ res <- as.data.frame(res$performanceEvaluation$evaluationStatistics)
+ plpResultLoad <- 'readRDS'
+ }
+
+ #if empty do edit?
+
+ res <- tryCatch(reshape2::dcast(res[res$Eval=='test',], analysisId ~ Metric, value.var='Value'),
+ error = function(cont) return(NULL))
+ if(is.null(res)){
+ return(NULL) }
+ res <- res[,!colnames(res)%in%c("BrierScore","BrierScaled")]
+ res$incidence <- as.double(res$outcomeCount)/as.double(res$populationSize)*100
+ res[, !colnames(res)%in%c('analysisId','outcomeCount','populationSize')] <-
+ format(as.double(res[, !colnames(res)%in%c('analysisId','outcomeCount','populationSize')]), digits = 2, scientific = F)
+
+ if(sum(colnames(res)=='AUC.auc_ub95ci')>0){
+ res$AUC <- res$AUC.auc
+ #res$AUC <- paste0(res$AUC.auc, ' (', res$AUC.auc_lb95ci,'-', res$AUC.auc_ub95ci,')')
+ }
+
+ res$plpResultLocation <- location
+ res$plpResultLoad <- plpResultLoad
+ return(res[,c('analysisId', 'AUC', 'AUPRC', 'outcomeCount','populationSize','incidence','plpResultLocation', 'plpResultLoad')])
+}
+
+getValidationPerformance <- function(validationLocation){
+ val <- readRDS(file.path(validationLocation,'validationResult.rds'))
+ if("performanceEvaluation"%in%names(val)){
+ valPerformance <- reshape2::dcast(as.data.frame(val$performanceEvaluation$evaluationStatistics),
+ analysisId ~ Metric, value.var='Value')
+ } else {
+ valPerformance <- reshape2::dcast(as.data.frame(val[[1]]$performanceEvaluation$evaluationStatistics),
+ analysisId ~ Metric, value.var='Value')
+ }
+ valPerformance$incidence <- as.double(valPerformance$outcomeCount)/as.double(valPerformance$populationSize)*100
+ valPerformance[, !colnames(valPerformance)%in%c('analysisId','outcomeCount','populationSize')] <-
+ format(as.double(valPerformance[, !colnames(valPerformance)%in%c('analysisId','outcomeCount','populationSize')]), digits = 2, scientific = F)
+
+ if(sum(colnames(valPerformance)=='AUC.auc_ub95ci')>0){
+ valPerformance$AUC <- valPerformance$AUC.auc
+ #valPerformance$AUC <- paste0(valPerformance$AUC.auc, ' (', valPerformance$AUC.auc_lb95ci,'-', valPerformance$AUC.auc_ub95ci,')')
+ }
+ valPerformance$analysisId <- strsplit(validationLocation, '/')[[1]][[length(strsplit(validationLocation, '/')[[1]])]]
+ valPerformance$valDatabase <- strsplit(validationLocation, '/')[[1]][[length(strsplit(validationLocation, '/')[[1]])-1]]
+ valPerformance <- valPerformance[,c('analysisId','valDatabase', 'AUC', 'AUPRC', 'outcomeCount','populationSize','incidence')]
+ valPerformance$plpResultLocation <- file.path(validationLocation,'validationResult.rds')
+ valPerformance$plpResultLoad <- 'readRDS'
+ #valPerformance$rocplot <- file.path(validationLocation,'plots','sparseROC.pdf')
+ #valPerformance$calplot <- file.path(validationLocation,'plots','sparseCalibrationConventional.pdf')
+ return(valPerformance)
+}
+
+
diff --git a/Covid19ValidatingCovVulIndex/server.R b/Covid19ValidatingCovVulIndex/server.R
new file mode 100644
index 00000000..2d91049a
--- /dev/null
+++ b/Covid19ValidatingCovVulIndex/server.R
@@ -0,0 +1,356 @@
+# @file server.R
+#
+# Copyright 2018 Observational Health Data Sciences and Informatics
+#
+# This file is part of PatientLevelPrediction
+#
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+#
+# http://www.apache.org/licenses/LICENSE-2.0
+#
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+library(shiny)
+library(plotly)
+library(shinycssloaders)
+
+source("helpers.R")
+source("plots.R")
+
+server <- shiny::shinyServer(function(input, output, session) {
+ session$onSessionEnded(shiny::stopApp)
+ filterIndex <- shiny::reactive({getFilter(summaryTable,input)})
+
+ print(summaryTable)
+
+ # need to remove over columns:
+ output$summaryTable <- DT::renderDataTable(DT::datatable(summaryTable[filterIndex(),!colnames(summaryTable)%in%c('addExposureDaysToStart','addExposureDaysToEnd', 'plpResultLocation', 'plpResultLoad')],
+ rownames= FALSE, selection = 'single',
+ extensions = 'Buttons', options = list(
+ dom = 'Bfrtip', buttons = I('colvis')
+ ),
+
+ container = htmltools::withTags(table(
+ class = 'display',
+ thead(
+ #tags$th(title=active_columns[i], colnames(data)[i])
+ tr(apply(data.frame(colnames=c('Dev', 'Val', 'T','O', 'Model',
+ 'TAR start', 'TAR end', 'AUC', 'AUPRC',
+ 'T Size', 'O Count', 'O Incidence (%)'),
+ labels=c('Database used to develop the model', 'Database used to evaluate model', 'Target population - the patients you want to predict risk for','Outcome - what you want to predict',
+ 'Model type','Time-at-risk start day', 'Time-at-risk end day', 'Area under the reciever operating characteristics (test or validation)', 'Area under the precision recall curve (test or validation)',
+ 'Target population size of test or validation set', 'Outcome count in test or validation set', 'Percentage of target population that have outcome during time-at-risk')), 1,
+ function(x) th(title=x[2], x[1])))
+ )
+ ))
+
+ )
+ )
+
+
+ selectedRow <- shiny::reactive({
+ if(is.null(input$summaryTable_rows_selected[1])){
+ return(1)
+ }else{
+ return(input$summaryTable_rows_selected[1])
+ }
+ })
+
+
+
+ plpResult <- shiny::reactive({getPlpResult(result,validation,summaryTable, inputType,filterIndex(), selectedRow())})
+
+ # covariate table
+ output$modelView <- DT::renderDataTable(editCovariates(plpResult()$covariateSummary)$table,
+ colnames = editCovariates(plpResult()$covariateSummary)$colnames)
+
+
+ output$modelCovariateInfo <- DT::renderDataTable(data.frame(covariates = nrow(plpResult()$covariateSummary),
+ nonZeroCount = sum(plpResult()$covariateSummary$covariateValue!=0)))
+
+ # Downloadable csv of model ----
+ output$downloadData <- shiny::downloadHandler(
+ filename = function(){'model.csv'},
+ content = function(file) {
+ write.csv(plpResult()$covariateSummary[plpResult()$covariateSummary$covariateValue!=0,c('covariateName','covariateValue','CovariateCount','CovariateMeanWithOutcome','CovariateMeanWithNoOutcome' )]
+ , file, row.names = FALSE)
+ }
+ )
+
+ # input tables
+ output$modelTable <- DT::renderDataTable(formatModSettings(plpResult()$model$modelSettings ))
+ output$covariateTable <- DT::renderDataTable(formatCovSettings(plpResult()$model$metaData$call$covariateSettings))
+ output$populationTable <- DT::renderDataTable(formatPopSettings(plpResult()$model$populationSettings))
+
+
+
+
+ # prediction text
+ output$info <- shiny::renderText(paste0('Within ', summaryTable[filterIndex(),'T'][selectedRow()],
+ ' predict who will develop ', summaryTable[filterIndex(),'O'][selectedRow()],
+ ' during ',summaryTable[filterIndex(),'TAR start'][selectedRow()], ' day/s',
+ ' after ', ifelse(summaryTable[filterIndex(),'addExposureDaysToStart'][selectedRow()]==0, ' cohort start ', ' cohort end '),
+ ' and ', summaryTable[filterIndex(),'TAR end'][selectedRow()], ' day/s',
+ ' after ', ifelse(summaryTable[filterIndex(),'addExposureDaysToEnd'][selectedRow()]==0, ' cohort start ', ' cohort end '))
+ )
+
+ # PLOTTING FUNCTION
+ plotters <- shiny::reactive({
+
+ eval <- plpResult()$performanceEvaluation
+ if(is.null(eval)){return(NULL)}
+
+ calPlot <- NULL
+ rocPlot <- NULL
+ prPlot <- NULL
+ f1Plot <- NULL
+
+ if(!is.null(eval)){
+ #intPlot <- plotShiny(eval, input$slider1) -- RMS
+ intPlot <- plotShiny(eval)
+ rocPlot <- intPlot$roc
+ prPlot <- intPlot$pr
+ f1Plot <- intPlot$f1score
+
+ list(rocPlot= rocPlot,
+ prPlot=prPlot, f1Plot=f1Plot)
+ }
+ })
+
+
+ performance <- shiny::reactive({
+
+ eval <- plpResult()$performanceEvaluation
+
+ if(is.null(eval)){
+ return(NULL)
+ } else {
+ intPlot <- getORC(eval, input$slider1)
+ threshold <- intPlot$threshold
+ prefthreshold <- intPlot$prefthreshold
+ TP <- intPlot$TP
+ FP <- intPlot$FP
+ TN <- intPlot$TN
+ FN <- intPlot$FN
+ }
+
+ twobytwo <- as.data.frame(matrix(c(FP,TP,TN,FN), byrow=T, ncol=2))
+ colnames(twobytwo) <- c('Ground Truth Negative','Ground Truth Positive')
+ rownames(twobytwo) <- c('Predicted Positive','Predicted Negative')
+
+ list(threshold = threshold,
+ prefthreshold = prefthreshold,
+ twobytwo = twobytwo,
+ Incidence = (TP+FN)/(TP+TN+FP+FN),
+ Threshold = threshold,
+ Sensitivity = TP/(TP+FN),
+ Specificity = TN/(TN+FP),
+ PPV = TP/(TP+FP),
+ NPV = TN/(TN+FN) )
+ })
+
+
+ # preference plot
+ output$prefdist <- shiny::renderPlot({
+ if(is.null(plpResult()$performanceEvaluation)){
+ return(NULL)
+ } else{
+ plotPreferencePDF(plpResult()$performanceEvaluation,
+ type=plpResult()$type ) #+
+ # ggplot2::geom_vline(xintercept=plotters()$prefthreshold) -- RMS
+ }
+ })
+
+ output$preddist <- shiny::renderPlot({
+ if(is.null(plpResult()$performanceEvaluation)){
+ return(NULL)
+ } else{
+ plotPredictedPDF(plpResult()$performanceEvaluation,
+ type=plpResult()$type ) # +
+ #ggplot2::geom_vline(xintercept=plotters()$threshold) -- RMS
+ }
+ })
+
+ output$box <- shiny::renderPlot({
+ if(is.null(plpResult()$performanceEvaluation)){
+ return(NULL)
+ } else{
+ plotPredictionDistribution(plpResult()$performanceEvaluation, type=plpResult()$type )
+ }
+ })
+
+ output$cal <- shiny::renderPlot({
+ if(is.null(plpResult()$performanceEvaluation)){
+ return(NULL)
+ } else{
+ plotSparseCalibration2(plpResult()$performanceEvaluation, type=plpResult()$type )
+ }
+ })
+
+ output$demo <- shiny::renderPlot({
+ if(is.null(plpResult()$performanceEvaluation)){
+ return(NULL)
+ } else{
+ tryCatch(plotDemographicSummary(plpResult()$performanceEvaluation,
+ type=plpResult()$type ),
+ error= function(cond){return(NULL)})
+ }
+ })
+
+
+
+ # Do the tables and plots:
+
+ output$performance <- shiny::renderTable(performance()$performance,
+ rownames = F, digits = 3)
+ output$twobytwo <- shiny::renderTable(performance()$twobytwo,
+ rownames = T, digits = 0)
+
+
+ output$threshold <- shiny::renderText(format(performance()$threshold,digits=5))
+
+ output$roc <- plotly::renderPlotly({
+ plotters()$rocPlot
+ })
+
+ output$pr <- plotly::renderPlotly({
+ plotters()$prPlot
+ })
+ output$f1 <- plotly::renderPlotly({
+ plotters()$f1Plot
+ })
+
+
+
+
+
+
+ # covariate model plots
+ covs <- shiny::reactive({
+ if(is.null(plpResult()$covariateSummary))
+ return(NULL)
+ plotCovariateSummary(formatCovariateTable(plpResult()$covariateSummary))
+ })
+
+ output$covariateSummaryBinary <- plotly::renderPlotly({ covs()$binary })
+ output$covariateSummaryMeasure <- plotly::renderPlotly({ covs()$meas })
+
+ # LOG
+ output$log <- shiny::renderText( paste(plpResult()$log, collapse="\n") )
+
+ # dashboard
+
+ output$performanceBoxIncidence <- shinydashboard::renderInfoBox({
+ shinydashboard::infoBox(
+ "Incidence", paste0(round(performance()$Incidence*100, digits=3),'%'), icon = shiny::icon("ambulance"),
+ color = "green"
+ )
+ })
+
+ output$performanceBoxThreshold <- shinydashboard::renderInfoBox({
+ shinydashboard::infoBox(
+ "Threshold", format((performance()$Threshold), scientific = F, digits=3), icon = shiny::icon("edit"),
+ color = "yellow"
+ )
+ })
+
+ output$performanceBoxPPV <- shinydashboard::renderInfoBox({
+ shinydashboard::infoBox(
+ "PPV", paste0(round(performance()$PPV*1000)/10, "%"), icon = shiny::icon("thumbs-up"),
+ color = "orange"
+ )
+ })
+
+ output$performanceBoxSpecificity <- shinydashboard::renderInfoBox({
+ shinydashboard::infoBox(
+ "Specificity", paste0(round(performance()$Specificity*1000)/10, "%"), icon = shiny::icon("bullseye"),
+ color = "purple"
+ )
+ })
+
+ output$performanceBoxSensitivity <- shinydashboard::renderInfoBox({
+ shinydashboard::infoBox(
+ "Sensitivity", paste0(round(performance()$Sensitivity*1000)/10, "%"), icon = shiny::icon("low-vision"),
+ color = "blue"
+ )
+ })
+
+ output$performanceBoxNPV <- shinydashboard::renderInfoBox({
+ shinydashboard::infoBox(
+ "NPV", paste0(round(performance()$NPV*1000)/10, "%"), icon = shiny::icon("minus-square"),
+ color = "black"
+ )
+ })
+
+
+
+
+
+ # HELPER INFO
+ showInfoBox <- function(title, htmlFileName) {
+ shiny::showModal(shiny::modalDialog(
+ title = title,
+ easyClose = TRUE,
+ footer = NULL,
+ size = "l",
+ shiny::HTML(readChar(htmlFileName, file.info(htmlFileName)$size) )
+ ))
+ }
+
+
+ observeEvent(input$DescriptionInfo, {
+ showInfoBox("Description", "html/Description.html")
+ })
+ observeEvent(input$SummaryInfo, {
+ showInfoBox("Summary", "html/Summary.html")
+ })
+ observeEvent(input$PerformanceInfo, {
+ showInfoBox("Performance", "html/Performance.html")
+ })
+ observeEvent(input$ModelInfo, {
+ showInfoBox("Model", "html/Model.html")
+ })
+ observeEvent(input$LogInfo, {
+ showInfoBox("Log", "html/Log.html")
+ })
+ observeEvent(input$DataInfoInfo, {
+ showInfoBox("DataInfo", "html/DataInfo.html")
+ })
+ observeEvent(input$HelpInfo, {
+ showInfoBox("HelpInfo", "html/Help.html")
+ })
+
+
+ observeEvent(input$rocHelp, {
+ showInfoBox("ROC Help", "html/rocHelp.html")
+ })
+ observeEvent(input$prcHelp, {
+ showInfoBox("PRC Help", "html/prcHelp.html")
+ })
+ observeEvent(input$f1Help, {
+ showInfoBox("F1 Score Plot Help", "html/f1Help.html")
+ })
+ observeEvent(input$boxHelp, {
+ showInfoBox("Box Plot Help", "html/boxHelp.html")
+ })
+ observeEvent(input$predDistHelp, {
+ showInfoBox("Predicted Risk Distribution Help", "html/predDistHelp.html")
+ })
+ observeEvent(input$prefDistHelp, {
+ showInfoBox("Preference Score Distribution Help", "html/prefDistHelp.html")
+ })
+ observeEvent(input$calHelp, {
+ showInfoBox("Calibration Help", "html/calHelp.html")
+ })
+ observeEvent(input$demoHelp, {
+ showInfoBox("Demographic Help", "html/demoHelp.html")
+ })
+
+
+})
\ No newline at end of file
diff --git a/Covid19ValidatingCovVulIndex/ui.R b/Covid19ValidatingCovVulIndex/ui.R
new file mode 100644
index 00000000..e452fe1c
--- /dev/null
+++ b/Covid19ValidatingCovVulIndex/ui.R
@@ -0,0 +1,269 @@
+# @file Ui.R
+#
+# Copyright 2018 Observational Health Data Sciences and Informatics
+#
+# This file is part of PatientLevelPrediction
+#
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+#
+# http://www.apache.org/licenses/LICENSE-2.0
+#
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+library(shiny)
+library(plotly)
+library(shinycssloaders)
+library(shinydashboard)
+
+addInfo <- function(item, infoId) {
+ infoTag <- tags$small(class = "badge pull-right action-button",
+ style = "padding: 1px 6px 2px 6px; background-color: steelblue;",
+ type = "button",
+ id = infoId,
+ "i")
+ item$children[[1]]$children <- append(item$children[[1]]$children, list(infoTag))
+ return(item)
+}
+
+ui <- shinydashboard::dashboardPage(skin = 'black',
+
+ shinydashboard::dashboardHeader(title = "Multiple PLP Viewer",
+
+ tags$li(div(img(src = 'logo.png',
+ title = "OHDSI PLP", height = "40px", width = "40px"),
+ style = "padding-top:0px; padding-bottom:0px;"),
+ class = "dropdown")
+
+
+ ),
+
+ shinydashboard::dashboardSidebar(
+ shinydashboard::sidebarMenu(
+ addInfo(shinydashboard::menuItem("Description", tabName = "Description", icon = shiny::icon("home")), "DescriptionInfo"),
+ addInfo(shinydashboard::menuItem("Summary", tabName = "Summary", icon = shiny::icon("table")), "SummaryInfo"),
+ addInfo(shinydashboard::menuItem("Performance", tabName = "Performance", icon = shiny::icon("bar-chart")), "PerformanceInfo"),
+ addInfo(shinydashboard::menuItem("Model", tabName = "Model", icon = shiny::icon("clipboard")), "ModelInfo"),
+ addInfo(shinydashboard::menuItem("Log", tabName = "Log", icon = shiny::icon("list")), "LogInfo"),
+ addInfo(shinydashboard::menuItem("Data Info", tabName = "DataInfo", icon = shiny::icon("database")), "DataInfoInfo"),
+ addInfo(shinydashboard::menuItem("Help", tabName = "Help", icon = shiny::icon("info")), "HelpInfo")
+ )
+ ),
+
+ shinydashboard::dashboardBody(
+ shinydashboard::tabItems(
+
+ # help tab
+ shinydashboard::tabItem(tabName = "Help",
+ shiny::h2("Information"),
+ shiny::p("Click on a row to explore the results for that model. When you wish to explore a different model, then select the new result row and the tabs will be updated."),
+ shiny::a("Demo Video", href = 'https://youtu.be/StpV40yl1UE', target='_blank')
+ ),
+
+ # First tab content
+ shinydashboard::tabItem(tabName = "Description",
+ shiny::includeMarkdown(path = "./www/shinyDescription.md")
+
+ ),
+ shinydashboard::tabItem(tabName = "DataInfo",
+ shiny::includeMarkdown(path = "./www/dataInfo.md")
+
+ ),
+ shinydashboard::tabItem(tabName = "Summary",
+
+ shiny::fluidRow(
+ shiny::column(2,
+ shiny::h4('Filters'),
+ shiny::selectInput('modelSettingName', 'Model:', c('All',unique(as.character(summaryTable$Model)))),
+ shiny::selectInput('devDatabase', 'Development Database', c('All',unique(as.character(summaryTable$Dev)))),
+ shiny::selectInput('valDatabase', 'Validation Database', c('All',unique(as.character(summaryTable$Val)))),
+ shiny::selectInput('T', 'Target Cohort', c('All',unique(as.character(summaryTable$`T`)))),
+ shiny::selectInput('O', 'Outcome Cohort', c('All',unique(as.character(summaryTable$`O`)))),
+ shiny::selectInput('riskWindowStart', 'Time-at-risk start:', c('All',unique(as.character(summaryTable$`TAR start`)))),
+ shiny::selectInput('riskWindowEnd', 'Time-at-risk end:', c('All',unique(as.character(summaryTable$`TAR end`))))
+ ),
+ shiny::column(10, style = "background-color:#F3FAFC;",
+
+ # do this inside tabs:
+ shiny::tabsetPanel(
+
+ shiny::tabPanel("Results",
+ shiny::div(DT::dataTableOutput('summaryTable'),
+ style = "font-size:70%")),
+
+ shiny::tabPanel("Model Settings",
+ shiny::h3('Model Settings: ',
+ shiny::a("help", href="https://ohdsi.github.io/PatientLevelPrediction/reference/index.html", target="_blank")
+ ),
+ DT::dataTableOutput('modelTable')),
+
+ shiny::tabPanel("Population Settings",
+ shiny::h3('Population Settings: ',
+ shiny::a("help", href="https://ohdsi.github.io/PatientLevelPrediction/reference/createStudyPopulation.html", target="_blank")
+ ),
+ DT::dataTableOutput('populationTable')),
+
+ shiny::tabPanel("Covariate Settings",
+ shiny::h3('Covariate Settings: ',
+ shiny::a("help", href="http://ohdsi.github.io/FeatureExtraction/reference/createCovariateSettings.html", target="_blank")
+ ),
+ DT::dataTableOutput('covariateTable'))
+ )
+
+ )
+
+ )),
+ # second tab
+ shinydashboard::tabItem(tabName = "Performance",
+
+ shiny::fluidRow(
+ tabBox(
+ title = "Performance",
+ # The id lets us use input$tabset1 on the server to find the current tab
+ id = "tabset1", height = "100%", width='100%',
+ tabPanel("Summary",
+
+ shiny::fluidRow(
+ shiny::column(width = 4,
+ shinydashboard::box(width = 12,
+ title = tagList(shiny::icon("question"),"Prediction Question"), status = "info", solidHeader = TRUE,
+ shiny::textOutput('info')
+ ),
+ shinydashboard::box(width = 12,
+ title = tagList(shiny::icon("gear"), "Input"),
+ status = "info", solidHeader = TRUE,
+ shiny::splitLayout(
+ cellWidths = c('5%', '90%', '5%'),
+ shiny::h5(' '),
+ shiny::sliderInput("slider1",
+ shiny::h4("Threshold value slider: ", strong(shiny::textOutput('threshold'))),
+ min = 1, max = 100, value = 50, ticks = F),
+ shiny::h5(' ')
+ ),
+ shiny::splitLayout(
+ cellWidths = c('5%', '90%', '5%'),
+ shiny::h5(strong('0')),
+ shiny::h5(' '),
+ shiny::h5(strong('1'))
+ ),
+ shiny::tags$script(shiny::HTML("
+ $(document).ready(function() {setTimeout(function() {
+ supElement = document.getElementById('slider1').parentElement;
+ $(supElement).find('span.irs-max, span.irs-min, span.irs-single, span.irs-from, span.irs-to').remove();
+ }, 50);})
+ "))
+ )
+
+ ),
+
+
+ shiny::column(width = 8,
+ shinydashboard::box(width = 12,
+ title = "Dashboard",
+ status = "warning", solidHeader = TRUE,
+ shinydashboard::infoBoxOutput("performanceBoxThreshold"),
+ shinydashboard::infoBoxOutput("performanceBoxIncidence"),
+ shinydashboard::infoBoxOutput("performanceBoxPPV"),
+ shinydashboard::infoBoxOutput("performanceBoxSpecificity"),
+ shinydashboard::infoBoxOutput("performanceBoxSensitivity"),
+ shinydashboard::infoBoxOutput("performanceBoxNPV")
+
+ ),
+ shinydashboard::box(width = 12,
+ title = "Cutoff Performance",
+ status = "warning", solidHeader = TRUE,
+ shiny::tableOutput('twobytwo')
+ #infoBoxOutput("performanceBox"),
+ )
+ )
+ )
+
+
+ ),
+ tabPanel("Discrimination",
+
+ shiny::fluidRow(
+ shinydashboard::box( status = 'info',
+ title = actionLink("rocHelp", "ROC Plot", icon = icon("info")),
+ solidHeader = TRUE,
+ shinycssloaders::withSpinner(plotly::plotlyOutput('roc'))),
+ shinydashboard::box(status = 'info',
+ title = actionLink("prcHelp", "Precision recall plot", icon = icon("info")),
+ solidHeader = TRUE,
+ side = "right",
+ shinycssloaders::withSpinner(plotly::plotlyOutput('pr')))),
+
+ shiny::fluidRow(
+ shinydashboard::box(status = 'info',
+ title = actionLink("f1Help", "F1 Score Plot", icon = icon("info")),
+ solidHeader = TRUE,
+ shinycssloaders::withSpinner(plotly::plotlyOutput('f1'))),
+ shinydashboard::box(status = 'info',
+ title = actionLink("boxHelp","Box Plot", icon = icon("info")),
+ solidHeader = TRUE,
+ side = "right",
+ shinycssloaders::withSpinner(shiny::plotOutput('box')))),
+
+ shiny::fluidRow(
+ shinydashboard::box(status = 'info',
+ title = actionLink("predDistHelp","Prediction Score Distribution", icon = icon("info")),
+ solidHeader = TRUE,
+ shinycssloaders::withSpinner(shiny::plotOutput('preddist'))),
+ shinydashboard::box(status = 'info',
+ title = actionLink("prefDistHelp","Preference Score Distribution", icon = icon("info")),
+ solidHeader = TRUE,
+ side = "right",
+ shinycssloaders::withSpinner(shiny::plotOutput('prefdist'))))
+
+
+ ),
+ tabPanel("Calibration",
+ shiny::fluidRow(
+ shinydashboard::box(status = 'info',
+ title = actionLink("calHelp","Calibration Plot", icon = icon("info")),
+ solidHeader = TRUE,
+ shinycssloaders::withSpinner(shiny::plotOutput('cal'))),
+ shinydashboard::box(status = 'info',
+ title = actionLink("demoHelp","Demographic Plot", icon = icon("info")),
+ solidHeader = TRUE,
+ side = "right",
+ shinycssloaders::withSpinner(shiny::plotOutput('demo')))
+ )
+ )
+ ))),
+
+ # 3rd tab
+ shinydashboard::tabItem(tabName = "Model",
+ shiny::fluidRow(
+ shinydashboard::box( status = 'info',
+ title = "Binary", solidHeader = TRUE,
+ shinycssloaders::withSpinner(plotly::plotlyOutput('covariateSummaryBinary'))),
+ shinydashboard::box(status = 'info',
+ title = "Measurements", solidHeader = TRUE,
+ side = "right",
+ shinycssloaders::withSpinner(plotly::plotlyOutput('covariateSummaryMeasure')))),
+ shiny::fluidRow(width=12,
+ shinydashboard::box(status = 'info', width = 12,
+ title = "Covariates", solidHeader = TRUE,
+ DT::dataTableOutput('modelCovariateInfo'))),
+ shiny::fluidRow(width=12,
+ shinydashboard::box(status = 'info', width = 12,
+ title = "Model Table", solidHeader = TRUE,
+ shiny::downloadButton("downloadData", "Download Model"),
+ DT::dataTableOutput('modelView')))
+ ),
+
+ # 4th tab
+ shinydashboard::tabItem(tabName = "Log",
+ shiny::verbatimTextOutput('log')
+ )
+
+
+ )
+ )
+ )
\ No newline at end of file
diff --git a/Covid19ValidatingCovVulIndex/www/about.png b/Covid19ValidatingCovVulIndex/www/about.png
new file mode 100644
index 00000000..878a509e
Binary files /dev/null and b/Covid19ValidatingCovVulIndex/www/about.png differ
diff --git a/Covid19ValidatingCovVulIndex/www/custom.css b/Covid19ValidatingCovVulIndex/www/custom.css
new file mode 100644
index 00000000..26730bbd
--- /dev/null
+++ b/Covid19ValidatingCovVulIndex/www/custom.css
@@ -0,0 +1,81 @@
+.plotly.html-widget.html-widget-output.shiny-bound-output.js-plotly-plot {
+ z-index: 22;
+ position: relative;
+}
+
+.plotlybars {
+ padding: 0 10px;
+ vertical-align: bottom;
+ width: 100%;
+ height: 100%;
+ overflow: hidden;
+ position: relative;
+ box-sizing: border-box;
+}
+
+.plotlybars-wrapper {
+ width: 165px;
+ height: 100px;
+ margin: 0 auto;
+ left: 0;
+ right: 0;
+ position: absolute;
+ z-index: 1;
+}
+
+.plotlybars-text {
+ color: #447adb;
+ font-family: 'Open Sans', verdana, arial, sans-serif;
+ font-size: 80%;
+ text-align: center;
+ margin-top: 5px;
+}
+
+.plotlybars-bar {
+ background-color: #447adb;
+ height: 100%;
+ width: 13.3%;
+ position: absolute;
+
+ -webkit-transform: translateZ(0);
+ transform: translateZ(0);
+
+ animation-duration: 2s;
+ animation-iteration-count: infinite;
+ animation-direction: normal;
+ animation-timing-function: linear;
+
+ -webkit-animation-duration: 2s;
+ -webkit-animation-iteration-count: infinite;
+ -webkit-animation-direction: normal;
+ -webkit-animation-timing-function: linear;
+}
+
+.b1 { left: 0%; top: 88%; animation-name: b1; -webkit-animation-name: b1; }
+.b2 { left: 14.3%; top: 76%; animation-name: b2; -webkit-animation-name: b2; }
+.b3 { left: 28.6%; top: 16%; animation-name: b3; -webkit-animation-name: b3; }
+.b4 { left: 42.9%; top: 40%; animation-name: b4; -webkit-animation-name: b4; }
+.b5 { left: 57.2%; top: 26%; animation-name: b5; -webkit-animation-name: b5; }
+.b6 { left: 71.5%; top: 67%; animation-name: b6; -webkit-animation-name: b6; }
+.b7 { left: 85.8%; top: 89%; animation-name: b7; -webkit-animation-name: b7; }
+
+@keyframes b1 { 0% { top: 88%; } 44% { top: 0%; } 94% { top: 100%; } 100% { top: 88%; } }
+@-webkit-keyframes b1 { 0% { top: 88%; } 44% { top: 0%; } 94% { top: 100%; } 100% { top: 88%; } }
+
+@keyframes b2 { 0% { top: 76%; } 38% { top: 0%; } 88% { top: 100%; } 100% { top: 76%; } }
+@-webkit-keyframes b2 { 0% { top: 76%; } 38% { top: 0%; } 88% { top: 100%; } 100% { top: 76%; } }
+
+@keyframes b3 { 0% { top: 16%; } 8% { top: 0%; } 58% { top: 100%; } 100% { top: 16%; } }
+@-webkit-keyframes b3 { 0% { top: 16%; } 8% { top: 0%; } 58% { top: 100%; } 100% { top: 16%; } }
+
+@keyframes b4 { 0% { top: 40%; } 20% { top: 0%; } 70% { top: 100%; } 100% { top: 40%; } }
+@-webkit-keyframes b4 { 0% { top: 40%; } 20% { top: 0%; } 70% { top: 100%; } 100% { top: 40%; } }
+
+@keyframes b5 { 0% { top: 26%; } 13% { top: 0%; } 63% { top: 100%; } 100% { top: 26%; } }
+@-webkit-keyframes b5 { 0% { top: 26%; } 13% { top: 0%; } 63% { top: 100%; } 100% { top: 26%; } }
+
+@keyframes b6 { 0% { top: 67%; } 33.5% { top: 0%; } 83% { top: 100%; } 100% { top: 67%; } }
+@-webkit-keyframes b6 { 0% { top: 67%; } 33.5% { top: 0%; } 83% { top: 100%; } 100% { top: 67%; } }
+
+@keyframes b7 { 0% { top: 89%; } 44.5% { top: 0%; } 94.5% { top: 100%; } 100% { top: 89%; } }
+@-webkit-keyframes b7 { 0% { top: 89%; } 44.5% { top: 0%; } 94.5% { top: 100%; } 100% { top: 89%; } }
diff --git a/Covid19ValidatingCovVulIndex/www/dataInfo.md b/Covid19ValidatingCovVulIndex/www/dataInfo.md
new file mode 100644
index 00000000..b517307e
--- /dev/null
+++ b/Covid19ValidatingCovVulIndex/www/dataInfo.md
@@ -0,0 +1,19 @@
+# Data Information #
+
+The following databases were used in this study:
+
+| Database | Name | Country | Type | Years
+|--------|----------|-----|-----|-----|
+| *OptumDoD* | Optum® De-Identified Clinformatic Data Mart Database – Date of Death (DOD) | USA | Claims | 2000-2019 |
+| *AUSOM* | - | Korea | EHR | 1999-2018 |
+| *CCAE* | IBM MarketScan® Commercial Database | USA | Claims | 2000-2019 |
+| *MDCD* | IBM MarketScan® Multi-State Medicaid Database | USA | Claims | 2006-2019 |
+| *MDCR* | IBM MarketScan® Medicare Supplemental Database | USA | Claims | 2000-2019 |
+| *JMDC* | Japan Medical Data Center | Japan | Claims | 2000-2019 |
+| *optumEhr* | Optum® de-identified Electronic Health Record Dataset | USA | EHR | 2006-2019 |
+| *Tufts* | - | USA | EHR | ?-2020 |
+| *SIDIAP* | - | Spain | ? | ?-2020 |
+| *HIRA* | - | Korea | Claims | 2013-2020 |
+
+
+All databases obtained IRB approval or used deidentified data that was considered except from IRB approval.
diff --git a/Covid19ValidatingCovVulIndex/www/favicon.ico b/Covid19ValidatingCovVulIndex/www/favicon.ico
new file mode 100644
index 00000000..849a1fa4
Binary files /dev/null and b/Covid19ValidatingCovVulIndex/www/favicon.ico differ
diff --git a/Covid19ValidatingCovVulIndex/www/logo.png b/Covid19ValidatingCovVulIndex/www/logo.png
new file mode 100644
index 00000000..c6307af6
Binary files /dev/null and b/Covid19ValidatingCovVulIndex/www/logo.png differ
diff --git a/Covid19ValidatingCovVulIndex/www/shinyDescription.md b/Covid19ValidatingCovVulIndex/www/shinyDescription.md
new file mode 100644
index 00000000..73c93db0
--- /dev/null
+++ b/Covid19ValidatingCovVulIndex/www/shinyDescription.md
@@ -0,0 +1,31 @@
+### External validation of the covid-19 vulnerability index patient-level prediction across an international network of observational healthcare data datasets
+
+**Development Status: Under Development**
+
+### Information
+
+This shiny application contains the results of the external validations of a model developed to predict risk of hospitalization with pneumonia in patients with flu or covid-19.
+
+During manuscript development and the subsequent review period, these results are considered under embargo and should not be disclosed without explicit permission and consent from the authors.
+
+Below are links for study-related artifacts that have been made available as part of this study:
+
+**Protocol:** [link](https://github.com/ohdsi-studies/Covid19PredictionStudies/blob/master/CovidVulnerabilityIndex/docs/PLP_protocol_cvi_20200416.docx)
+
+### Abstract
+
+Below is the abstract of the manuscript that summarizes the findings:
+
+**Background:** The COVID-19 illness is straining healthcare systems globally. Evidence based medicine that can be used to discriminate between COVID-19 patients requiring hospitalization and those who do not are need to reduce the likelihood that hospitals reach capacity during the pandemic. The COVID-19 vulnerability index, a model that predict which patients with pneumonia require hospitalization, has been developed and proposed as a tool for decision making during the COVID-19 outbreak. However, the model has not been extensively externally validated.
+
+**Methods:** We translated the model so it could be implemented on any data in the Observational Medical Outcome Partnership (OMOP) common data model format. We implemented the model on patients at the point they have COVID-19/Flu or related symptoms during an outpatient visit to predict their risk of hospitalization with pneumonia during the following 0 to 30 days. We then validated the model across a network of N databases spanning the US, Europe and Asia. The validation included non-COVID-19 datasets in addition to COVID-19 datasets.
+
+**Findings:** The internal validation performance of the COVID-19 vulnerability index on non-COVID-19 patients was 0.xx. When externally validated on N non-COVID-19 patients across the OHDSI network the AUC ranged between 0.xx-0.xx. Transported to COVID-19 data the model obtained AUCs of 0.xx, 0.xx and 0.xx on A,B and C datasets respectively. The calibration …
+
+**Interpretation:** The results show that the discriminative performance of the model was lower than the reported internal validation performance across non-COVID-19 data and [add COVID-19 summary]. The calibration results mean [add]. We therefore [do/do not] recommend using this model [causously] as a means to identify which COVID-19 patients should be hospitalized.
+
+### Study Packages
+
+- Model validation: [link](https://github.com/ohdsi-studies/Covid19PredictionStudies/tree/master/CovidVulnerabilityIndex)
+
+The Observational Health Data Sciences and Informatics (OHDSI) international community is hosting a COVID-19 virtual study-a-thon this week (March 26-29) to inform healthcare decision-making in response to the current global pandemic. The preliminary research results on this web-based application are from a retrospective, real-world, observational study in support of this activity and will subsequently be submitted to a peer-reviewed, scientific journal.
\ No newline at end of file