diff --git a/Covid19PredictingHospitalizationInFluPatients/PLPViewer.Rproj b/Covid19PredictingHospitalizationInFluPatients/PLPViewer.Rproj new file mode 100644 index 00000000..8e3c2ebc --- /dev/null +++ b/Covid19PredictingHospitalizationInFluPatients/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/Covid19PredictingHospitalizationInFluPatients/data/Analysis_1/plpLog.txt b/Covid19PredictingHospitalizationInFluPatients/data/Analysis_1/plpLog.txt new file mode 100644 index 00000000..7b8e32a1 --- /dev/null +++ b/Covid19PredictingHospitalizationInFluPatients/data/Analysis_1/plpLog.txt @@ -0,0 +1,40 @@ +2020-03-28 23:07:48 [Main thread] INFO PatientLevelPrediction Patient-Level Prediction Package version 3.0.15 +2020-03-28 23:07:48 [Main thread] INFO PatientLevelPrediction AnalysisID: Analysis_1 +2020-03-28 23:07:48 [Main thread] INFO PatientLevelPrediction CohortID: 5894 +2020-03-28 23:07:48 [Main thread] INFO PatientLevelPrediction OutcomeID: 5892 +2020-03-28 23:07:48 [Main thread] INFO PatientLevelPrediction Cohort size: 150000 +2020-03-28 23:07:48 [Main thread] INFO PatientLevelPrediction Covariates: 31917 +2020-03-28 23:07:48 [Main thread] INFO PatientLevelPrediction Population size: 150000 +2020-03-28 23:07:48 [Main thread] INFO PatientLevelPrediction Cases: 6712 +2020-03-28 23:07:48 [Main thread] INFO PatientLevelPrediction splitSeed: 6118764 +2020-03-28 23:07:48 [Main thread] WARN PatientLevelPrediction personSplitter This function is deprecated. Use 'randomSplitter' instead. +2020-03-28 23:07:48 [Main thread] INFO PatientLevelPrediction randomSplitter Creating a 25% test and 75% train (into 3 folds) random stratified split by class +2020-03-28 23:07:49 [Main thread] INFO PatientLevelPrediction randomSplitter Data split into 37500 test cases and 112500 train cases (37500, 37500, 37500) +2020-03-28 23:07:49 [Main thread] INFO PatientLevelPrediction Training Lasso Logistic Regression model +2020-03-28 23:08:34 [Main thread] INFO PatientLevelPrediction fitGLMModel Running Cyclops +2020-03-28 23:13:04 [Main thread] INFO PatientLevelPrediction fitGLMModel Done. +2020-03-28 23:13:04 [Main thread] INFO PatientLevelPrediction fitGLMModel GLM fit status: OK +2020-03-28 23:13:04 [Main thread] INFO PatientLevelPrediction fitGLMModel Fitting model took 4.75 mins +2020-03-28 23:13:04 [Main thread] INFO PatientLevelPrediction fitLassoLogisticRegression Creating variable importance data frame +2020-03-28 23:13:04 [Main thread] INFO PatientLevelPrediction fitLassoLogisticRegression Getting predictions on train set +2020-03-28 23:13:15 [Main thread] INFO PatientLevelPrediction predictProbabilities Prediction took 4.52 secs +2020-03-28 23:13:27 [Main thread] INFO PatientLevelPrediction predictProbabilities Prediction took 1.41 secs +2020-03-28 23:13:27 [Main thread] INFO PatientLevelPrediction Train set evaluation +2020-03-28 23:13:28 [Main thread] INFO PatientLevelPrediction evaluatePlp AUC: 87.34 +2020-03-28 23:13:28 [Main thread] INFO PatientLevelPrediction evaluatePlp AUPRC: 26.61 +2020-03-28 23:13:28 [Main thread] INFO PatientLevelPrediction evaluatePlp Brier: 0.04 +2020-03-28 23:13:38 [Main thread] INFO PatientLevelPrediction evaluatePlp Calibration gradient: 1.08 intercept: -0.00 +2020-03-28 23:13:41 [Main thread] INFO PatientLevelPrediction evaluatePlp Average Precision: 0.27 +2020-03-28 23:13:41 [Main thread] INFO PatientLevelPrediction Test set evaluation +2020-03-28 23:13:41 [Main thread] INFO PatientLevelPrediction evaluatePlp AUC: 85.22 +2020-03-28 23:13:41 [Main thread] INFO PatientLevelPrediction evaluatePlp AUPRC: 22.36 +2020-03-28 23:13:41 [Main thread] INFO PatientLevelPrediction evaluatePlp Brier: 0.04 +2020-03-28 23:13:48 [Main thread] INFO PatientLevelPrediction evaluatePlp Calibration gradient: 0.95 intercept: 0.00 +2020-03-28 23:13:49 [Main thread] INFO PatientLevelPrediction evaluatePlp Average Precision: 0.22 +2020-03-28 23:13:49 [Main thread] INFO PatientLevelPrediction Calculating covariate summary @ 2020-03-28 23:13:49 +2020-03-28 23:13:49 [Main thread] INFO PatientLevelPrediction This can take a while... +2020-03-28 23:14:59 [Main thread] INFO PatientLevelPrediction Finished covariate summary @ 2020-03-28 23:14:59 +2020-03-28 23:14:59 [Main thread] INFO PatientLevelPrediction Saving PlpResult +2020-03-28 23:15:02 [Main thread] INFO PatientLevelPrediction plpResult saved to ..\T:/covid19Studies/covid19Results/HospitalizationInSymptomaticPatientsResults/optumDod/Analysis_1\plpResult +2020-03-28 23:15:02 [Main thread] INFO PatientLevelPrediction Log saved to T:/covid19Studies/covid19Results/HospitalizationInSymptomaticPatientsResults/optumDod/Analysis_1/plplog.txt +2020-03-28 23:15:02 [Main thread] INFO PatientLevelPrediction Run finished successfully. diff --git a/Covid19PredictingHospitalizationInFluPatients/data/Analysis_1/plpResult.rds b/Covid19PredictingHospitalizationInFluPatients/data/Analysis_1/plpResult.rds new file mode 100644 index 00000000..b326e455 Binary files /dev/null and b/Covid19PredictingHospitalizationInFluPatients/data/Analysis_1/plpResult.rds differ diff --git a/Covid19PredictingHospitalizationInFluPatients/data/Analysis_2/plpLog.txt b/Covid19PredictingHospitalizationInFluPatients/data/Analysis_2/plpLog.txt new file mode 100644 index 00000000..d1551b00 --- /dev/null +++ b/Covid19PredictingHospitalizationInFluPatients/data/Analysis_2/plpLog.txt @@ -0,0 +1,40 @@ +2020-03-28 23:16:22 [Main thread] INFO PatientLevelPrediction Patient-Level Prediction Package version 3.0.15 +2020-03-28 23:16:22 [Main thread] INFO PatientLevelPrediction AnalysisID: Analysis_2 +2020-03-28 23:16:22 [Main thread] INFO PatientLevelPrediction CohortID: 5894 +2020-03-28 23:16:22 [Main thread] INFO PatientLevelPrediction OutcomeID: 5893 +2020-03-28 23:16:22 [Main thread] INFO PatientLevelPrediction Cohort size: 150000 +2020-03-28 23:16:22 [Main thread] INFO PatientLevelPrediction Covariates: 31917 +2020-03-28 23:16:22 [Main thread] INFO PatientLevelPrediction Population size: 150000 +2020-03-28 23:16:22 [Main thread] INFO PatientLevelPrediction Cases: 10468 +2020-03-28 23:16:22 [Main thread] INFO PatientLevelPrediction splitSeed: -5092062 +2020-03-28 23:16:22 [Main thread] WARN PatientLevelPrediction personSplitter This function is deprecated. Use 'randomSplitter' instead. +2020-03-28 23:16:22 [Main thread] INFO PatientLevelPrediction randomSplitter Creating a 25% test and 75% train (into 3 folds) random stratified split by class +2020-03-28 23:16:23 [Main thread] INFO PatientLevelPrediction randomSplitter Data split into 37500 test cases and 112500 train cases (37500, 37500, 37500) +2020-03-28 23:16:23 [Main thread] INFO PatientLevelPrediction Training Lasso Logistic Regression model +2020-03-28 23:17:08 [Main thread] INFO PatientLevelPrediction fitGLMModel Running Cyclops +2020-03-28 23:21:15 [Main thread] INFO PatientLevelPrediction fitGLMModel Done. +2020-03-28 23:21:15 [Main thread] INFO PatientLevelPrediction fitGLMModel GLM fit status: OK +2020-03-28 23:21:15 [Main thread] INFO PatientLevelPrediction fitGLMModel Fitting model took 4.37 mins +2020-03-28 23:21:15 [Main thread] INFO PatientLevelPrediction fitLassoLogisticRegression Creating variable importance data frame +2020-03-28 23:21:15 [Main thread] INFO PatientLevelPrediction fitLassoLogisticRegression Getting predictions on train set +2020-03-28 23:21:26 [Main thread] INFO PatientLevelPrediction predictProbabilities Prediction took 5.13 secs +2020-03-28 23:21:38 [Main thread] INFO PatientLevelPrediction predictProbabilities Prediction took 1.55 secs +2020-03-28 23:21:38 [Main thread] INFO PatientLevelPrediction Train set evaluation +2020-03-28 23:21:39 [Main thread] INFO PatientLevelPrediction evaluatePlp AUC: 88.92 +2020-03-28 23:21:39 [Main thread] INFO PatientLevelPrediction evaluatePlp AUPRC: 40.81 +2020-03-28 23:21:39 [Main thread] INFO PatientLevelPrediction evaluatePlp Brier: 0.05 +2020-03-28 23:21:49 [Main thread] INFO PatientLevelPrediction evaluatePlp Calibration gradient: 1.06 intercept: -0.00 +2020-03-28 23:21:51 [Main thread] INFO PatientLevelPrediction evaluatePlp Average Precision: 0.41 +2020-03-28 23:21:51 [Main thread] INFO PatientLevelPrediction Test set evaluation +2020-03-28 23:21:52 [Main thread] INFO PatientLevelPrediction evaluatePlp AUC: 87.21 +2020-03-28 23:21:52 [Main thread] INFO PatientLevelPrediction evaluatePlp AUPRC: 35.42 +2020-03-28 23:21:52 [Main thread] INFO PatientLevelPrediction evaluatePlp Brier: 0.05 +2020-03-28 23:21:59 [Main thread] INFO PatientLevelPrediction evaluatePlp Calibration gradient: 0.96 intercept: 0.00 +2020-03-28 23:22:00 [Main thread] INFO PatientLevelPrediction evaluatePlp Average Precision: 0.35 +2020-03-28 23:22:00 [Main thread] INFO PatientLevelPrediction Calculating covariate summary @ 2020-03-28 23:22:00 +2020-03-28 23:22:00 [Main thread] INFO PatientLevelPrediction This can take a while... +2020-03-28 23:23:03 [Main thread] INFO PatientLevelPrediction Finished covariate summary @ 2020-03-28 23:23:03 +2020-03-28 23:23:03 [Main thread] INFO PatientLevelPrediction Saving PlpResult +2020-03-28 23:23:05 [Main thread] INFO PatientLevelPrediction plpResult saved to ..\T:/covid19Studies/covid19Results/HospitalizationInSymptomaticPatientsResults/optumDod/Analysis_2\plpResult +2020-03-28 23:23:05 [Main thread] INFO PatientLevelPrediction Log saved to T:/covid19Studies/covid19Results/HospitalizationInSymptomaticPatientsResults/optumDod/Analysis_2/plplog.txt +2020-03-28 23:23:05 [Main thread] INFO PatientLevelPrediction Run finished successfully. diff --git a/Covid19PredictingHospitalizationInFluPatients/data/Analysis_2/plpResult.rds b/Covid19PredictingHospitalizationInFluPatients/data/Analysis_2/plpResult.rds new file mode 100644 index 00000000..ffcdeaa3 Binary files /dev/null and b/Covid19PredictingHospitalizationInFluPatients/data/Analysis_2/plpResult.rds differ diff --git a/Covid19PredictingHospitalizationInFluPatients/data/Analysis_3/plpLog.txt b/Covid19PredictingHospitalizationInFluPatients/data/Analysis_3/plpLog.txt new file mode 100644 index 00000000..dee24c17 --- /dev/null +++ b/Covid19PredictingHospitalizationInFluPatients/data/Analysis_3/plpLog.txt @@ -0,0 +1,40 @@ +2020-03-28 23:16:00 [Main thread] INFO PatientLevelPrediction Patient-Level Prediction Package version 3.0.15 +2020-03-28 23:16:00 [Main thread] INFO PatientLevelPrediction AnalysisID: Analysis_3 +2020-03-28 23:16:00 [Main thread] INFO PatientLevelPrediction CohortID: 5894 +2020-03-28 23:16:00 [Main thread] INFO PatientLevelPrediction OutcomeID: 5892 +2020-03-28 23:16:00 [Main thread] INFO PatientLevelPrediction Cohort size: 150000 +2020-03-28 23:16:00 [Main thread] INFO PatientLevelPrediction Covariates: 18 +2020-03-28 23:16:00 [Main thread] INFO PatientLevelPrediction Population size: 150000 +2020-03-28 23:16:00 [Main thread] INFO PatientLevelPrediction Cases: 6712 +2020-03-28 23:16:00 [Main thread] INFO PatientLevelPrediction splitSeed: 1710568 +2020-03-28 23:16:00 [Main thread] WARN PatientLevelPrediction personSplitter This function is deprecated. Use 'randomSplitter' instead. +2020-03-28 23:16:00 [Main thread] INFO PatientLevelPrediction randomSplitter Creating a 25% test and 75% train (into 3 folds) random stratified split by class +2020-03-28 23:16:01 [Main thread] INFO PatientLevelPrediction randomSplitter Data split into 37500 test cases and 112500 train cases (37500, 37500, 37500) +2020-03-28 23:16:01 [Main thread] INFO PatientLevelPrediction Training Lasso Logistic Regression model +2020-03-28 23:16:02 [Main thread] INFO PatientLevelPrediction fitGLMModel Running Cyclops +2020-03-28 23:16:08 [Main thread] INFO PatientLevelPrediction fitGLMModel Done. +2020-03-28 23:16:08 [Main thread] INFO PatientLevelPrediction fitGLMModel GLM fit status: OK +2020-03-28 23:16:08 [Main thread] INFO PatientLevelPrediction fitGLMModel Fitting model took 6.82 secs +2020-03-28 23:16:08 [Main thread] INFO PatientLevelPrediction fitLassoLogisticRegression Creating variable importance data frame +2020-03-28 23:16:08 [Main thread] INFO PatientLevelPrediction fitLassoLogisticRegression Getting predictions on train set +2020-03-28 23:16:09 [Main thread] INFO PatientLevelPrediction predictProbabilities Prediction took 0.493 secs +2020-03-28 23:16:09 [Main thread] INFO PatientLevelPrediction predictProbabilities Prediction took 0.17 secs +2020-03-28 23:16:09 [Main thread] INFO PatientLevelPrediction Train set evaluation +2020-03-28 23:16:10 [Main thread] INFO PatientLevelPrediction evaluatePlp AUC: 55.61 +2020-03-28 23:16:10 [Main thread] INFO PatientLevelPrediction evaluatePlp AUPRC: 5.63 +2020-03-28 23:16:10 [Main thread] INFO PatientLevelPrediction evaluatePlp Brier: 0.04 +2020-03-28 23:16:13 [Main thread] INFO PatientLevelPrediction evaluatePlp Calibration gradient: 1.02 intercept: -0.00 +2020-03-28 23:16:15 [Main thread] INFO PatientLevelPrediction evaluatePlp Average Precision: 0.06 +2020-03-28 23:16:15 [Main thread] INFO PatientLevelPrediction Test set evaluation +2020-03-28 23:16:15 [Main thread] INFO PatientLevelPrediction evaluatePlp AUC: 56.71 +2020-03-28 23:16:15 [Main thread] INFO PatientLevelPrediction evaluatePlp AUPRC: 6.19 +2020-03-28 23:16:15 [Main thread] INFO PatientLevelPrediction evaluatePlp Brier: 0.04 +2020-03-28 23:16:17 [Main thread] INFO PatientLevelPrediction evaluatePlp Calibration gradient: 1.37 intercept: -0.02 +2020-03-28 23:16:18 [Main thread] INFO PatientLevelPrediction evaluatePlp Average Precision: 0.06 +2020-03-28 23:16:18 [Main thread] INFO PatientLevelPrediction Calculating covariate summary @ 2020-03-28 23:16:18 +2020-03-28 23:16:18 [Main thread] INFO PatientLevelPrediction This can take a while... +2020-03-28 23:16:19 [Main thread] INFO PatientLevelPrediction Finished covariate summary @ 2020-03-28 23:16:19 +2020-03-28 23:16:19 [Main thread] INFO PatientLevelPrediction Saving PlpResult +2020-03-28 23:16:20 [Main thread] INFO PatientLevelPrediction plpResult saved to ..\T:/covid19Studies/covid19Results/HospitalizationInSymptomaticPatientsResults/optumDod/Analysis_3\plpResult +2020-03-28 23:16:20 [Main thread] INFO PatientLevelPrediction Log saved to T:/covid19Studies/covid19Results/HospitalizationInSymptomaticPatientsResults/optumDod/Analysis_3/plplog.txt +2020-03-28 23:16:20 [Main thread] INFO PatientLevelPrediction Run finished successfully. diff --git a/Covid19PredictingHospitalizationInFluPatients/data/Analysis_3/plpResult.rds b/Covid19PredictingHospitalizationInFluPatients/data/Analysis_3/plpResult.rds new file mode 100644 index 00000000..a393d607 Binary files /dev/null and b/Covid19PredictingHospitalizationInFluPatients/data/Analysis_3/plpResult.rds differ diff --git a/Covid19PredictingHospitalizationInFluPatients/data/Analysis_4/plpLog.txt b/Covid19PredictingHospitalizationInFluPatients/data/Analysis_4/plpLog.txt new file mode 100644 index 00000000..266ea5de --- /dev/null +++ b/Covid19PredictingHospitalizationInFluPatients/data/Analysis_4/plpLog.txt @@ -0,0 +1,40 @@ +2020-03-28 23:23:05 [Main thread] INFO PatientLevelPrediction Patient-Level Prediction Package version 3.0.15 +2020-03-28 23:23:05 [Main thread] INFO PatientLevelPrediction AnalysisID: Analysis_4 +2020-03-28 23:23:05 [Main thread] INFO PatientLevelPrediction CohortID: 5894 +2020-03-28 23:23:05 [Main thread] INFO PatientLevelPrediction OutcomeID: 5893 +2020-03-28 23:23:05 [Main thread] INFO PatientLevelPrediction Cohort size: 150000 +2020-03-28 23:23:05 [Main thread] INFO PatientLevelPrediction Covariates: 18 +2020-03-28 23:23:05 [Main thread] INFO PatientLevelPrediction Population size: 150000 +2020-03-28 23:23:05 [Main thread] INFO PatientLevelPrediction Cases: 10468 +2020-03-28 23:23:05 [Main thread] INFO PatientLevelPrediction splitSeed: -7970845 +2020-03-28 23:23:05 [Main thread] WARN PatientLevelPrediction personSplitter This function is deprecated. Use 'randomSplitter' instead. +2020-03-28 23:23:05 [Main thread] INFO PatientLevelPrediction randomSplitter Creating a 25% test and 75% train (into 3 folds) random stratified split by class +2020-03-28 23:23:06 [Main thread] INFO PatientLevelPrediction randomSplitter Data split into 37500 test cases and 112500 train cases (37500, 37500, 37500) +2020-03-28 23:23:06 [Main thread] INFO PatientLevelPrediction Training Lasso Logistic Regression model +2020-03-28 23:23:07 [Main thread] INFO PatientLevelPrediction fitGLMModel Running Cyclops +2020-03-28 23:23:10 [Main thread] INFO PatientLevelPrediction fitGLMModel Done. +2020-03-28 23:23:10 [Main thread] INFO PatientLevelPrediction fitGLMModel GLM fit status: OK +2020-03-28 23:23:10 [Main thread] INFO PatientLevelPrediction fitGLMModel Fitting model took 4.02 secs +2020-03-28 23:23:10 [Main thread] INFO PatientLevelPrediction fitLassoLogisticRegression Creating variable importance data frame +2020-03-28 23:23:10 [Main thread] INFO PatientLevelPrediction fitLassoLogisticRegression Getting predictions on train set +2020-03-28 23:23:11 [Main thread] INFO PatientLevelPrediction predictProbabilities Prediction took 0.476 secs +2020-03-28 23:23:12 [Main thread] INFO PatientLevelPrediction predictProbabilities Prediction took 0.17 secs +2020-03-28 23:23:12 [Main thread] INFO PatientLevelPrediction Train set evaluation +2020-03-28 23:23:12 [Main thread] INFO PatientLevelPrediction evaluatePlp AUC: 56.29 +2020-03-28 23:23:12 [Main thread] INFO PatientLevelPrediction evaluatePlp AUPRC: 9.01 +2020-03-28 23:23:12 [Main thread] INFO PatientLevelPrediction evaluatePlp Brier: 0.06 +2020-03-28 23:23:15 [Main thread] INFO PatientLevelPrediction evaluatePlp Calibration gradient: 1.06 intercept: -0.00 +2020-03-28 23:23:18 [Main thread] INFO PatientLevelPrediction evaluatePlp Average Precision: 0.09 +2020-03-28 23:23:18 [Main thread] INFO PatientLevelPrediction Test set evaluation +2020-03-28 23:23:18 [Main thread] INFO PatientLevelPrediction evaluatePlp AUC: 55.16 +2020-03-28 23:23:18 [Main thread] INFO PatientLevelPrediction evaluatePlp AUPRC: 8.78 +2020-03-28 23:23:18 [Main thread] INFO PatientLevelPrediction evaluatePlp Brier: 0.06 +2020-03-28 23:23:19 [Main thread] INFO PatientLevelPrediction evaluatePlp Calibration gradient: 0.95 intercept: 0.00 +2020-03-28 23:23:20 [Main thread] INFO PatientLevelPrediction evaluatePlp Average Precision: 0.09 +2020-03-28 23:23:20 [Main thread] INFO PatientLevelPrediction Calculating covariate summary @ 2020-03-28 23:23:20 +2020-03-28 23:23:20 [Main thread] INFO PatientLevelPrediction This can take a while... +2020-03-28 23:23:21 [Main thread] INFO PatientLevelPrediction Finished covariate summary @ 2020-03-28 23:23:21 +2020-03-28 23:23:21 [Main thread] INFO PatientLevelPrediction Saving PlpResult +2020-03-28 23:23:22 [Main thread] INFO PatientLevelPrediction plpResult saved to ..\T:/covid19Studies/covid19Results/HospitalizationInSymptomaticPatientsResults/optumDod/Analysis_4\plpResult +2020-03-28 23:23:22 [Main thread] INFO PatientLevelPrediction Log saved to T:/covid19Studies/covid19Results/HospitalizationInSymptomaticPatientsResults/optumDod/Analysis_4/plplog.txt +2020-03-28 23:23:22 [Main thread] INFO PatientLevelPrediction Run finished successfully. diff --git a/Covid19PredictingHospitalizationInFluPatients/data/Analysis_4/plpResult.rds b/Covid19PredictingHospitalizationInFluPatients/data/Analysis_4/plpResult.rds new file mode 100644 index 00000000..cb026c10 Binary files /dev/null and b/Covid19PredictingHospitalizationInFluPatients/data/Analysis_4/plpResult.rds differ diff --git a/Covid19PredictingHospitalizationInFluPatients/data/settings.csv b/Covid19PredictingHospitalizationInFluPatients/data/settings.csv new file mode 100644 index 00000000..2d330ecf --- /dev/null +++ b/Covid19PredictingHospitalizationInFluPatients/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" +5892,5894,1,1,"optumDod",1,1,1,"Lasso Logistic Regression",0,0,0,30,"T:/covid19Studies/covid19Results/HospitalizationInSymptomaticPatientsResults/optumDod/PlpData_L1_T5894","T:/covid19Studies/covid19Results/HospitalizationInSymptomaticPatientsResults/optumDod/StudyPop_L1_T5894_O5892.rds","T:/covid19Studies/covid19Results/HospitalizationInSymptomaticPatientsResults/optumDod/Analysis_1","[COVID ID13 v1] GP/OP/ER visits of patients presenting with Covid flu or flu-like symptoms AND no symptoms or pneumonia in prior 60d","[COVID19 ID25 V1] Hospitalizations with pneumonia" +5892,5894,2,3,"optumDod",1,1,2,"Lasso Logistic Regression",0,0,0,30,"T:/covid19Studies/covid19Results/HospitalizationInSymptomaticPatientsResults/optumDod/PlpData_L2_T5894","T:/covid19Studies/covid19Results/HospitalizationInSymptomaticPatientsResults/optumDod/StudyPop_L1_T5894_O5892.rds","T:/covid19Studies/covid19Results/HospitalizationInSymptomaticPatientsResults/optumDod/Analysis_3","[COVID ID13 v1] GP/OP/ER visits of patients presenting with Covid flu or flu-like symptoms AND no symptoms or pneumonia in prior 60d","[COVID19 ID25 V1] Hospitalizations with pneumonia" +5893,5894,1,2,"optumDod",1,1,1,"Lasso Logistic Regression",0,0,0,30,"T:/covid19Studies/covid19Results/HospitalizationInSymptomaticPatientsResults/optumDod/PlpData_L1_T5894","T:/covid19Studies/covid19Results/HospitalizationInSymptomaticPatientsResults/optumDod/StudyPop_L1_T5894_O5893.rds","T:/covid19Studies/covid19Results/HospitalizationInSymptomaticPatientsResults/optumDod/Analysis_2","[COVID ID13 v1] GP/OP/ER visits of patients presenting with Covid flu or flu-like symptoms AND no symptoms or pneumonia in prior 60d","[COVID19 ID26 V1] Hospitalizations with pneumonia or ARDS or sepsis or AKI" +5893,5894,2,4,"optumDod",1,1,2,"Lasso Logistic Regression",0,0,0,30,"T:/covid19Studies/covid19Results/HospitalizationInSymptomaticPatientsResults/optumDod/PlpData_L2_T5894","T:/covid19Studies/covid19Results/HospitalizationInSymptomaticPatientsResults/optumDod/StudyPop_L1_T5894_O5893.rds","T:/covid19Studies/covid19Results/HospitalizationInSymptomaticPatientsResults/optumDod/Analysis_4","[COVID ID13 v1] GP/OP/ER visits of patients presenting with Covid flu or flu-like symptoms AND no symptoms or pneumonia in prior 60d","[COVID19 ID26 V1] Hospitalizations with pneumonia or ARDS or sepsis or AKI" diff --git a/Covid19PredictingHospitalizationInFluPatients/global.R b/Covid19PredictingHospitalizationInFluPatients/global.R new file mode 100644 index 00000000..b38e6714 --- /dev/null +++ b/Covid19PredictingHospitalizationInFluPatients/global.R @@ -0,0 +1,29 @@ +# 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/Covid19PredictingHospitalizationInFluPatients/helpers.R b/Covid19PredictingHospitalizationInFluPatients/helpers.R new file mode 100644 index 00000000..6c1feebc --- /dev/null +++ b/Covid19PredictingHospitalizationInFluPatients/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/Covid19PredictingHospitalizationInFluPatients/plots.R b/Covid19PredictingHospitalizationInFluPatients/plots.R new file mode 100644 index 00000000..cd791438 --- /dev/null +++ b/Covid19PredictingHospitalizationInFluPatients/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/Covid19PredictingHospitalizationInFluPatients/processing.R b/Covid19PredictingHospitalizationInFluPatients/processing.R new file mode 100644 index 00000000..c6622603 --- /dev/null +++ b/Covid19PredictingHospitalizationInFluPatients/processing.R @@ -0,0 +1,221 @@ + +# 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) + } + + 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') + + 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')] + 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/Covid19PredictingHospitalizationInFluPatients/server.R b/Covid19PredictingHospitalizationInFluPatients/server.R new file mode 100644 index 00000000..11c55141 --- /dev/null +++ b/Covid19PredictingHospitalizationInFluPatients/server.R @@ -0,0 +1,270 @@ +# @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')) + + 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" + ) + }) + +}) \ No newline at end of file diff --git a/Covid19PredictingHospitalizationInFluPatients/ui.R b/Covid19PredictingHospitalizationInFluPatients/ui.R new file mode 100644 index 00000000..6c2989fb --- /dev/null +++ b/Covid19PredictingHospitalizationInFluPatients/ui.R @@ -0,0 +1,241 @@ +# @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) + +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( + shinydashboard::menuItem("Summary", tabName = "Summary", icon = shiny::icon("table")), + shinydashboard::menuItem("Performance", tabName = "Performance", icon = shiny::icon("bar-chart")), + shinydashboard::menuItem("Model", tabName = "Model", icon = shiny::icon("clipboard")), + shinydashboard::menuItem("Log", tabName = "Log", icon = shiny::icon("list")), + shinydashboard::menuItem("Help", tabName = "Help", icon = shiny::icon("info")) + ) + ), + + 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 = "Summary", + + shiny::fluidRow( + shiny::column(2, + shiny::h4('Filters'), + 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::selectInput('modelSettingName', 'Model:', c('All',unique(as.character(summaryTable$Model)))) + ), + 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 = "ROC Plot", solidHeader = TRUE, + shinycssloaders::withSpinner(plotly::plotlyOutput('roc'))), + shinydashboard::box(status = 'info', + title = "Precision recall plot", solidHeader = TRUE, + side = "right", + shinycssloaders::withSpinner(plotly::plotlyOutput('pr')))), + + shiny::fluidRow( + shinydashboard::box(status = 'info', + title = "F1 Score Plot", solidHeader = TRUE, + shinycssloaders::withSpinner(plotly::plotlyOutput('f1'))), + shinydashboard::box(status = 'info', + title = "Box Plot", solidHeader = TRUE, + side = "right", + shinycssloaders::withSpinner(shiny::plotOutput('box')))), + + shiny::fluidRow( + shinydashboard::box(status = 'info', + title = "Prediction Score Distribution", solidHeader = TRUE, + shinycssloaders::withSpinner(shiny::plotOutput('preddist'))), + shinydashboard::box(status = 'info', + title = "Preference Score Distribution", solidHeader = TRUE, + side = "right", + shinycssloaders::withSpinner(shiny::plotOutput('prefdist')))) + + + ), + tabPanel("Calibration", + shiny::fluidRow( + shinydashboard::box(status = 'info', + title = "Calibration Plot", solidHeader = TRUE, + shinycssloaders::withSpinner(shiny::plotOutput('cal'))), + shinydashboard::box(status = 'info', + title = "Demographic Plot", 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/Covid19PredictingHospitalizationInFluPatients/www/about.png b/Covid19PredictingHospitalizationInFluPatients/www/about.png new file mode 100644 index 00000000..878a509e Binary files /dev/null and b/Covid19PredictingHospitalizationInFluPatients/www/about.png differ diff --git a/Covid19PredictingHospitalizationInFluPatients/www/custom.css b/Covid19PredictingHospitalizationInFluPatients/www/custom.css new file mode 100644 index 00000000..26730bbd --- /dev/null +++ b/Covid19PredictingHospitalizationInFluPatients/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/Covid19PredictingHospitalizationInFluPatients/www/favicon.ico b/Covid19PredictingHospitalizationInFluPatients/www/favicon.ico new file mode 100644 index 00000000..849a1fa4 Binary files /dev/null and b/Covid19PredictingHospitalizationInFluPatients/www/favicon.ico differ diff --git a/Covid19PredictingHospitalizationInFluPatients/www/logo.png b/Covid19PredictingHospitalizationInFluPatients/www/logo.png new file mode 100644 index 00000000..c6307af6 Binary files /dev/null and b/Covid19PredictingHospitalizationInFluPatients/www/logo.png differ