#open data #data is the 1781 patients for internal validation #datab is 1781 's lab variables (blood test +CRP) #data_waibu_qianbanjie is the 210 patients for external validation #load packages library(glmnet) library(ggplot2) library(corrplot) library(gridExtra) library(caret) library(pROC) library(xgboost) library(ada) library(ROCR) library(shiny) library(shapviz) library(car) library(DALEX) library(reshape2) library(klaR) library(gbm) library(readxl) library(dcurves) library(catboost)# this package only on github, not the r-cran library(dplyr) library(compareGroups) library(poLCA) library(tidyr) library(forestplot) library(boot) library(mclust) library(rms) library(PredictABEL) library(patchwork) # group compare in 1781 data_jx<-data.frame(data) # data_jx for compare str(data_jx) data_jx$feiyan<-as.factor(data_jx$feiyan) # pneumonia data_jx$sex<-as.factor(data_jx$sex) # sex data_jx$yongyaoshi<-as.factor(data_jx$yongyaoshi) # medication history data_jx$jierezhentong<-as.factor(data_jx$jierezhentong) # used antipyretics data_jx$kangshengsu<-as.factor(data_jx$kangshengsu) # used antibiotics data_jx$kangbingdu<-as.factor(data_jx$kangbingdu) # used antivirals data_jx$xuanfeijiebiao<-as.factor(data_jx$xuanfeijiebiao) # TCM_XFJB data_jx$xierejiedu<-as.factor(data_jx$xierejiedu) # TCM_XRJD data_jx$wenlisanhan<-as.factor(data_jx$wenlisanhan) # TCM_WLSH data_jx$fare<-as.factor(data_jx$fare) # heat_feeling data_jx$wuhan<-as.factor(data_jx$wuhan) # cold_feeling data_jx$toushentong<-as.factor(data_jx$toushentong) # headache and body pain data_jx$xiongtong<-as.factor(data_jx$xiongtong) # chest pain data_jx$futong<-as.factor(data_jx$futong) # abdominal pain data_jx$biseliuti<-as.factor(data_jx$biseliuti) # nasal congestion data_jx$yanbubushi<-as.factor(data_jx$yanbubushi) # pharyngeal discomfort data_jx$kesou<-as.factor(data_jx$kesou) # cough data_jx$qichuan<-as.factor(data_jx$qichuan) # dyspnea data_jx$xiongmen<-as.factor(data_jx$xiongmen) # chest tightness data_jx$exinoutu<-as.factor(data_jx$exinoutu) # nausea and vomiting data_jx$fuxie<-as.factor(data_jx$fuxie) # diarrhea data_jx$fali<-as.factor(data_jx$fali) # fatigue data_jx$nacha<-as.factor(data_jx$nacha) # poor appetite data_jx$shenzhiyichang<-as.factor(data_jx$shenzhiyichang) # altered mental status data_jx$xinxueguan<-as.factor(data_jx$xinxueguan) # cardiovascular disease data_jx$huxi<-as.factor(data_jx$huxi) # respiratory disease data_jx$shenjing<-as.factor(data_jx$shenjing) # neurological disease data_jx$neifenmi<-as.factor(data_jx$neifenmi) # endocrine disease data_jx$shenzang<-as.factor(data_jx$shenzang) # kidney disease data_jx$xueye<-as.factor(data_jx$xueye) # blood disorders data_jx$zhongliumianyi<-as.factor(data_jx$zhongliumianyi) # oncological or immune diseases str(data_jx) compareGroups(feiyan~.,data=data_jx) compareGroups(feiyan~., data=data_jx, method = c(chol=NA), alpha= (0.05/40))# adjust p to 0.05/40~0.001 jxbiao<-compareGroups(feiyan~., data=data_jx, method = c(chol=NA), alpha= (0.05/40)) jxtable<-createTable(jxbiao,show.ratio=TRUE) print(jxtable,which.table="descr") #days,age,tmax,pharyngeal discomfort,cough,dyspnea,altered mental status has meaningful p value forest_dataor <- data.frame( Variable = c("days", "sex", "age", "tmax", "medication history", "used antipyretics", "used antibiotics", "used antivirals","TCM_xuanfeijiebiao", "TCM_xierejiedu","TCM_wenlisanhan", "heat feeling","cold feeling", "headache and body pain","chest pain", "abdominal pain","nasal congestion", "pharyngeal discomfort","cough","dyspnea", "chest tightness","nausea and vomiting", "diarrhea","fatigue","poor appetite", "altered mental status","cardiovascular disease", "respiratory disease","neurological disease", "endocrine disease","kidney disease", "blood disorders","oncological or immune diseases", "NEU","LYM","PLT","CRP","NLR","CRP/PLT"), OR = c(1.04,1.12,1.06,1.47,0.97,0.84,0.94, 2.68,0.74,0.88,1,0.83,1.01, 0.49,3.92,3.41,0.64,0.27,1.73,4.56, 1.18,1.74,2.01,0.80,1,14.4,1.38, 1.83,1.36,1.34,0.96,1.52,1.10, 1.14,0.54,1.00,1.02,1.09,28.7), # or Lower_CI = c(1.02,0.89,1.05,1.24,0.76,0.65,0.70, 0.31,0.57,0.64,1,0.59,0.68, 0.29,0.10,1.07,0.33,0.18,1.27,2.33, 0.16,0.78,0.99,0.63,1,7.49,1.04, 1.15,0.88,0.91,0.41,0.62,0.62, 1.11,0.43,1,1.02,1.07,16.8), # 95%lower Upper_CI = c(1.07,1.41,1.06,1.75,1.25,1.08,1.24, 17.7,0.95,1.19,1,1.19,1.47, 0.78,153,10.5,1.12,0.39,2.34,8.99, 5.06,3.61,3.89,1.02,1,30.1,1.82, 2.83,2.04,1.93,2.01,3.36,1.84, 1.17,0.67,1,1.02,1.10,49.1), # 95%uper P_value = c(0.001,0.354,0.001,0.001,0.811,0.184,0.647, 0.329,0.019,0.406,1,0.302,0.952, 0.002,0.407,0.039,0.124,0.001,0.001,0.001, 0.844,0.169,0.055,0.069,1,0.001,0.025, 0.011,0.164,0.136,0.926,0.337,0.738, 0.001,0.001,0.115,0.001,0.001,0.001) # pvalue ) # draw forest plot forest_dataor$Labeltext <- with(forest_dataor, paste0("OR: ", round(OR, 2), " [95% CI: ", round(Lower_CI, 2), ", ", round(Upper_CI, 2), "], p = ", round(P_value, 4))) forestplot(labeltext = paste0(forest_dataor$Variable, " (OR = ", round(forest_dataor$OR,4), ")"), mean = forest_dataor$OR, lower = forest_dataor$Lower_CI, upper = forest_dataor$Upper_CI, zero = 1, boxsize = 0.5, col = fpColors(box = "royalblue", summary = "royalblue", line = "darkblue"), xlab = "Odds Ratio", title = "Forest Plot of All Variables", is.summary = rep(FALSE, nrow(forest_dataor)), clip = c(0.1, 5), xlog = TRUE, new_page = TRUE) # lasso select variable x <- as.matrix(data[ ,c(2:34)]) y <- as.matrix(data$feiyan) summary(x) summary(y) set.seed(1234) lasso <- glmnet(x,y,alpha=1,family="binomial",nlambda = 100) print(lasso) plot(lasso, xvar = "lambda", label = TRUE) # lambda cv <- cv.glmnet(x, y, family="binomial", alpha = 1, nfolds=10) plot(cv) print(cv) # lambda.min/ labmda.1se lambda_min <- cv$lambda.min lambda_min lambda_1se <- cv$lambda.1se lambda_1se #choose lambda.min coef_cv <- coef(lasso,s=c(cv$lambda.min,cv$lambda.1se)) coef_cv coef_cv_min <- coef(lasso, s=cv$lambda.min) coef_cv_min coef_cv_min <- as.matrix(coef_cv_min) coef_cv_min <- data.frame(coef_cv_min) vars <- row.names(coef_cv_min) vars <- data.frame(variable=vars,coef=coef_cv_min$s1) nonzero_vars <- vars[vars$coef!=0,] # remove"intercept" selected_features <- nonzero_vars[-1,] selected_features # three strategies compare by randomforest modeling # lasso strategy lasso_data <- data[,selected_features$variable] str(lasso_data) lasso_data$feiyan<-data$feiyan lasso_data$feiyan <- as.factor(lasso_data$feiyan) levels(lasso_data$feiyan) <- make.names(levels(lasso_data$feiyan)) data$feiyan <- as.factor(data$feiyan) levels(data$feiyan) <- make.names(levels(data$feiyan)) fitControl <- trainControl( method = 'cv', # full data's 10 folds cross validation without random cut number = 10, # 10 folds savePredictions = 'final', classProbs = TRUE, summaryFunction = twoClassSummary ) set.seed(2024) model_rf_lasso = train(feiyan ~ ., data=lasso_data, method='rf', tuneLength=5, trControl =fitControl) print(model_rf_lasso) # model_rf_lasso AUC 0.79 in 10 folds cross validation # # full variables strategy set.seed(2025) model_rf_all = train(feiyan ~ ., data=data, method='rf', tuneLength=5, trControl =fitControl) print(model_rf_all) # model_rf_all AUC 0.78 in 10 folds cross validation # # p value strategy set.seed(2026) model_rf_p = train(feiyan ~ age+tmax+days+shenzhiyichang+yanbubushi+kesou+qichuan, data=data, method='rf', tuneLength=5, trControl =fitControl) print(model_rf_p) # model_rf_p AUC 0.80 in 10 folds cross validation # # importance compare importance_rf_all <- varImp(model_rf_all, scale = FALSE) importance_rf_lasso <- varImp(model_rf_lasso, scale = FALSE) importance_rf_p <- varImp(model_rf_p, scale = FALSE) print(importance_rf_all) print(importance_rf_lasso) print(importance_rf_p) plot(importance_rf_all) plot(importance_rf_lasso) plot(importance_rf_p) # # choose p value strategy # new data by p value new_data_x <- data[, c("days", "age", "tmax", "yanbubushi", "kesou", "qichuan", "shenzhiyichang", "feiyan")] head(new_data_x) new_data_x$feiyan <- as.factor(new_data_x$feiyan) levels(new_data_x$feiyan) <- make.names(levels(new_data_x$feiyan)) # try interaction strategy with age new_data_x$age_tmax<-new_data_x$age*new_data_x$tmax new_data_x$age_days<-new_data_x$age*new_data_x$days new_data_x$age_shenzhiyichang<-new_data_x$age*new_data_x$shenzhiyichang new_data_x$age_yanbubushi<-new_data_x$age*new_data_x$yanbubushi new_data_x$age_kesou<-new_data_x$age*new_data_x$kesou new_data_x$age_qichuan<-new_data_x$age*new_data_x$qichuan head(new_data_x) # x = interaction set.seed(3024) model_rf_x= train(feiyan ~.,data=new_data_x, method='rf', tuneLength=5, trControl =fitControl) print(model_rf_x) # model_rf_x AUC 0.80 in 10 folds cross validation # with/without interaction compare importance_rf_x <- varImp(model_rf_x, scale = FALSE) print(importance_rf_x) plot(importance_rf_x) modelrf<-list(full_rf_model=model_rf_all, lasso_short_rf_model=model_rf_lasso, pvalue_sig_rf_model=model_rf_p, interaction_rf_model=model_rf_x) modelrf_compare <- resamples(modelrf) summary(modelrf_compare) scales_rf <- list(x=list(relation="free"), y=list(relation="free")) bwplot(modelrf_compare, scales=scales_rf) # interaction is better # modeling with different machine learning algorithms # # xgboost set.seed(3025) model_xgb_x = train(feiyan ~.,data=new_data_x,method = 'xgbTree',trControl = fitControl,verbose = FALSE) print(model_xgb_x) # model_xgb_x AUC 0.79 in 10 folds cross validation # # adaboost ada_grid_x <- expand.grid(iter = c(50, 100, 150),maxdepth = c(1, 2, 3),nu = c(0.1, 0.2, 0.3)) set.seed(3026) model_ada_x = train(feiyan ~.,data=new_data_x, method = "ada",trControl = fitControl,tuneGrid = ada_grid_x) print(model_ada_x) # model_ada_x AUC 0.79 in 10 folds cross validation # # logistic set.seed(3027) model_logit_x = train(feiyan ~.,data=new_data_x, method='glm', family='binomial', trControl=fitControl) print(model_logit_x) # model_logit_x AUC 0.79 in 10 folds cross validation # # logit_net lambda_values_x <- 10^seq(-3, 3, length = 100) alpha_values_x <- c(0, 0.1, 0.5, 1) tuning_grid_x <- expand.grid(alpha = alpha_values_x, lambda = lambda_values_x) set.seed(3028) model_lgn_x = train(feiyan ~.,data=new_data_x, method = "glmnet", trControl = fitControl, tuneGrid = tuning_grid_x, family = "binomial", type.measure = "ROC") print(model_lgn_x) # model_lgn_x AUC 0.80 in 10 folds cross validation # # compare five best model on 10-folds cross validation modelx<-list(random_forest=model_rf_x, xgboost=model_xgb_x, adaboost=model_ada_x, logistic=model_logit_x, logistic_net=model_lgn_x) modelx_compare <- resamples(modelx) summary(modelx_compare) scales_x <- list(x=list(relation="free"), y=list(relation="free")) bwplot(modelx_compare, scales=scales_x) # # add another machine learning algorithms --- catboost # catboost has its own codes of validation, # not the same way as five algorithma above # # new_data_x as internal validation (1781) # data_waibu_qianbanjie as external validation (210) # # tip:data_waibu_qianbanjie contains 210, # which is the first half of the remaining, # after inclusion and exclusion to the external validation of 300 # library(catboost) new_data_x$feiyan_binary <- as.numeric(new_data_x$feiyan) - 1 library(dplyr) dataAspl <- new_data_x %>% select(-feiyan, -feiyan_binary) head(dataAspl) train_poolA <- catboost.load_pool(data = dataAspl,label = as.numeric(as.character(new_data_x$feiyan_binary))) test_poolA <- catboost.load_pool(data = new_data_x,as.numeric(as.character(new_data_x$feiyan_binary))) actual_labelsA <- new_data_x$feiyan actual_labelsSLA <- data_waibu_qianbanjie$feiyan test_poolAA <- catboost.load_pool(data = data_waibu_qianbanjie,label = as.numeric(as.character(data_waibu_qianbanjie$feiyan))) auc_resultsa <- data.frame(iterations = integer(), aucCATAA = numeric()) for (iter in 1:500) { catA <- catboost.train(train_poolA, NULL, params = list(loss_function = 'Logloss', eval_metric = 'AUC', iterations = iter)) pred_probCATAA <- catboost.predict(catA, test_poolAA, prediction_type = "Probability") pred_objCATAA <- prediction(pred_probCATAA, actual_labelsSLA) aucCATAA <- performance(pred_objCATAA, "auc") aucCATAA <- unlist(aucCATAA@y.values) auc_resultsa <- rbind(auc_resultsa, data.frame(iterations = iter, aucCATAA = aucCATAA)) } print(auc_resultsa) # 3 is best iter catA<-catboost.train(train_poolA,NULL, params=list(loss_function='Logloss', eval_metric='AUC', iterations=3)) catA_cv<-catboost.cv(train_poolA,fold_count=10,#交叉验证 params=list(loss_function='Logloss', eval_metric='AUC')) catA_cv<-data.frame(catA_cv) catA_cv$test.AUC.mean[3] # catA AUC 0.79 in 10 folds cross validation pred_probCATA <- catboost.predict(catA, test_poolA, prediction_type = "Probability") pred_objCATA <- prediction(pred_probCATA, actual_labelsA) aucCATA <- performance(pred_objCATA, "auc") aucCATA <- unlist(aucCATA@y.values) print(aucCATA) # catA AUC 0.80 in internal validation test_poolAA <- catboost.load_pool(data = data_waibu_qianbanjie,label = as.numeric(as.character(data_waibu_qianbanjie$feiyan))) pred_probCATAA <- catboost.predict(catA, test_poolAA, prediction_type = "Probability") pred_objCATAA <- prediction(pred_probCATAA, actual_labelsSLA) aucCATAA <- performance(pred_objCATAA, "auc") aucCATAA <- unlist(aucCATAA@y.values) print(aucCATAA) # catA AUC 0.80 in external validation # # compare the five best model and catboost # # 1781 as internal validation # 210 as external validation # library(boot) newpreds <- list( random_forest = predict(model_rf_x, newdata = new_data_x, type = "prob")[,2], xgboost = predict(model_xgb_x, newdata = new_data_x, type = "prob")[,2], adaboost = predict(model_ada_x, newdata = new_data_x, type = "prob")[,2], logistic = predict(model_logit_x, newdata = new_data_x, type = "prob")[,2], logistic_net = predict(model_lgn_x, newdata = new_data_x, type = "prob")[,2], catboost = pred_probCATA ) # +catboost = newpreds roc_results <- lapply(names(newpreds), function(model_name) { pred_probs <- newpreds[[model_name]] true_class <- new_data_x$feiyan pred <- prediction(pred_probs, true_class) auc <- unlist(slot(performance(pred, "auc"), "y.values")) boot_auc <- boot(pred_probs, statistic = function(pred_probs, i) { pred_i <- prediction(pred_probs[i], true_class[i]) unlist(slot(performance(pred_i, "auc"), "y.values")) }, R = 1000) # bootstrap for 1000 ci_lower <- quantile(boot_auc$t, probs = 0.025) ci_upper <- quantile(boot_auc$t, probs = 0.975) return(data.frame(model = model_name, auc = auc, ci_lower = ci_lower, ci_upper = ci_upper)) }) roc_df <- do.call(rbind, roc_results) str(roc_df) roc_curve_df <- data.frame() for(model_name in names(newpreds)) { pred_probs <- newpreds[[model_name]] true_class <- new_data_x$feiyan pred <- prediction(pred_probs, true_class) perf <- performance(pred, "tpr", "fpr") df <- data.frame(fpr=unlist(perf@x.values), tpr=unlist(perf@y.values), model=model_name) roc_curve_df <- rbind(roc_curve_df, df) } ggplot(roc_curve_df, aes(x=fpr, y=tpr, color=model, linetype=model)) + geom_line(size=1) + geom_abline(intercept=0, slope=1, linetype=2, color="gray", size=1) + labs(title="ROC Curves", x="False Positive Rate", y="True Positive Rate") + theme_minimal() + theme(legend.position = "bottom") + scale_color_discrete(name="Model") + scale_linetype_discrete(name="Model") + guides(color=guide_legend(title.position="top", title.hjust=0.5), linetype=guide_legend(title.position="top", title.hjust=0.5)) print(roc_df) # internal validation # #model auc ci_lower ci_upper #2.5% random_forest 0.9401814 0.9288914 0.9516614 #2.5%1 xgboost 0.8205588 0.7968989 0.8460816 #2.5%2 adaboost 0.8512745 0.8285493 0.8698375 #2.5%3 logistic 0.7996615 0.7730157 0.8258508 #2.5%4 logistic_net 0.7971677 0.7702585 0.8233492 #2.5%5 catboost 0.7995018 0.7727276 0.8266350 # pred_list1 <- list( random_forest = predict(model_rf_x, newdata = new_data_x, type = "prob")[,2], xgboost = predict(model_xgb_x, newdata = new_data_x, type = "prob")[,2], adaboost = predict(model_ada_x, newdata = new_data_x, type = "prob")[,2], logistic = predict(model_logit_x, newdata = new_data_x, type = "prob")[,2], logistic_net = predict(model_lgn_x, newdata = new_data_x, type = "prob")[,2], catboost = pred_probCATA )# +catboost roc_curves1 <- lapply(pred_list1, function(pred) { performance(prediction(pred, actual_labelsA), "tpr", "fpr") }) auc_values1 <- c() for(i in 1:length(pred_list1)) { pred <- prediction(pred_list1[[i]], new_data_x$feiyan) perf <- performance(pred, "auc") auc_value <- unlist(perf@y.values) auc_values1 <- c(auc_values1, auc_value) } auc_values1 auc_df1 <- data.frame(Model = c(names(modelx),"catboost"), AUC = auc_values1) auc_df_sorted1 <- auc_df1[order(auc_df1$AUC, decreasing = TRUE),] auc_df_sorted1 colors1 <- rainbow(length(modelx)+1) plot(0, 0, type = "n", xlab = "False Positive Rate", ylab = "True Positive Rate", main = "ROC Curves of α_Models on Internal Data", xlim = c(0, 1), ylim = c(0, 1)) for(i in 1:nrow(auc_df_sorted1)) { model_name <- auc_df_sorted1$Model[i] model_index <- which(c(names(modelx),"catboost") == model_name) lines(roc_curves1[[model_index]]@x.values[[1]], roc_curves1[[model_index]]@y.values[[1]], col = colors1[i], lwd = 2) } abline(a = 0, b = 1, lty = 2, col = "gray") legend("bottomright", legend = sprintf("%s's AUC = %.2f", auc_df_sorted1$Model, auc_df_sorted1$AUC), col = colors1, lwd = 2) auc_df_sorted1 # internal validation # #Model AUC #1 random_forest 0.9401814 #3 adaboost 0.8512745 #2 xgboost 0.8205588 #4 logistic 0.7996615 #6 catboost 0.7995018 #5 logistic_net 0.7971677 # # now do external validation library(boot) preds_wb <- list( random_forest = predict(model_rf_x, newdata = data_waibu_qianbanjie, type = "prob")[,2], xgboost = predict(model_xgb_x, newdata = data_waibu_qianbanjie, type = "prob")[,2], adaboost = predict(model_ada_x, newdata = data_waibu_qianbanjie, type = "prob")[,2], logistic = predict(model_logit_x, newdata = data_waibu_qianbanjie, type = "prob")[,2], logistic_net = predict(model_lgn_x, newdata = data_waibu_qianbanjie, type = "prob")[,2], catboost=pred_probCATAA ) roc_results_wb <- lapply(names(preds_wb), function(model_name) { pred_probs_wb <- preds_wb[[model_name]] true_class_wb <- data_waibu_qianbanjie$feiyan_binary pred_wb <- prediction(pred_probs_wb, true_class_wb) auc_wb <- unlist(slot(performance(pred_wb, "auc"), "y.values")) boot_auc_wb <- boot(pred_probs_wb, statistic = function(pred_probs_wb, i) { pred_i_wb <- prediction(pred_probs_wb[i], true_class_wb[i]) unlist(slot(performance(pred_i_wb, "auc"), "y.values")) }, R = 1000) ci_lower_wb <- quantile(boot_auc_wb$t, probs = 0.025) ci_upper_wb <- quantile(boot_auc_wb$t, probs = 0.975) return(data.frame(model = model_name, auc = auc_wb, ci_lower = ci_lower_wb, ci_upper = ci_upper_wb)) }) roc_df_wb <- do.call(rbind, roc_results_wb) str(roc_df_wb) roc_curve_df_wb <- data.frame() for(model_name in names(preds_wb)) { pred_probs_wb <- preds_wb[[model_name]] true_class_wb <- data_waibu_qianbanjie$feiyan pred_wb <- prediction(pred_probs_wb, true_class_wb) perf_wb <- performance(pred_wb, "tpr", "fpr") df_wb <- data.frame(fpr=unlist(perf_wb@x.values), tpr=unlist(perf_wb@y.values), model=model_name) roc_curve_df_wb <- rbind(roc_curve_df_wb, df_wb) } ggplot(roc_curve_df_wb, aes(x=fpr, y=tpr, color=model, linetype=model)) + geom_line(size=1) + geom_abline(intercept=0, slope=1, linetype=2, color="gray", size=1) + labs(title="ROC Curves", x="False Positive Rate", y="True Positive Rate") + theme_minimal() + theme(legend.position = "bottom") + scale_color_discrete(name="Model") + scale_linetype_discrete(name="Model") + guides(color=guide_legend(title.position="top", title.hjust=0.5), linetype=guide_legend(title.position="top", title.hjust=0.5)) print(roc_df_wb) # external validation # #model auc ci_lower ci_upper #2.5% random_forest 0.7550403 0.6481889 0.8572132 #2.5%1 xgboost 0.7653450 0.6613835 0.8645781 #2.5%2 adaboost 0.7412634 0.6214644 0.8417069 #2.5%3 logistic 0.7547043 0.6532037 0.8456623 #2.5%4 logistic_net 0.7659050 0.6734611 0.8487810 #2.5%5 catboost 0.7959229 0.7122514 0.8714572 # pred_list11<-preds_wb roc_curves11 <- lapply(pred_list11, function(pred) { performance(prediction(pred, data_waibu_qianbanjie$feiyan_binary), "tpr", "fpr") }) auc_values11 <- c() for(i in 1:length(pred_list11)) { pred <- prediction(pred_list11[[i]], data_waibu_qianbanjie$feiyan_binary) perf <- performance(pred, "auc") auc_value <- unlist(perf@y.values) auc_values11 <- c(auc_values11, auc_value) } auc_df11 <- data.frame(Model = c(names(modelx),"catboost"), AUC = auc_values11) auc_df_sorted11 <- auc_df11[order(auc_df11$AUC, decreasing = TRUE),] colors11 <- rainbow(length(modelx)+1) plot(0, 0, type = "n", xlab = "False Positive Rate", ylab = "True Positive Rate", main = "ROC Curves of α_Models on External Data", xlim = c(0, 1), ylim = c(0, 1)) for(i in 1:nrow(auc_df_sorted11)) { model_name <- auc_df_sorted11$Model[i] model_index <- which(c(names(modelx),"catboost") == model_name) lines(roc_curves11[[model_index]]@x.values[[1]], roc_curves11[[model_index]]@y.values[[1]], col = colors1[i], lwd = 2) } abline(a = 0, b = 1, lty = 2, col = "gray") legend("bottomright", legend = sprintf("%s's AUC = %.2f", auc_df_sorted11$Model, auc_df_sorted11$AUC), col = colors1, lwd = 2) auc_df_sorted11 # external validation # #Model AUC #6 catboost 0.7959229 #5 logistic_net 0.7659050 #2 xgboost 0.7653450 #1 random_forest 0.7550403 #4 logistic 0.7547043 #3 adaboost 0.7412634 # # catboost is the best α_model --- catA # # now add laboratory test # # datab also of 1781 # but only laboratory test part # head(datab) datab$crp_plt_ratio <- datab$crp / datab$plt data_waibu_qianbanjie$crp_plt_ratio <- data_waibu_qianbanjie$crp / data_waibu_qianbanjie$plt compareGroups(feiyan~.,data=datab) compareGroups(feiyan~., data=datab, alpha= (0.05/17))# adjust p to 0.05/17~0.003 jxbiaob<-compareGroups(feiyan~., data=datab, alpha= (0.05/17)) jxtableb<-createTable(jxbiaob,show.ratio=TRUE) print(jxtableb,which.table="descr") # nlr, crp_plt_ratio had meaningful p value # # add two variables to modeling β_model datadddd<-new_data_x%>% select(-feiyan) head(datadddd) datadddd$pr_cat_m1<-pred_probCATA datadddd$crp_plt_ratio<-datab$crp_plt_ratio datadddd$nlr<-datab$nlr datadddd$feiyan_binary <- factor(datadddd$feiyan_binary) levels(datadddd$feiyan_binary) <- c("0", "1") head(datadddd) # # datadddd to build six models # fitControld <- trainControl( method = 'cv', # 10-fold cross validation number = 10, savePredictions = 'final', classProbs = TRUE, summaryFunction = twoClassSummary ) # logistic set.seed(8888) datadddd$feiyan_binary <- factor(datadddd$feiyan_binary) levels(datadddd$feiyan_binary) <- c("no", "yes") modelb_logit_dddd = train(feiyan_binary ~.,data=datadddd, method='glm', family='binomial',trControl=fitControld) print(modelb_logit_dddd) summary(modelb_logit_dddd) # first logistic AUC 0.82 # # but p value is not significant # so short the logistic model # set.seed(8888) modelb_logit_dddd = train(feiyan_binary ~age+pr_cat_m1+crp_plt_ratio+nlr, data=datadddd, method='glm', family='binomial',trControl=fitControld) print(modelb_logit_dddd) summary(modelb_logit_dddd) # second logistic AUC 0.82 # # randomforest set.seed(8889) modelb_rf_dddd = train(feiyan_binary ~age+pr_cat_m1+crp_plt_ratio+nlr, data=datadddd, method='rf',trControl=fitControld) print(modelb_rf_dddd) # randomforest AUC 0.78 # # xgboost set.seed(8890) modelb_xgb_dddd = train(feiyan_binary ~age+pr_cat_m1+crp_plt_ratio+nlr,data=datadddd,method = 'xgbTree',trControl=fitControld,verbose = FALSE) print(modelb_xgb_dddd) # xgboost AUC 0.81 # # adaboost ada_grid_d <- expand.grid(iter = c(50, 100, 150),maxdepth = c(1, 2, 3),nu = c(0.1, 0.2, 0.3)) dataddddada<-datadddd%>% select(-c(days,tmax,yanbubushi, kesou,qichuan,shenzhiyichang, age_tmax,age_days,age_shenzhiyichang, age_yanbubushi,age_kesou,age_qichuan)) head(dataddddada) set.seed(8891) modelb_ada_dddd = train(feiyan_binary ~.,data=dataddddada,method = "ada",tuneGrid = ada_grid_d,trControl=fitControld) print(modelb_ada_dddd) # adaboost AUC 0.81 # # logistic_net datadddd$feiyan_binary <- factor(datadddd$feiyan_binary) levels(datadddd$feiyan_binary) <- c("no", "yes") lambda_values_d <- 10^seq(-3, 3, length = 100) alpha_values_d <- c(0, 0.1, 0.5, 1) tuning_grid_d <- expand.grid(alpha = alpha_values_d, lambda = lambda_values_d) set.seed(8892) modelb_lgn_dddd = train(feiyan_binary ~age+pr_cat_m1+crp_plt_ratio+nlr,data=datadddd, method = "glmnet", tuneGrid = tuning_grid_d, family = "binomial", type.measure = "ROC",trControl=fitControld) print(modelb_lgn_dddd) # logistic_net AUC 0.81 # # add catboost head(datadddd) dataCATD<-datadddd %>% select(age,pr_cat_m1,crp_plt_ratio,nlr) head(dataCATD) datadddd$feiyan_binary<-as.character(datadddd$feiyan_binary) datadddd$feiyan_binary <- ifelse(datadddd$feiyan_binary == "yes", 1, 0) head(datadddd$feiyan_binary) train_poolD <- catboost.load_pool(data = dataCATD,label = datadddd$feiyan_binary) test_poolD <- catboost.load_pool(data = datadddd,label = datadddd$feiyan_binary) head(data_waibu_qianbanjie) datawaibudddd<-data_waibu_qianbanjie %>% select(age,crp_plt_ratio,nlr) head(datawaibudddd) datawaibudddd$pr_cat_m1<-pred_probCATAA datawaibudddd$feiyan_binary <- as.integer(data_waibu_qianbanjie$feiyan_binary) head(data_waibu_qianbanjie$feiyan_binary) test_poolDD <- catboost.load_pool(data = datawaibudddd,label = datawaibudddd$feiyan_binary) # auc_resultsd <- data.frame(iterations = integer(), auc = numeric()) for (iter in 1:500) { catD <- catboost.train(train_poolD, NULL, params = list(loss_function = 'Logloss', eval_metric = 'AUC', iterations = iter)) pred_probCATDD <- catboost.predict(catD, test_poolDD, prediction_type = "Probability") actual_labelsDD <- datawaibudddd$feiyan_binary pred_objCATDD <- prediction(pred_probCATDD, actual_labelsDD) aucCATDD <- performance(pred_objCATDD, "auc") aucCATDD <- unlist(aucCATDD@y.values) auc_resultsd <- rbind(auc_resultsd, data.frame(iterations = iter, auc = aucCATDD)) } print(auc_resultsd) # 241 is best catD<-catboost.train(train_poolD,NULL, params=list(loss_function='Logloss', eval_metric='AUC', iterations=241)) catD_cv<-catboost.cv(train_poolD,fold_count=10, # 10-folds cross params=list(loss_function='Logloss', eval_metric='AUC', iterations=241)) catD_cv<-data.frame(catD_cv) catD_cv$test.AUC.mean[241] catD_cv$test.AUC.std[241] # catD AUC in 10-folds cross validation 0.80 pred_probCATD <- catboost.predict(catD, test_poolD, prediction_type = "Probability") actual_labelsD<- datadddd$feiyan_binary pred_objCATD <- prediction(pred_probCATD, actual_labelsD) aucCATD <- performance(pred_objCATD, "auc") aucCATD <- unlist(aucCATD@y.values) print(aucCATD) # catD AUC in internal validation 0.93 test_poolDD <- catboost.load_pool(data = datawaibudddd,label = datawaibudddd$feiyan_binary) pred_probCATDD <- catboost.predict(catD, test_poolDD, prediction_type = "Probability") actual_labelsDD<-datawaibudddd$feiyan_binary pred_objCATDD <- prediction(pred_probCATDD, actual_labelsDD) aucCATDD <- performance(pred_objCATDD, "auc") aucCATDD <- unlist(aucCATDD@y.values) print(aucCATDD) # catD AUC in external validation 0.81 # # compare all these models modeld<-list(random_forest=modelb_rf_dddd, xgboost=modelb_xgb_dddd, adaboost=modelb_ada_dddd, logistic=modelb_logit_dddd, logistic_net=modelb_lgn_dddd, catboost=catD) modeld_compare <- resamples(modeld[-match("catboost", names(modeld))]) summary(modeld_compare) scales_d <- list(x=list(relation="free"), y=list(relation="free")) bwplot(modeld_compare, scales=scales_d) predsd <- list( random_forest = predict(modelb_rf_dddd, newdata = datadddd, type = "prob")[,2], xgboost = predict(modelb_xgb_dddd, newdata = datadddd, type = "prob")[,2], adaboost = predict(modelb_ada_dddd, newdata = datadddd, type = "prob")[,2], logistic = predict(modelb_logit_dddd, newdata = datadddd, type = "prob")[,2], logistic_net = predict(modelb_lgn_dddd, newdata = datadddd, type = "prob")[,2], catboost = pred_probCATD ) roc_resultsd <- lapply(names(predsd), function(model_name) { pred_probs <- predsd[[model_name]] true_class <- datadddd$feiyan_binary pred <- prediction(pred_probs, true_class) auc <- unlist(slot(performance(pred, "auc"), "y.values")) boot_auc <- boot(pred_probs, statistic = function(pred_probs, i) { pred_i <- prediction(pred_probs[i], true_class[i]) unlist(slot(performance(pred_i, "auc"), "y.values")) }, R = 1000) ci_lower <- quantile(boot_auc$t, probs = 0.025) ci_upper <- quantile(boot_auc$t, probs = 0.975) return(data.frame(model = model_name, auc = auc, ci_lower = ci_lower, ci_upper = ci_upper)) }) roc_dfd <- do.call(rbind, roc_resultsd) str(roc_dfd) roc_curve_dfd <- data.frame() for(model_name in names(predsd)) { pred_probs <- predsd[[model_name]] true_class <- datadddd$feiyan_binary pred <- prediction(pred_probs, true_class) perf <- performance(pred, "tpr", "fpr") df <- data.frame(fpr=unlist(perf@x.values), tpr=unlist(perf@y.values), model=model_name) roc_curve_dfd <- rbind(roc_curve_dfd, df) } ggplot(roc_curve_dfd, aes(x=fpr, y=tpr, color=model, linetype=model)) + geom_line(size=1) + geom_abline(intercept=0, slope=1, linetype=2, color="gray", size=1) + labs(title="ROC Curves", x="False Positive Rate", y="True Positive Rate") + theme_minimal() + theme(legend.position = "bottom") + scale_color_discrete(name="Model") + scale_linetype_discrete(name="Model") + guides(color=guide_legend(title.position="top", title.hjust=0.5), linetype=guide_legend(title.position="top", title.hjust=0.5)) print(roc_dfd) # internal validation # #model auc ci_lower ci_upper #2.5% random_forest 1.0000000 1.0000000 1.0000000 #2.5%1 xgboost 0.8346036 0.8104269 0.8580372 #2.5%2 adaboost 0.8290437 0.8044152 0.8543043 #2.5%3 logistic 0.8175744 0.7899900 0.8453691 #2.5%4 logistic_net 0.8174206 0.7903694 0.8432703 #2.5%5 catboost 0.9332909 0.9193978 0.9461488 pred_listd <- list( random_forest = predict(modelb_rf_dddd, newdata = datadddd, type = "prob")[,2], xgboost = predict(modelb_xgb_dddd, newdata = datadddd, type = "prob")[,2], adaboost = predict(modelb_ada_dddd, newdata = datadddd, type = "prob")[,2], logistic = predict(modelb_logit_dddd, newdata = datadddd, type = "prob")[,2], logistic_net = predict(modelb_lgn_dddd, newdata = datadddd, type = "prob")[,2], catboost = pred_probCATD ) roc_curvesd <- lapply(pred_listd, function(pred) { performance(prediction(pred, actual_labelsD), "tpr", "fpr") }) auc_valuesd <- c() for(i in 1:length(pred_listd)) { pred <- prediction(pred_listd[[i]], datadddd$feiyan_binary) perf <- performance(pred, "auc") auc_value <- unlist(perf@y.values) auc_valuesd <- c(auc_valuesd, auc_value) } auc_valuesd auc_dfd <- data.frame(Model = names(modeld), AUC = auc_valuesd) auc_df_sortedd <- auc_dfd[order(auc_dfd$AUC, decreasing = TRUE),] colorsd <- rainbow(length(modeld)) plot(0, 0, type = "n", xlab = "False Positive Rate", ylab = "True Positive Rate", main = "ROC Curves of β_Models on Internal Data", xlim = c(0, 1), ylim = c(0, 1)) for(i in 1:nrow(auc_df_sortedd)) { model_name <- auc_df_sortedd$Model[i] model_index <- which(names(modeld) == model_name) lines(roc_curvesd[[model_index]]@x.values[[1]], roc_curvesd[[model_index]]@y.values[[1]], col = colorsd[i], lwd = 2) } abline(a = 0, b = 1, lty = 2, col = "gray") legend("bottomright", legend = sprintf("%s's AUC = %.2f", auc_df_sortedd$Model, auc_df_sortedd$AUC), col = colorsd, lwd = 2) auc_df_sortedd # internal validation # # Model AUC #1 random_forest 1.0000000 #6 catboost 0.9332909 #2 xgboost 0.8346036 #3 adaboost 0.8290437 #4 logistic 0.8175744 #5 logistic_net 0.8174206 # # # preds_wbd <- list( random_forest = predict(modelb_rf_dddd, newdata = datawaibudddd, type = "prob")[,2], xgboost = predict(modelb_xgb_dddd, newdata = datawaibudddd, type = "prob")[,2], adaboost = predict(modelb_ada_dddd, newdata = datawaibudddd, type = "prob")[,2], logistic = predict(modelb_logit_dddd, newdata = datawaibudddd, type = "prob")[,2], logistic_net = predict(modelb_lgn_dddd, newdata = datawaibudddd, type = "prob")[,2], catboost = pred_probCATDD ) roc_results_wbd <- lapply(names(preds_wbd), function(model_name) { pred_probs_wb <- preds_wbd[[model_name]] true_class_wb <- data_waibu_qianbanjie$feiyan_binary pred_wb <- prediction(pred_probs_wb, true_class_wb) auc_wb <- unlist(slot(performance(pred_wb, "auc"), "y.values")) boot_auc_wb <- boot(pred_probs_wb, statistic = function(pred_probs_wb, i) { pred_i_wb <- prediction(pred_probs_wb[i], true_class_wb[i]) unlist(slot(performance(pred_i_wb, "auc"), "y.values")) }, R = 1000) ci_lower_wb <- quantile(boot_auc_wb$t, probs = 0.025) ci_upper_wb <- quantile(boot_auc_wb$t, probs = 0.975) return(data.frame(model = model_name, auc = auc_wb, ci_lower = ci_lower_wb, ci_upper = ci_upper_wb)) }) roc_df_wbd <- do.call(rbind, roc_results_wbd) str(roc_df_wbd) roc_curve_df_wbd <- data.frame() for(model_name in names(preds_wbd)) { pred_probs_wb <- preds_wbd[[model_name]] true_class_wb <- data_waibu_qianbanjie$feiyan_binary pred_wb <- prediction(pred_probs_wb, true_class_wb) perf_wb <- performance(pred_wb, "tpr", "fpr") df_wb <- data.frame(fpr=unlist(perf_wb@x.values), tpr=unlist(perf_wb@y.values), model=model_name) roc_curve_df_wbd <- rbind(roc_curve_df_wb, df_wb) } ggplot(roc_curve_df_wbd, aes(x=fpr, y=tpr, color=model, linetype=model)) + geom_line(size=1) + geom_abline(intercept=0, slope=1, linetype=2, color="gray", size=1) + labs(title="ROC Curves", x="False Positive Rate", y="True Positive Rate") + theme_minimal() + theme(legend.position = "bottom") + scale_color_discrete(name="Model") + scale_linetype_discrete(name="Model") + guides(color=guide_legend(title.position="top", title.hjust=0.5), linetype=guide_legend(title.position="top", title.hjust=0.5)) print(roc_df_wbd) # external validation # #model auc ci_lower ci_upper #2.5% random_forest 0.7530242 0.6274514 0.8727370 #2.5%1 xgboost 0.7756496 0.6727189 0.8695979 #2.5%2 adaboost 0.7726254 0.6717676 0.8760468 #2.5%3 logistic 0.7811380 0.6812031 0.8747617 #2.5%4 logistic_net 0.7851703 0.6911674 0.8700922 #2.5%5 catboost 0.8064516 0.6955940 0.9018647 pred_listdd <- list( random_forest = predict(modelb_rf_dddd, newdata = datawaibudddd, type = "prob")[,2], xgboost = predict(modelb_xgb_dddd, newdata = datawaibudddd, type = "prob")[,2], adaboost = predict(modelb_ada_dddd, newdata = datawaibudddd, type = "prob")[,2], logistic = predict(modelb_logit_dddd, newdata = datawaibudddd, type = "prob")[,2], logistic_net = predict(modelb_lgn_dddd, newdata = datawaibudddd, type = "prob")[,2], catboost = pred_probCATDD ) roc_curvesdd <- lapply(pred_listdd, function(pred) { performance(prediction(pred, datawaibudddd$feiyan_binary), "tpr", "fpr") }) auc_valuesdd <- c() for(i in 1:length(pred_listdd)) { pred <- prediction(pred_listdd[[i]],datawaibudddd$feiyan_binary) perf <- performance(pred, "auc") auc_value <- unlist(perf@y.values) auc_valuesdd <- c(auc_valuesdd, auc_value) } auc_dfdd <- data.frame(Model = names(modeld), AUC = auc_valuesdd) auc_df_sorteddd <- auc_dfdd[order(auc_dfdd$AUC, decreasing = TRUE),] colorsdd <- rainbow(length(modeld)) plot(0, 0, type = "n", xlab = "False Positive Rate", ylab = "True Positive Rate", main = "ROC Curves of β_Models on External Data", xlim = c(0, 1), ylim = c(0, 1)) for(i in 1:nrow(auc_df_sorteddd)) { model_name <- auc_df_sorteddd$Model[i] model_index <- which(names(modeld) == model_name) lines(roc_curvesdd[[model_index]]@x.values[[1]], roc_curvesdd[[model_index]]@y.values[[1]], col = colorsdd[i], lwd = 2) } abline(a = 0, b = 1, lty = 2, col = "gray") legend("bottomright", legend = sprintf("%s's AUC = %.2f", auc_df_sorteddd$Model, auc_df_sorteddd$AUC), col = colorsdd, lwd = 2) auc_df_sorteddd # external validation # # Model AUC #6 catboost 0.8064516 #5 logistic_net 0.7851703 #4 logistic 0.7811380 #2 xgboost 0.7756496 #3 adaboost 0.7726254 #1 random_forest 0.7530242 # # catboost is the best β_model --- catD # # now check and compare other performance of built models # # compare α/β AUC # poolA <- catboost.load_pool(data = new_data_x,label = as.numeric(new_data_x$feiyan_binary)) predictions_probA <- catboost.predict(catA, poolA, prediction_type = "Probability") poolAA <- catboost.load_pool(data = data_waibu_qianbanjie,label = data_waibu_qianbanjie$feiyan) predictions_probAA <- catboost.predict(catA, poolAA, prediction_type = "Probability") poolD <- catboost.load_pool(data = datadddd,label = as.numeric(datadddd$feiyan_binary)) predictions_probD <- catboost.predict(catD, poolD, prediction_type = "Probability") poolDD <- catboost.load_pool(data =datawaibudddd ,label = as.numeric(datawaibudddd$feiyan_binary)) predictions_probDD <- catboost.predict(catD,poolDD,prediction_type = "Probability") # # # internal AUC compare pred_listAD<-list( α_model=predictions_probA, β_model=predictions_probD ) trueAD=new_data_x$feiyan_binary roc_alpha_AD <- roc(trueAD, predictions_probA) roc_beta_AD <- roc(trueAD, predictions_probD) plot(roc_alpha_AD, col = "blue", lwd = 2, main = "α/β_Model's Internal Validation ROC Curves") lines(roc_beta_AD, col = "red", lwd = 2) legend("bottomright", legend = c("α_model’s AUC = 0.80, 95%CI 0.77 - 0.83", "β_model’s AUC = 0.93, 95%CI 0.92 - 0.95"), col = c("blue", "red"), lwd = 2) auc_alpha_AD <- auc(roc_alpha_AD) ci_alpha_AD <- ci.auc(roc_alpha_AD) auc_beta_AD <- auc(roc_beta_AD) ci_beta_AD <- ci.auc(roc_beta_AD) cat("Internal Validation:\n") cat("AUC for α_model:", auc_alpha_AD, "CI:", ci_alpha_AD, "\n") # AUC for α_model: 0.7995018 CI: 0.7722474 0.7995018 0.8267562 cat("AUC for β_model:", auc_beta_AD, "CI:", ci_beta_AD, "\n") # AUC for β_model: 0.9332909 CI: 0.9196102 0.9332909 0.9469716 # DeLong test delong_test_AD <- roc.test(roc_alpha_AD, roc_beta_AD, method = "delong") cat("DeLong test between α_model and β_model:\n") print(delong_test_AD) # Z = -13.914, p-value < 2.2e-16 # # external AUC compare pred_listAADD<-list( α_model=predictions_probAA, β_model=predictions_probDD ) trueAADD=data_waibu_qianbanjie$feiyan_binary roc_alpha_AADD <- roc(trueAADD, predictions_probAA) roc_beta_AADD <- roc(trueAADD, predictions_probDD) plot(roc_alpha_AADD, col = "blue", lwd = 2, main = "α/β_Model's External Validation ROC Curves") lines(roc_beta_AADD, col = "red", lwd = 2) legend("bottomright", legend = c("α_model’s AUC = 0.80, 95%CI 0.72 - 0.88", "β_model’s AUC = 0.81, 95%CI 0.70 - 0.91"), col = c("blue", "red"), lwd = 2) auc_alpha_AADD <- auc(roc_alpha_AADD) ci_alpha_AADD <- ci.auc(roc_alpha_AADD) auc_beta_AADD <- auc(roc_beta_AADD) ci_beta_AADD <- ci.auc(roc_beta_AADD) cat("External Validation:\n") cat("AUC for α_model (DD):", auc_alpha_AADD, "CI:", ci_alpha_AADD, "\n") cat("AUC for β_model (DD):", auc_beta_AADD, "CI:", ci_beta_AADD, "\n") # DeLong test delong_test_AADD <- roc.test(roc_alpha_AADD, roc_beta_AADD, method = "delong") cat("DeLong test between α_model (DD) and β_model (DD):\n") print(delong_test_AADD) # Z = -0.32138, p-value = 0.7479 # # IDI compare # α_model's IDI compare # calculate_IDIAA <- function(preds1, preds2, actual_classes) { mean_pred_prob1 <- mean(preds1[actual_classes == 1]) mean_pred_prob2 <- mean(preds2[actual_classes == 1]) IDI <- mean_pred_prob2 - mean_pred_prob1 return(IDI) } modelnamesAA <- c("randomforest", "xgboost", "adaboost", "logistic", "logisticnet", "catboost") IDI_matrixAA <- matrix(NA, nrow=length(modelnamesAA), ncol=length(modelnamesAA), dimnames=list(modelnamesAA, modelnamesAA)) for(i in 1:length(modelnamesAA)) { for(j in 1:length(modelnamesAA)) { if(i != j) { IDI <- calculate_IDIAA(pred_list11[[i]], pred_list11[[j]], data_waibu_qianbanjie$feiyan_binary) IDI_matrixAA[modelnamesAA[i], modelnamesAA[j]] <- IDI } } } print(IDI_matrixAA) IDI_matrix_long <- melt(IDI_matrixAA) IDI_matrix_long$value[is.na(IDI_matrix_long$value)] <- 0 IDI_matrix_long <- IDI_matrix_long %>% rename('IDI.yminusx' = value) ggplot(IDI_matrix_long, aes(x = Var1, y = Var2, fill = IDI.yminusx)) + geom_tile() + scale_fill_gradient2(low = "blue", mid = "gray", high = "red", midpoint = 0) + theme_minimal() + theme(axis.text.x = element_text(angle = 45, hjust = 1), axis.text.y = element_text(size = 12), axis.title = element_blank(), legend.title = element_text(size = 12)) + labs(title = "IDI Matrix Heatmap of α_Models on External Data") # # β_model's IDI compare # calculate_IDIDD <- function(preds1, preds2, actual_classes) { mean_pred_prob1 <- mean(preds1[actual_classes == 1]) mean_pred_prob2 <- mean(preds2[actual_classes == 1]) IDI <- mean_pred_prob2 - mean_pred_prob1 return(IDI) } modelnamesDD <- c("randomforest", "xgboost", "adaboost", "logistic", "logisticnet", "catboost") IDI_matrixDD <- matrix(NA, nrow=length(modelnamesDD), ncol=length(modelnamesDD), dimnames=list(modelnamesDD, modelnamesDD)) for(i in 1:length(modelnamesDD)) { for(j in 1:length(modelnamesDD)) { if(i != j) { IDI <- calculate_IDIDD(pred_listdd[[i]], pred_listdd[[j]], data_waibu_qianbanjie$feiyan_binary) IDI_matrixDD[modelnamesDD[i], modelnamesDD[j]] <- IDI } } } print(IDI_matrixDD) IDI_matrix_longD <- melt(IDI_matrixDD) IDI_matrix_longD$value[is.na(IDI_matrix_longD$value)] <- 0 IDI_matrix_longD <- IDI_matrix_longD %>% rename('IDI.yminusx' = value) ggplot(IDI_matrix_longD, aes(x = Var1, y = Var2, fill = IDI.yminusx)) + geom_tile() + scale_fill_gradient2(low = "blue", mid = "gray", high = "red", midpoint = 0) + theme_minimal() + theme(axis.text.x = element_text(angle = 45, hjust = 1), axis.text.y = element_text(size = 12), axis.title = element_blank(), legend.title = element_text(size = 12)) + labs(title = "IDI Matrix Heatmap of β_Models on External Data") # # now separately compare two models' performance # # α_model performance # # confusion matrix compare # # internal # pred_A <- prediction(predictions_probA, new_data_x$feiyan_binary) cutoffs_A <- data.frame( threshold = pred_A@cutoffs[[1]], specificity = unlist(performance(pred_A, "spec", "sens")@y.values), sensitivity = unlist(performance(pred_A, "spec", "sens")@x.values) ) print(paste("Best threshold:", cutoffs_A[which.max(cutoffs_A$sensitivity + cutoffs_A$specificity - 1), "threshold"])) predicted_classes_optimalA <- ifelse(predictions_probA > cutoffs_A[which.max(cutoffs_A$sensitivity + cutoffs_A$specificity - 1), "threshold"], "1", "0") confusion_matrix_optimalA <- table(new_data_x$feiyan_binary, predicted_classes_optimalA) accuracy_optimalA <- sum(diag(confusion_matrix_optimalA)) / sum(confusion_matrix_optimalA) specificity_optimalA <- confusion_matrix_optimalA[1,1] / sum(confusion_matrix_optimalA[1,]) sensitivity_optimalA <- confusion_matrix_optimalA[2,2] / sum(confusion_matrix_optimalA[2,]) precision_optimalA <- confusion_matrix_optimalA[2,2] / sum(confusion_matrix_optimalA[,2]) recall_optimalA <- sensitivity_optimalA F1_score_optimalA <- 2 * (precision_optimalA * recall_optimalA) / (precision_optimalA + recall_optimalA) print(paste("Accuracy (A_MODEL):", accuracy_optimalA)) print(paste("Specificity (A_MODEL):", specificity_optimalA)) print(paste("Sensitivity (A_MODEL):", sensitivity_optimalA)) print(paste("F1 Score (A_MODEL):", F1_score_optimalA)) perfA <- performance(pred_A, "tpr", "fpr") best_thresholdA <- which.max(cutoffs_A$sensitivity + cutoffs_A$specificity - 1) closest_indexA <- which.min(abs(pred_A@cutoffs[[1]] - best_thresholdA)) tpr_bestA <- unlist(performance(pred_A, "tpr")@y.values)[closest_indexA] fpr_bestA <- unlist(performance(pred_A, "fpr")@x.values)[closest_indexA] print(paste("A_MODEL's TPR at best threshold:", tpr_bestA)) print(paste("A_MODEL's FPR at best threshold:", fpr_bestA)) thresholdsA <- pred_A@cutoffs[[1]] tprsA <- unlist(performance(pred_A, "tpr")@y.values) fprsA <- unlist(performance(pred_A, "fpr")@x.values) closest_indexA <- which.min(abs(thresholdsA - best_thresholdA)) tpr_bestA <- tprsA[closest_indexA] fpr_bestA <- fprsA[closest_indexA] tpr_bestA fpr_bestA predictions_classA <- as.factor(predicted_classes_optimalA ) caret::confusionMatrix(as.factor(predictions_classA), as.factor(new_data_x$feiyan_binary),positive ='1') # MCC for unbalance compare TP_A <- as.double(confusion_matrix_optimalA[2,2]) # true positive FP_A <- as.double(confusion_matrix_optimalA[1,2]) # false positive FN_A <- as.double(confusion_matrix_optimalA[2,1]) # false negative TN_A <- as.double(confusion_matrix_optimalA[1,1]) # true negative print(TP_A) print(FP_A) print(FN_A) print(TN_A) MCC_optimalA <- ((TP_A * TN_A) - (FP_A * FN_A)) / sqrt((TP_A + FP_A) * (TP_A + FN_A) * (TN_A + FP_A) * (TN_A + FN_A)) print(paste("MCC (A_MODEL):", MCC_optimalA)) # MCC 0.446 str(predictions_probA) str(new_data_x$feiyan_binary) predictions_probA_matrix <- cbind(1 - predictions_probA,predictions_probA) new_data_x_feiyan_binary_num <- as.numeric(new_data_x$feiyan_binary) # Brier score BrierA<-BrierScore(predictions_probA_matrix, new_data_x_feiyan_binary_num) BrierA # Brier score 0.1263755，< 0.25，good # # external # pred_AA <- prediction(predictions_probAA,data_waibu_qianbanjie$feiyan) cutoffs_AA <- data.frame( threshold = pred_AA@cutoffs[[1]], specificity = unlist(performance(pred_AA, "spec", "sens")@y.values), sensitivity = unlist(performance(pred_AA, "spec", "sens")@x.values) ) print(paste("Best threshold:", cutoffs_AA[which.max(cutoffs_AA$sensitivity + cutoffs_AA$specificity - 1), "threshold"])) predicted_classes_optimalAA <- ifelse(predictions_probAA> cutoffs_AA[which.max(cutoffs_AA$sensitivity + cutoffs_AA$specificity - 1), "threshold"], 1, 0) confusion_matrix_optimalAA <- table(data_waibu_qianbanjie$feiyan, predicted_classes_optimalAA) accuracy_optimalAA <- sum(diag(confusion_matrix_optimalAA)) / sum(confusion_matrix_optimalAA) specificity_optimalAA <- confusion_matrix_optimalAA[1,1] / sum(confusion_matrix_optimalAA[1,]) sensitivity_optimalAA <- confusion_matrix_optimalAA[2,2] / sum(confusion_matrix_optimalAA[2,]) precision_optimalAA <- confusion_matrix_optimalAA[2,2] / sum(confusion_matrix_optimalAA[,2]) recall_optimalAA <- sensitivity_optimalAA F1_score_optimalAA <- 2 * (precision_optimalAA * recall_optimalAA) / (precision_optimalAA + recall_optimalAA) print(paste("Accuracy (A_MODEL):", accuracy_optimalAA)) print(paste("Specificity (A_MODEL):", specificity_optimalAA)) print(paste("Sensitivity (A_MODEL):", sensitivity_optimalAA)) print(paste("F1 Score (A_MODEL):", F1_score_optimalAA)) perfAA <- performance(pred_AA, "tpr", "fpr") closest_indexAA <- which.min(abs(pred_AA@cutoffs[[1]] - 0.176)) tpr_bestAA <- unlist(performance(pred_AA, "tpr")@y.values)[closest_indexAA] fpr_bestAA <- unlist(performance(pred_AA, "fpr")@x.values)[closest_indexAA] print(paste("A_MODEL's TPR at best threshold:", tpr_bestAA)) print(paste("A_MODEL's FPR at best threshold:", fpr_bestAA)) predictions_classAA <- as.factor(predicted_classes_optimalAA ) caret::confusionMatrix(as.factor(predictions_classAA), as.factor(data_waibu_qianbanjie$feiyan),positive ='1') # MCC TP_AA <- as.double(confusion_matrix_optimalAA[2,2]) FP_AA <- as.double(confusion_matrix_optimalAA[1,2]) FN_AA <- as.double(confusion_matrix_optimalAA[2,1]) TN_AA <- as.double(confusion_matrix_optimalAA[1,1]) print(TP_AA) print(FP_AA) print(FN_AA) print(TN_AA) MCC_optimalAA <- ((TP_AA * TN_AA) - (FP_AA * FN_AA)) / sqrt((TP_AA + FP_AA) * (TP_AA + FN_AA) * (TN_AA + FP_AA) * (TN_AA + FN_AA)) print(paste("MCC (A_MODEL):", MCC_optimalAA)) # MCC 0.283 str(predictions_probAA) str(data_waibu_qianbanjie$feiyan_binary) predictions_probAA_matrix <- cbind(1 - predictions_probAA,predictions_probAA) data_waibu_qianbanjie_feiyan_binary_num <- as.numeric(data_waibu_qianbanjie$feiyan_binary) # Brier score BrierAA<-BrierScore(predictions_probAA_matrix, data_waibu_qianbanjie_feiyan_binary_num) BrierAA # Brier score 0.1065106，< 0.25，good # # DCA plot compare # # internal # α_randomforest.I <- predict(model_rf_x, newdata = new_data_x, type = "prob")[,2] α_xgboost.I <- predict(model_xgb_x, newdata = new_data_x, type = "prob")[,2] α_adaboost.I <- predict(model_ada_x, newdata = new_data_x, type = "prob")[,2] α_logistic.I <- predict(model_logit_x, newdata = new_data_x, type = "prob")[,2] α_logisticnet.I <- predict(model_lgn_x, newdata = new_data_x, type = "prob")[,2] α_catboost.I<-predictions_probA dca_A <- dca(data =new_data_x, feiyan_binary ~ α_randomforest.I+ α_xgboost.I+ α_adaboost.I+ α_logistic.I+ α_logisticnet.I+ α_catboost.I)#加入catboost plot(dca_A, type = 'net_benefit', smooth = TRUE, showggplotcode = FALSE) + ggtitle("Decision Curve Analysis of α_Models on Internal Data") + theme(plot.title = element_text(hjust = 0.5)) # # external # α_randomforest.E <- predict(model_rf_x, newdata = data_waibu_qianbanjie, type = "prob")[,2] α_xgboost.E <- predict(model_xgb_x, newdata = data_waibu_qianbanjie, type = "prob")[,2] α_adaboost.E <- predict(model_ada_x, newdata = data_waibu_qianbanjie, type = "prob")[,2] α_logistic.E <- predict(model_logit_x, newdata = data_waibu_qianbanjie, type = "prob")[,2] α_logisticnet.E <- predict(model_lgn_x, newdata = data_waibu_qianbanjie, type = "prob")[,2] # test_poolAA <- catboost.load_pool(data = data_waibu_qianbanjie,label = data_waibu_qianbanjie$feiyan) pred_probCATAA <- catboost.predict(catA, test_poolAA, prediction_type = "Probability") α_catboost.E<-pred_probCATAA dca_AA <- dca(data =data_waibu_qianbanjie, feiyan ~ α_randomforest.E+ α_xgboost.E+ α_adaboost.E+ α_logistic.E+ α_logisticnet.E+ α_catboost.E) plot(dca_AA, type = 'net_benefit', smooth = TRUE, showggplotcode = FALSE) + ggtitle("Decision Curve Analysis of α_Models on External Data") + theme(plot.title = element_text(hjust = 0.5)) # # calibration plot # # internal # new_data_x$feiyan_binary <- as.factor(new_data_x$feiyan_binary) head(new_data_x$feiyan_binary) lift_resultsA <- data.frame(Class = as.factor((as.numeric(new_data_x$feiyan_binary)))) lift_resultsA$randomforest <-α_randomforest.I lift_resultsA$xgboost <- α_xgboost.I lift_resultsA$adaboost <- α_adaboost.I lift_resultsA$logistic <- α_logistic.I lift_resultsA$logisticnet <- α_logisticnet.I lift_resultsA$catboost <- α_catboost.I head(lift_resultsA) lift_resultsA$Class <- as.factor(lift_resultsA$Class) calculate_calibration <- function(predictor, data) { fit_cal <- lrm(Class ~ data[[predictor]], data = data, x = TRUE, y = TRUE) calibration <- calibrate(fit_cal, cmethod="boot", B=1000) predicted <- calibration[, "predy"] calibrated <- calibration[, "calibrated.orig"] return(data.frame(Predicted = predicted, Calibrated = calibrated, Model = predictor)) } calibration_data <- NULL models_cal <- c("randomforest", "xgboost", "adaboost", "logistic", "logisticnet", "catboost") for (model in models_cal) { calibration_data <- rbind(calibration_data, calculate_calibration(model, lift_resultsA)) } ggplot(calibration_data, aes(x = Predicted, y = Calibrated, color = Model)) + geom_point(alpha = 0.5) + geom_abline(intercept = 0, slope = 1, color = "red") + labs(title = "Calibration Curves of α_Models on Internal Data", x = "Predicted Probability", y = "Actual Probability") + theme_minimal() # # external # data_waibu_qianbanjie$feiyan_binary<- as.factor(data_waibu_qianbanjie$feiyan_binary) head(data_waibu_qianbanjie$feiyan_binary) lift_resultsAA <- data.frame(Class = as.factor((as.numeric(data_waibu_qianbanjie$feiyan_binary)))) lift_resultsAA$randomforest <-α_randomforest.E lift_resultsAA$xgboost <- α_xgboost.E lift_resultsAA$adaboost <- α_adaboost.E lift_resultsAA$logistic <- α_logistic.E lift_resultsAA$logisticnet <- α_logisticnet.E lift_resultsAA$catboost <- α_catboost.E head(lift_resultsAA) lift_resultsAA$Class <- as.factor(lift_resultsAA$Class) calculate_calibration_test <- function(predictor, data) { fit_cal <- lrm(Class ~ data[[predictor]], data = data, x = TRUE, y = TRUE) calibration <- calibrate(fit_cal, cmethod="boot", B=1000) predicted <- calibration[, "predy"] calibrated <- calibration[, "calibrated.orig"] return(data.frame(Predicted = predicted, Calibrated = calibrated, Model = predictor)) } calibration_data_test <- NULL models_cal_test <- c("randomforest", "xgboost", "adaboost", "logistic", "logisticnet", "catboost") for (model in models_cal_test) { calibration_data_test <- rbind(calibration_data_test, calculate_calibration_test(model, lift_resultsAA)) } ggplot(calibration_data_test, aes(x = Predicted, y = Calibrated, color = Model)) + geom_point(alpha = 0.5) + geom_abline(intercept = 0, slope = 1, color = "red") + labs(title = "Calibration Curves of α_Models on External Data", x = "Predicted Probability", y = "Actual Probability") + theme_minimal() # # β_model performance # # confusion matrix # # internal pred_D <- prediction(predictions_probD, datadddd$feiyan_binary) pred_D cutoffs_D <- data.frame( threshold = pred_D@cutoffs[[1]], specificity = unlist(performance(pred_D, "spec", "sens")@y.values), sensitivity = unlist(performance(pred_D, "spec", "sens")@x.values) ) print(paste("Best threshold:", cutoffs_D[which.max(cutoffs_D$sensitivity + cutoffs_D$specificity - 1), "threshold"])) predicted_classes_optimalD <- ifelse(predictions_probD> cutoffs_D[which.max(cutoffs_D$sensitivity + cutoffs_D$specificity - 1), "threshold"], 1, 0) confusion_matrix_optimalD <- table(datadddd$feiyan_binary, predicted_classes_optimalD) accuracy_optimalD <- sum(diag(confusion_matrix_optimalD)) / sum(confusion_matrix_optimalD) specificity_optimalD <- confusion_matrix_optimalD[1,1] / sum(confusion_matrix_optimalD[1,]) sensitivity_optimalD <- confusion_matrix_optimalD[2,2] / sum(confusion_matrix_optimalD[2,]) precision_optimalD <- confusion_matrix_optimalD[2,2] / sum(confusion_matrix_optimalD[,2]) recall_optimalD <- sensitivity_optimalD F1_score_optimalD <- 2 * (precision_optimalD * recall_optimalD) / (precision_optimalD + recall_optimalD) print(confusion_matrix_optimalD) print(paste("Accuracy (D_MODEL):", accuracy_optimalD)) print(paste("Specificity (D_MODEL):", specificity_optimalD)) print(paste("Sensitivity (D_MODEL):", sensitivity_optimalD)) print(paste("F1 Score (D_MODEL):", F1_score_optimalD)) perfD<- performance(pred_D, "tpr", "fpr") best_thresholdD<- which.max(cutoffs_D$sensitivity + cutoffs_D$specificity - 1) closest_indexD <- which.min(abs(pred_D@cutoffs[[1]] - best_thresholdD)) tpr_bestD <- unlist(performance(pred_D, "tpr")@y.values)[closest_indexD] fpr_bestD <- unlist(performance(pred_D, "fpr")@x.values)[closest_indexD] print(paste("D_MODEL's TPR at best threshold:", tpr_bestD)) print(paste("D_MODEL's FPR at best threshold:", fpr_bestD)) thresholdsD <- pred_D@cutoffs[[1]] tprsD <- unlist(performance(pred_D, "tpr")@y.values) fprsD <- unlist(performance(pred_D, "fpr")@x.values) closest_indexD <- which.min(abs(thresholdsD - best_thresholdD)) tpr_bestD <- tprsD[closest_indexD] fpr_bestD <- fprsD[closest_indexD] tpr_bestD fpr_bestD predictions_classD <- as.factor(predicted_classes_optimalD) str(datadddd$feiyan_binary) datadddd$feiyan_binary <- as.factor(datadddd$feiyan_binary) levels(datadddd$feiyan_binary) <- levels(predictions_classD) caret::confusionMatrix(predictions_classD, datadddd$feiyan_binary, positive = "1") # MCC TP_D <- as.double(confusion_matrix_optimalD[2,2]) FP_D <- as.double(confusion_matrix_optimalD[1,2]) FN_D <- as.double(confusion_matrix_optimalD[2,1]) TN_D <- as.double(confusion_matrix_optimalD[1,1]) print(TP_D) print(FP_D) print(FN_D) print(TN_D) MCC_optimalD <- ((TP_D * TN_D) - (FP_D * FN_D)) / sqrt((TP_D + FP_D) * (TP_D + FN_D) * (TN_D + FP_D) * (TN_D + FN_D)) print(paste("MCC (D_MODEL):", MCC_optimalD)) # MCC 0.597 str(predictions_probD) str(new_data_x$feiyan_binary) predictions_probD_matrix <- cbind(1 - predictions_probD,predictions_probD) new_data_x_feiyan_binary_numD <- as.numeric(new_data_x$feiyan_binary) # Brier score BrierD<-BrierScore(predictions_probD_matrix, new_data_x_feiyan_binary_numD) BrierD # Brier score 0.0758222，< 0.25，good # # NRI head(new_data_x) str(new_data_x$feiyan_binary) new_data_x$feiyan_binary <- as.numeric(as.character(new_data_x$feiyan_binary)) head(predictions_probD) reclassification(data=new_data_x,cOutcome=15, predrisk1=predictions_probA, predrisk2=predictions_probD, cutoff=c(0,.22,1)) # NRI=0.20 # # external # poolDD <- catboost.load_pool(data =datawaibudddd ,label = as.numeric(datawaibudddd$feiyan_binary)) predictions_probDD <- catboost.predict(catD,poolDD,prediction_type = "Probability") pred_DD <- prediction(predictions_probDD,datawaibudddd$feiyan_binary) cutoffs_DD <- data.frame( threshold = pred_DD@cutoffs[[1]], specificity = unlist(performance(pred_DD, "spec", "sens")@y.values), sensitivity = unlist(performance(pred_DD, "spec", "sens")@x.values) ) print(paste("Best threshold:", cutoffs_DD[which.max(cutoffs_DD$sensitivity + cutoffs_DD$specificity - 1), "threshold"])) predicted_classes_optimalDD <- ifelse(predictions_probDD > cutoffs_DD[which.max(cutoffs_DD$sensitivity + cutoffs_DD$specificity - 1), "threshold"], 1, 0) confusion_matrix_optimalDD <- table(data_waibu_qianbanjie$feiyan_binary, predicted_classes_optimalDD) accuracy_optimalDD <- sum(diag(confusion_matrix_optimalDD)) / sum(confusion_matrix_optimalDD) specificity_optimalDD <- confusion_matrix_optimalDD[1,1] / sum(confusion_matrix_optimalDD[1,]) sensitivity_optimalDD <- confusion_matrix_optimalDD[2,2] / sum(confusion_matrix_optimalDD[2,]) precision_optimalDD <- confusion_matrix_optimalDD[2,2] / sum(confusion_matrix_optimalDD[,2]) recall_optimalDD <- sensitivity_optimalDD F1_score_optimalDD <- 2 * (precision_optimalDD * recall_optimalDD) / (precision_optimalDD + recall_optimalDD) print(confusion_matrix_optimalDD) print(paste("Accuracy (D_MODEL):", accuracy_optimalDD)) print(paste("Specificity (D_MODEL):", specificity_optimalDD)) print(paste("Sensitivity (D_MODEL):", sensitivity_optimalDD)) print(paste("F1 Score (D_MODEL):", F1_score_optimalDD)) predictions_classDD <- as.factor(predicted_classes_optimalDD ) caret::confusionMatrix(as.factor(predictions_classDD), as.factor(data_waibu_qianbanjie$feiyan_binary),positive ='1') # MCC TP_DD <- as.double(confusion_matrix_optimalDD[2,2]) FP_DD <- as.double(confusion_matrix_optimalDD[1,2]) FN_DD <- as.double(confusion_matrix_optimalDD[2,1]) TN_DD <- as.double(confusion_matrix_optimalDD[1,1]) print(TP_DD) print(FP_DD) print(FN_DD) print(TN_DD) MCC_optimalDD <- ((TP_DD * TN_DD) - (FP_DD * FN_DD)) / sqrt((TP_DD + FP_DD) * (TP_DD + FN_DD) * (TN_DD + FP_DD) * (TN_DD + FN_DD)) print(paste("MCC (D_MODEL):", MCC_optimalDD)) # MCC 0.359 str(predictions_probDD) str(data_waibu_qianbanjie$feiyan_binary) predictions_probDD_matrix <- cbind(1 - predictions_probDD,predictions_probDD) data_waibu_qianbanjie_feiyan_binary_numD <- as.numeric(data_waibu_qianbanjie$feiyan_binary) # Brier score BrierDD<-BrierScore(predictions_probDD_matrix, data_waibu_qianbanjie_feiyan_binary_numD) BrierDD # Brier score 0.08503296，< 0.25，good # # NRI head(datawaibudddd) head(predictions_probDD) reclassification(data=datawaibudddd,cOutcome=5, predrisk1=predictions_probAA, predrisk2=predictions_probDD, cutoff=c(0,.15,1)) # NRI=0.12 # # DCA plot # # internal # β_randomforest.I <- predict(modelb_rf_dddd, newdata = datadddd, type = "prob")[,2] β_xgboost.I <- predict(modelb_xgb_dddd, newdata = datadddd, type = "prob")[,2] β_adaboost.I <- predict(modelb_ada_dddd, newdata = datadddd, type = "prob")[,2] β_logistic.I <- predict(modelb_logit_dddd, newdata = datadddd, type = "prob")[,2] β_logisticnet.I <- predict(modelb_lgn_dddd, newdata = datadddd, type = "prob")[,2] β_catboost.I <- pred_probCATD # dca_D <- dca(data =datadddd, feiyan_binary ~ β_randomforest.I+ β_xgboost.I+ β_adaboost.I+ β_logistic.I+ β_logisticnet.I+ β_catboost.I) plot(dca_D, type = 'net_benefit', smooth = TRUE, show_ggplot_code = FALSE)+ ggtitle("Decision Curve Analysis of β_Models on Internal Data") + theme(plot.title = element_text(hjust = 0.5)) # # external # β_randomforest.E <- predict(modelb_rf_dddd, newdata = datawaibudddd, type = "prob")[,2] β_xgboost.E <- predict(modelb_xgb_dddd, newdata = datawaibudddd, type = "prob")[,2] β_adaboost.E <- predict(modelb_ada_dddd, newdata = datawaibudddd, type = "prob")[,2] β_logistic.E <- predict(modelb_logit_dddd, newdata = datawaibudddd, type = "prob")[,2] β_logisticnet.E <- predict(modelb_lgn_dddd, newdata = datawaibudddd, type = "prob")[,2] β_catboost.E<-pred_probCATDD # dca_DD <- dca(data =data_waibu_qianbanjie, feiyan_binary ~ β_randomforest.E+ β_xgboost.E+ β_adaboost.E+ β_logistic.E+ β_logisticnet.E+ β_catboost.E) plot(dca_DD, type = 'net_benefit', smooth = TRUE, show_ggplot_code = FALSE)+ ggtitle("Decision Curve Analysis of β_Models on External Data") + theme(plot.title = element_text(hjust = 0.5)) # # calibration plot # # internal # new_data_x$feiyan_binary <- as.factor(new_data_x$feiyan_binary) head(new_data_x$feiyan_binary) lift_resultsD <- data.frame(Class = as.factor((as.numeric(new_data_x$feiyan_binary)))) # randomforest AUC = 1，it is overflit，with y=x line, will be error in codes # so just other models lift_resultsD$xgboost <- β_xgboost.I lift_resultsD$adaboost <- β_adaboost.I lift_resultsD$logistic <- β_logistic.I lift_resultsD$logisticnet <- β_logisticnet.I lift_resultsD$catboost <- β_catboost.I lift_resultsD<-data.frame(lift_resultsD) head(lift_resultsD) lift_resultsD$Class <- as.factor(lift_resultsD$Class) calculate_calibrationn <- function(predictor, data) { fit_call <- lrm(Class ~ data[[predictor]], data = data, x = TRUE, y = TRUE) calibrationn <- calibrate(fit_call, cmethod="boot", B=1000) predictedd <- calibrationn[, "predy"] calibratedd <- calibrationn[, "calibrated.orig"] return(data.frame(Predicted = predictedd, Calibrated = calibratedd, Model = predictor)) } calibration_dataD <- NULL models_call <- c("xgboost", "adaboost", "logistic", "logisticnet", "catboost") models_call for (model in models_call) { calibration_dataD <- rbind(calibration_dataD, calculate_calibrationn(model, lift_resultsD)) } ggplot(calibration_dataD, aes(x = Predicted, y = Calibrated, color = Model)) + geom_point(alpha = 0.5) + geom_abline(intercept = 0, slope = 1, color = "red") + labs(title = "Calibration Curves of β_Models on Internal Data", x = "Predicted Probability", y = "Actual Probability") + theme_minimal() # # external # lift_resultsDD <- data.frame(Class = as.factor((as.numeric(data_waibu_qianbanjie$feiyan_binary)))) lift_resultsDD$randomforest <-β_randomforest.E lift_resultsDD$xgboost <- β_xgboost.E lift_resultsDD$adaboost <- β_adaboost.E lift_resultsDD$logistic <- β_logistic.E lift_resultsDD$logisticnet <- β_logisticnet.E lift_resultsDD$catboost <- β_catboost.E head(lift_resultsDD) lift_resultsDD$Class <- as.factor(lift_resultsDD$Class) calculate_calibration_testt <- function(predictor, data) { fit_calll <- lrm(Class ~ data[[predictor]], data = data, x = TRUE, y = TRUE) calibrationnn <- calibrate(fit_calll, cmethod="boot", B=1000) predicteddd <- calibrationnn[, "predy"] calibrateddd <- calibrationnn[, "calibrated.orig"] return(data.frame(Predicted = predicteddd, Calibrated = calibrateddd, Model = predictor)) } calibration_data_testtD <- NULL models_cal_testt <- c("randomforest", "xgboost", "adaboost", "logistic", "logisticnet", "catboost") for (model in models_cal_testt) { calibration_data_testtD <- rbind(calibration_data_testtD, calculate_calibration_testt(model, lift_resultsDD)) } ggplot(calibration_data_testtD, aes(x = Predicted, y = Calibrated, color = Model)) + geom_point(alpha = 0.5) + geom_abline(intercept = 0, slope = 1, color = "red") + labs(title = "Calibration Curves of β_Models on External Data", x = "Predicted Probability", y = "Actual Probability") + theme_minimal() # # here to explain the machine learning model # # α_model can be explained by SHAP # shapviz.catboost.Model <- function(object, X_pred, X = X_pred, collapse = NULL, ...) { if (!requireNamespace("catboost", quietly = TRUE)) { stop("Package 'catboost' not installed") } stopifnot( "X must be a matrix or data.frame. It can't be an object of class catboost.Pool" = is.matrix(X) || is.data.frame(X), "X_pred must be a matrix, a data.frame, or a catboost.Pool" = is.matrix(X_pred) || is.data.frame(X_pred) || inherits(X_pred, "catboost.Pool"), "X_pred must have column names" = !is.null(colnames(X_pred)) ) if (!inherits(X_pred, "catboost.Pool")) { X_pred <- catboost.load_pool(X_pred) } S <- catboost.get_feature_importance(object, X_pred, type = "ShapValues", ...) # Call matrix method pp <- ncol(X_pred) + 1L baseline <- S[1L, pp] S <- S[, -pp, drop = FALSE] colnames(S) <- colnames(X_pred) shapviz(S, X = X, baseline = baseline, collapse = collapse) } head(new_data_x) shapAdata<-new_data_x[,-c(8,15)] head(shapAdata) shpCATA <- shapviz.catboost.Model(catA, X_pred = shapAdata) head(shpCATA$X) shplabels <- c("dyspnea","cough","age_dyspnea","altered_mental_status", "age_alteredmentalstatus","age_pharyngealdiscomfort","days", "tmax","age_cough","age_days","pharyngeal_discomfort", "age","age_tmax") sv_waterfall(shpCATA,row_id = 2) sv_force(shpCATA,row_id = 2) sv_importance(shpCATA,kind = "beeswarm")+ scale_y_discrete(labels = shplabels) # # β_model can be explained by RCS # calculate the delta of two model # dataab<-data.frame(datadddd) dataab$pr_cat_m2<-predictions_probD dataab$delta<-dataab$pr_cat_m2-dataab$pr_cat_m1 head(dataab) # line model first lmdelata <- lm(delta ~ crp_plt_ratio + nlr + pr_cat_m1, data = dataab) summary(lmdelata) # delta with crp_plt_ratio plot(dataab$crp_plt_ratio, dataab$delta, main = "Delta vs CRP/PLT Ratio", xlab = "CRP/PLT Ratio", ylab = "Delta") abline(lm(delta ~ crp_plt_ratio, data = dataab), col = "blue") # delta with nlr plot(dataab$nlr, dataab$delta, main = "Delta vs NLR", xlab = "NLR", ylab = "Delta") abline(lm(delta ~ nlr, data = dataab), col = "green") # delta with Pred_α plot(dataab$pr_cat_m1, dataab$delta, main = "Delta vs Pred_α", xlab = "Pred_α", ylab = "Delta") abline(lm(delta ~ pr_cat_m1, data = dataab), col = "red") # not line，now for rcs dd <- datadist(dataab) options(datadist = "dd") model_rcs <- ols(delta ~rcs(crp_plt_ratio) + rcs(nlr) + rcs(pr_cat_m1), data = dataab, x = TRUE, y = TRUE) summary(model_rcs) anova(model_rcs) # #Analysis of Variance Response: delta #Factor d.f. Partial SS MS F P #crp_plt_ratio 4 8.7427022 2.18567555 192.49 <.0001 #Nonlinear 3 0.3955889 0.13186295 11.61 <.0001 #nlr 4 1.3567552 0.33918879 29.87 <.0001 #Nonlinear 3 0.1360527 0.04535090 3.99 0.0076 #pr_cat_m1 4 0.4329323 0.10823308 9.53 <.0001 #Nonlinear 3 0.4262000 0.14206668 12.51 <.0001 #TOTAL NONLINEAR 9 1.0336288 0.11484764 10.11 <.0001 #REGRESSION 12 17.5381101 1.46150918 128.71 <.0001 #ERROR 1768 20.0753841 0.01135486 # Pred_α with delta Pred_α_pred <- Predict(model_rcs, pr_cat_m1, ref.zero = TRUE) Pred_α_plot<-ggplot() + geom_line(data = Pred_α_pred, aes(x = pr_cat_m1, y = yhat), color = "blue") + geom_ribbon(data = Pred_α_pred, aes(x = pr_cat_m1, ymin = lower, ymax = upper), alpha = 0.2, fill = "blue") + labs(title = "RCS Regression of Pred_α with α/β Model's Predicted Probability Delta", x = "Pred_α", y = "Predicted Delta") + annotate("text", x = max(Pred_α_pred$pr_cat_m1) * 0.8, y = max(Pred_α_pred$yhat) * 0.8, label = paste("Non-linear F = 12.51, p < 0.001"), color = "black", size = 4) + theme_minimal() # crp_plt_ratio with delta crp_pred <- Predict(model_rcs, crp_plt_ratio, ref.zero = TRUE) crp_plt_ratio_plot<-ggplot() + geom_line(data = crp_pred, aes(x = crp_plt_ratio, y = yhat), color = "red") + geom_ribbon(data = crp_pred, aes(x = crp_plt_ratio, ymin = lower, ymax = upper), alpha = 0.2, fill = "red") + labs(title = "RCS Regression of CRP/PLT with α/β Model's Predicted Probability Delta", x = "CRP/PLT", y = "Predicted Delta") + annotate("text", x = max(crp_pred$crp_plt_ratio) * 0.8, y = max(crp_pred$yhat) * 0.8, label = paste("Non-linear F = 11.61, p < 0.001"), color = "black", size = 4) + theme_minimal() # nlr with delta nlr_pred <- Predict(model_rcs, nlr, ref.zero = TRUE) nlr_plot<-ggplot() + geom_line(data = nlr_pred, aes(x = nlr, y = yhat), color = "green") + geom_ribbon(data = nlr_pred, aes(x = nlr, ymin = lower, ymax = upper), alpha = 0.2, fill = "green") + labs(title = "RCS Regression of NLR with α/β Model's Predicted Probability Delta", x = "NLR", y = "Predicted Delta") + annotate("text", x = max(nlr_pred$nlr) * 0.8, y = max(nlr_pred$yhat) * 0.8, label = paste("Non-linear F = 3.99, p = 0.008"), color = "black", size = 4) + theme_minimal() combined_plot_rcs <- Pred_α_plot / crp_plt_ratio_plot / nlr_plot combined_plot_rcs <- combined_plot_rcs & theme(plot.title = element_text(size = 12)) & plot_layout(guides = "collect") print(combined_plot_rcs) # # here to do lca, to annalyze the subtype # head(data_waibu_qianbanjie) datawb_comp<-data_waibu_qianbanjie datawb_comp<-data_waibu_qianbanjie%>% select(feiyan,age,days,tmax,yanbubushi,kesou,qichuan,shenzhiyichang, age_tmax,age_days,age_shenzhiyichang,age_yanbubushi,age_kesou,age_qichuan, nlr,crp,plt,crp_plt_ratio) datawb_comp$yanbubushi<-as.factor(datawb_comp$yanbubushi) datawb_comp$kesou<-as.factor(datawb_comp$kesou) datawb_comp$qichuan<-as.factor(datawb_comp$qichuan) datawb_comp$shenzhiyichang<-as.factor(datawb_comp$shenzhiyichang) wb_jx<-compareGroups(feiyan~.,data=datawb_comp) wb_jx_table<-createTable(wb_jx,show.ratio=TRUE) print(wb_jx_table,which.table="descr") head(new_data_x) head(datadddd) data_in<-data.frame(new_data_x) data_in$nlr<-datadddd$nlr data_in$crp_plt_ratio<-datadddd$crp_plt_ratio data_in$pred_α<-predictions_probA data_in$pred_β<-predictions_probD data_in<-data_in %>% select(-feiyan) new_colnames <- c("Days", "Age", "Tmax", "Pharyngeal_discomfort", "Cough", "Dyspnea", "Altered_mental_status", "Age_Tmax", "Age_Days", "Age_Alteredmentalstatus", "Age_Pharyngealdiscomfort", "Age_Cough", "Age_Dyspnea", "Pneumonia", "NLR", "CRP_Plt_Ratio","Pred_α","Pred_β") colnames(data_in) <- new_colnames head(data_in) head(data_jx) data_in$Heat_feeling <- data_jx$fare data_in$Cold_feeling <- data_jx$wuhan data_in$Head_body_pain <- data_jx$toushentong data_in$Chest_pain <- data_jx$xiongtong data_in$Abdominal_pain <- data_jx$futong data_in$Nasal_congestion <- data_jx$biseliuti data_in$Chest_tightness <- data_jx$xiongmen data_in$Nausea_and_vomiting <- data_jx$exinoutu data_in$Diarrhea <- data_jx$fuxie data_in$Fatigue <- data_jx$fali data_in$Poor_appetite <- data_jx$nacha head(data_in) data_in$ID <- 1:nrow(data_in) data_lca <- data_in[, c("Pharyngeal_discomfort", "Cough", "Dyspnea", "Altered_mental_status", "Pneumonia", "Heat_feeling", "Cold_feeling", "Head_body_pain", "Chest_pain", "Abdominal_pain", "Nasal_congestion", "Chest_tightness", "Nausea_and_vomiting", "Diarrhea", "Fatigue", "Poor_appetite", "ID")] data_lca <- na.omit(data_lca) head(data_lca) str(data_lca) data_lca_transformed <- data_lca columns <- names(data_lca_transformed) for (col in columns) { if (is.factor(data_lca_transformed[[col]])) { data_lca_transformed[[col]] <- as.numeric(as.character(data_lca_transformed[[col]])) + 1 } else { data_lca_transformed[[col]] <- data_lca_transformed[[col]] + 1 } } # 2 lacent lca_result <- poLCA(cbind(Pneumonia,Pharyngeal_discomfort, Cough, Dyspnea, Altered_mental_status, Heat_feeling, Cold_feeling, Head_body_pain, Chest_pain, Abdominal_pain, Nasal_congestion, Chest_tightness, Nausea_and_vomiting, Diarrhea, Fatigue, Poor_appetite) ~ 1, data = data_lca_transformed, nclass = 2) summary(lca_result) plot(lca_result) lca_conditional_prob <- lca_result[["probs"]] lca_prob_data <- data.frame() for (symptom in names(lca_conditional_prob)) { lca_class_probs <- lca_conditional_prob[[symptom]] for (class in 1:2) { # lca_prob_data <- rbind(lca_prob_data, data.frame( Symptom = symptom, Class = class, Probability = lca_class_probs[class, "Pr(2)"] )) } } lca_prob_data <- dplyr::as_tibble(lca_prob_data) class_1_probs <- lca_prob_data %>% filter(Class == 1) %>% arrange(desc(Probability)) lca_prob_data <- lca_prob_data %>% mutate(Symptom = factor(Symptom, levels = class_1_probs$Symptom)) ggplot(lca_prob_data, aes(x = Symptom, y = Probability, group = Class, color = as.factor(Class))) + geom_line(size = 1) + geom_point(size = 3) + labs(title = "LCA's Probability Difference of Pneumonia ornot Patients", x = "Symptom", y = "Probability of Symptom Occurrence", color = "Class") + theme_minimal() + theme(axis.text.x = element_text(angle = 60, vjust = 0.5)) + scale_color_manual(values = c("blue", "red"), labels = c("1: Not Pneumonia","2: Pneumonia")) head(data_jx) data_hot<-data.frame(data_jx) data_hot$αpred<-predictions_probA data_hot$βpred<-predictions_probD str(data_hot) data_hot_numeric <- data_hot factor_columns <- sapply(data_hot, is.factor) data_hot_numeric[factor_columns] <- lapply(data_hot[factor_columns], as.numeric) variable_mapping <- c(feiyan = "pneunomia",days = "days",sex = "sex",age = "age",tmax = "tmax", shenzhiyichang = "altered_mental_status",days = "days", yanbubushi = "pharyngeal_discomfort", kesou = "cough",qichuan = "dyspnea",sex = "sex",xuanfeijiebiao = "TCM_XFJB", xinxueguan = "cardiovascular_disease",huxi = "respiratory_disease",jierezhentong = "used_antipyretics", fali = "fatigue",xierejiedu = "TCM_XRJD",fare = "heat_feeling",kangshengsu = "used_antibiotics", neifenmi = "endocrine_disease",toushentong = "headache_and_body_pain",shenjing = "neurological_disease", fuxie = "diarrhea",yongyaoshi = "medication_history",wuhan = "cold_feeling",futong = "abdominal_pain", zhongliumianyi = "oncological_or_immune_diseases",xueye = "blood_disorders",biseliuti = "nasal_congestion", shenzang = "kidney_disease",exinoutu = "nausea_and_vomiting",kangbingdu = "used_antivirals", xiongtong = "chest_pain",xiongmen = "chest_tightness",nacha = "poor_appetite",wenlisanhan = "TCM_WLSH", αpred = "α_pred",βpred = "β_pred" ) names(data_hot_numeric) <- variable_mapping[names(data_hot_numeric)] data_hot_numeric<-data_hot_numeric %>% select(-c(β_pred,α_pred)) data_hot_numeric$crp_plt_ratio<-datab$crp_plt_ratio data_hot_numeric$nlr<-datab$nlr data_hot_numeric$plt<-datab$plt data_hot_numeric$crp<-datab$crp data_hot_numeric$lym<-datab$lym data_hot_numeric$neu<-datab$gr data_hot_numeric$wbc<-datab$wbc head(data_hot_numeric) cor_matrix <- cor(data_hot_numeric, use = "complete.obs", method = "pearson") cor_matrix_long <- melt(cor_matrix) ggplot(cor_matrix_long, aes(x = Var1, y = Var2, fill = value)) + geom_tile() + scale_fill_gradient2(low = "blue", high = "red", mid = "white", midpoint = 0, limit = c(-1, 1)) + theme_minimal() + theme(axis.text.x = element_text(angle = 45, hjust = 1)) + labs(title = "Correlation Heatmap of Training Cohort", fill = "Correlation") data_pneumonia <- data_lca[data_lca$Pneumonia == 1, ] data_pneumonia <- data_pneumonia %>% mutate(across(-ID, as.factor)) str(data_pneumonia) data_pneumonia_transformed <- data_pneumonia columns_pneumonia <- names(data_pneumonia_transformed) for (col in columns_pneumonia) { if (is.factor(data_pneumonia_transformed[[col]])) { data_pneumonia_transformed[[col]] <- as.numeric(as.character(data_pneumonia_transformed[[col]])) + 1 } else { data_pneumonia_transformed[[col]] <- data_pneumonia_transformed[[col]] + 1 } } str(data_pneumonia_transformed) # 3 lacent pneumonia_result <- poLCA(cbind(Pharyngeal_discomfort, Cough, Dyspnea, Altered_mental_status, Heat_feeling, Cold_feeling, Head_body_pain, Chest_pain, Abdominal_pain, Nasal_congestion, Chest_tightness, Nausea_and_vomiting, Diarrhea, Fatigue, Poor_appetite) ~ 1, data = data_pneumonia_transformed, nclass = 3) pneumonia_result summary(pneumonia_result) plot(pneumonia_result) conditional_prob <- pneumonia_result[["probs"]] prob_data <- data.frame() for (symptom in names(conditional_prob)) { class_probs <- conditional_prob[[symptom]] for (class in 1:3) { prob_data <- rbind(prob_data, data.frame( Symptom = symptom, Class = class, Probability = class_probs[class, "Pr(2)"] )) } } prob_data <- dplyr::as_tibble(prob_data) class_3_probs <- prob_data %>% filter(Class == 3) %>% arrange(desc(Probability)) prob_data <- prob_data %>% mutate(Symptom = factor(Symptom, levels = class_3_probs$Symptom)) ggplot(prob_data, aes(x = Symptom, y = Probability, group = Class, color = as.factor(Class))) + geom_line(size = 1) + geom_point(size = 3) + labs(title = "LCA's Probability Difference of Cold/Heat Syndrome among Pneumonia Patients", x = "Symptom", y = "Probability of Symptom Occurrence", color = "Class") + theme_minimal() + theme(axis.text.x = element_text(angle = 60, vjust = 0.5)) + scale_color_manual(values = c("darkgray","blue", "red"), labels = c("1: Cannot Differ","2: Cold Syndrome", "3: Heat Syndrome")) posterior_probs <- pneumonia_result[["posterior"]] predicted_classes_lca <- apply(posterior_probs, 1, which.max) predicted_classes_lca <- as.factor(predicted_classes_lca) data_pneumonia$class<-predicted_classes_lca head(data_pneumonia) str(data_pneumonia) data_pneumonia <- data_pneumonia %>% mutate(across(-ID, as.factor)) str(data_pneumonia) result_lc <- left_join(data_in, data_pneumonia, by = "ID") result_lc <- na.omit(result_lc) result_lc <- result_lc %>% select(-ends_with(".y")) result_lc <- result_lc %>% rename_with(~ gsub("\\.x$", "", .x)) head(result_lc) result_lc$Pneumonia<-as.factor(result_lc$Pneumonia) result_lc$Pharyngeal_discomfort<-as.factor(result_lc$Pharyngeal_discomfort) result_lc$Cough<-as.factor(result_lc$Cough) result_lc$Dyspnea<-as.factor(result_lc$Dyspnea) result_lc$Altered_mental_status<-as.factor(result_lc$Altered_mental_status) result_lc$Days<-as.numeric(result_lc$Days) result_lc$Age<-as.numeric(result_lc$Age) result_lc$Age_Days<-as.numeric(result_lc$Age_Days) result_lc$Age_Alteredmentalstatus<-as.numeric(result_lc$Age_Alteredmentalstatus) result_lc$Age_Pharyngealdiscomfort<-as.numeric(result_lc$Age_Pharyngealdiscomfort) result_lc$Age_Cough<-as.numeric(result_lc$Age_Cough) result_lc$Age_Dyspnea<-as.numeric(result_lc$Age_Dyspnea) str(result_lc) result_lc <- result_lc %>% mutate(heat = case_when( class == 2 ~ 0, class == 3 ~ 1 )) result_lc <- result_lc %>% mutate(mentalf = case_when( class == 1 ~ 1, class == 2 ~ 0, class == 3 ~ 0 )) head(result_lc) summary_stats <- result_lc %>% group_by(class) %>% summarise(across(where(is.numeric), list(mean = mean, median = median, sd = sd, n = ~sum(!is.na(.x))))) print(summary_stats) head(summary_stats) data_lc_cp <- result_lc %>% select(heat, Pred_α, Pred_β) data_lc_cp <- na.omit(data_lc_cp) head(data_lc_cp) # Pred_α difference mw_test_α <- wilcox.test(Pred_α ~ heat, data = data_lc_cp) print(mw_test_α) # W = 2685, p-value = 0.1991 # Pred_β difference mw_test_β <- wilcox.test(Pred_β ~ heat, data = data_lc_cp) print(mw_test_β) # W = 3078, p-value = 0.7451 # data_lc_mt data_lc_mt <- result_lc %>% select(mentalf, Pred_α, Pred_β) data_lc_mt <- na.omit(data_lc_mt) head(data_lc_mt) # Pred_α difference mw_test_α_mt <- wilcox.test(Pred_α ~ mentalf, data = data_lc_mt) print(mw_test_α_mt) # W = 2851.5, p-value = 3.783e-12 # Pred_β difference mw_test_β_mt <- wilcox.test(Pred_β ~ mentalf, data = data_lc_mt) print(mw_test_β_mt) # W = 2931, p-value = 9.154e-12 result_lc_cpr<-compareGroups(class~.,data=result_lc) result_lc_cpr_table<-createTable(result_lc_cpr,show.ratio=TRUE) print(result_lc_cpr_table,which.table="descr")