# define your files' location chemin <- '/Users/caupiais/Dropbox/THESE-CAMILLE/THESE_Betadose/BETADOSE-EE/Betadose-EE_Valorisation/Article/Soumission2-BMCmrm/3eme-soumission/code-publi/' # packages ---------------------------------------------------------------------------------------------------------------------------------------- library(betareg) library(flexmix) library(plyr) library(rstan) library(xtable) options(xtable.floating = FALSE) options(xtable.timestamp = "") ################################################################################################################################################################################################################## ####################################################################### PART A ####################################################################### ####################################################################### Fit margins from experts' elicitation ####################################################################### ################################################################################################################################################################################################################## # Load data base for experts' answers; or simulate using the above code (Data set E1 for experts) ---------------------------------------------- scenario.exp <- 'e1' mu = 0.20 phi = 50 a = mu*phi b = phi*(1-mu) a b SED = 49 set.seed(SED) x=seq(0.0001, 0.9999, 0.0001) y=rbeta(44, shape1=a, shape2=b) e1= round(y, 2) # Modeling Safety Margins from experts elicitation ------------------------------------------------------------------------------------------------------- # create the functions to compare the criteria for goodness of fit auc.hist.center = function(y){ # Area under the curve of an histogram {x <- rep(0.01, 101) hist <- hist (y, freq = FALSE, breaks = seq(-0.005, to = 1.005, by = 0.01), right = T) y <- hist$density } x*y } auc.dbeta.center = function(a, b) # Area under the curve of a beta distribution { auc <- NULL int <- integrate(dbeta, shape1 = a, shape2 = b, lower = 0, upper = 0.005) int <- int$value auc <- c(auc, int) x2 <- seq(0.005, to = 0.995, by = 0.01) for (l in x2) { int2 <- integrate(dbeta, shape1 = a, shape2 = b, lower = l, upper = l+0.01) int2 <- int2$value auc <- c(auc, int2) } return(auc) } auc.dbeta.mix.center = function(a1, b1, a2, b2, w) # Area under the curve of a mixture of 2 beta distributions { auc <- NULL betamix4 <- function(y, a1, b1, a2, b2, w){ w * dbeta(y, shape1 = a1, shape2 = b1) + (1-w) * dbeta(y, shape1 = a2, shape2 = b2) } int <- integrate(betamix4, lower = 0, upper = 0.005, w = w, a1 = a1, b1 = b1, a2 = a2, b2 = b2) int <- int$value auc <- c(auc, int) x2 <- seq(0.005, to = 0.995, by = 0.01) for (l in x2) { betamix4 <- function(y, a1, b1, a2, b2, w){ w * dbeta(y, shape1 = a1, shape2 = b1) + (1-w) * dbeta(y, shape1 = a2, shape2 = b2) } int2 <- try(integrate(betamix4, lower = l, upper = l+0.01, w = w, a1 = a1, b1 = b1, a2 = a2, b2 = b2)) if(isTRUE(class(int2)=="try-error") ) { next } else { int2 <- int2$value auc <- c(auc, int2) } } return(auc) } auc.dbeta.mix3.center = function(a1, b1, a2, b2, a3, b3, w1, w2) # Area under the curve of a mixture of 3 beta distributions { auc <- NULL betamix5 <- function(y, a1, b1, a2, b2, a3, b3, w1, w2){ w1 * dbeta(y, shape1 = a1, shape2 = b1) + w2 * dbeta(y, shape1 = a2, shape2 = b2) + (1-w1-w2) * dbeta(y, shape1 = a3, shape2 = b3) } int <- integrate(betamix5, lower = 0, upper = 0.005, w1 = w1, w2 = w2, a1 = a1, b1 = b1, a2 = a2, b2 = b2, a3 = a3, b3 = b3) int <- int$value auc <- c(auc, int) x2 <- seq(0.005, to = 0.995, by = 0.01) for (l in x2) { betamix5 <- function(y, a1, b1, a2, b2, a3, b3, w1, w2){ w1 * dbeta(y, shape1 = a1, shape2 = b1) + w2 * dbeta(y, shape1 = a2, shape2 = b2) + (1-w1-w2) * dbeta(y, shape1 = a3, shape2 = b3) } int2 <- try(integrate(betamix5, lower = l, upper = l+0.01, w1 = w1, w2 = w2, a1 = a1, b1 = b1, a2 = a2, b2 = b2, a3 = a3, b3 = b3)) if(isTRUE(class(int2)=="try-error") ) { next } else { int2 <- int2$value auc <- c(auc, int2) } } return(auc) } compar.auc.center = function (y, data) { # Compare AUC histogram and AUC of mixture of beta distributions using the 3 options (Option betamix function,Option manual mixture of 2 betareg function,Option manual mixture of a betamix function and a betareg function) # and extract the option with the best criteria value <- sort(as.numeric(levels(as.factor(y)))) imin <- value[3] imin3 <- value[4] imax <- value[length(value)-1] imax3 <- value[length(value)-2] auc.hist <- auc.hist.center(y) # auc histogramme y.data <- as.data.frame(y) beta1 <- betamix (y.data ~ 1 , data = y.data, k = 1, link = "logit") # Fit = Option betamix function mu.beta1<- plogis(coef(beta1)[1]) phi.beta1<- exp(coef(beta1)[2]) a.beta1<- mu.beta1 * phi.beta1 b.beta1 <- (1 - mu.beta1) * phi.beta1 auc.dbeta1 <- auc.dbeta.center(a = a.beta1, b = b.beta1) diff <- sum(abs(auc.dbeta1- auc.hist)) nbeta <- 1 seuil1 <- NA w = NA a1 <- a.beta1 b1 <- b.beta1 a2 <- NA b2 <- NA line <- cbind(nbeta, seuil1, w, diff, a1, b1, a2, b2) tab2 <- NULL # Fit = Option manual mixture of 2 betareg function for (i in seq (from = imin, to = imax, by = 0.01)) { # i = level for dichotomization of observed values y1 <- as.data.frame(y.data[y.data=i]) for (j in seq (from = 0, to = 1, by = 0.05)) { first.beta2 <- betamix(y1~ 1, data = y1, k = 1, link = "logit") first.mu.beta2 <- plogis(coef(first.beta2)[1]) first.phi.beta2 <- exp(coef(first.beta2)[2]) first.a.beta2<- first.mu.beta2 * first.phi.beta2 first.b.beta2 <- (1 - first.mu.beta2 ) * first.phi.beta2 second.beta2 <- betamix(y2 ~ 1 , data = y2, k = 1, link = "logit") second.mu.beta2 <- plogis(coef(second.beta2)[1]) second.phi.beta2 <- exp(coef(second.beta2)[2]) second.a.beta2 <- second.mu.beta2 * second.phi.beta2 second.b.beta2 <- (1 - second.mu.beta2 ) * second.phi.beta2 auc.dbeta2 <- auc.dbeta.mix.center(a1 = first.a.beta2, b1 = first.b.beta2, a2 = second.a.beta2, b2 = second.b.beta2, w = j) diff <- sum(abs(auc.dbeta2 - auc.hist)) nbeta <- 2 seuil1 <- i w <- j a1 <- first.a.beta2 b1 <- first.b.beta2 a2 <- second.a.beta2 b2 <- second.b.beta2 line2 <- cbind(nbeta, seuil1, w, diff, a1, b1, a2, b2) tab2 <- rbind.data.frame(tab2, line2) } } table <- rbind (line, tab2) min <- min(table$diff) best.auc <- table[table$diff == min , ] return(best.auc) } # Fit margins from experts' elicitation ----------------------------------------------------------------------------------------------------------------------------------------------------- auc.hist <- auc.hist.center(e1) # AUC of histogram auto <- betamix(e1 ~ 1 , k = 1:3, nstart = 10, link = "logit") # Option betamix function nbeta <-auto[["flexmix"]]@k0 beta1 <- betamix(e1 ~ 1 , k = nbeta, nstart = 10, link = "logit") if (nbeta == 1) { m1 <- plogis(coef(beta1)[1]) phi1 <- exp(coef(beta1)[2]) a1<- m1 * phi1 b1 <- (1 - m1) * phi1 auc.dbeta1 <- auc.dbeta.center(a = a1, b = b1) diff <- sum(abs(auc.dbeta1 - auc.hist)) #diff = criteria of goodness of fit seuil1 <- NA w1 <- 1 w2 <- 0 a2 <- a1 b2 <- b1 a3 <- a1 b3 <- b1 option <- "betamix" option.betamix <- cbind.data.frame(option, nbeta, seuil1, w1, w2, diff, a1, b1, a2, b2, a3, b3) # extract the betamix function with the best criteria of goodness of fit } if (nbeta == 2) { m <- plogis(coef(beta1)[,1]) phi <- exp(coef(beta1)[,2]) a<- m * phi b <- (1 - m) * phi auc.dbeta1 <- auc.dbeta.mix.center(w = prior(beta1$flexmix)[1], a1 = a[1], b1 = b[1], a2 = a[2], b2 = b[2]) diff <- sum(abs(auc.dbeta1 - auc.hist)) seuil1 <- NA a1 <- a[1] b1 <- b[1] a2 <- a[2] b2 <- b[2] option <- "betamix" w1 <- prior(beta1$flexmix)[1] w2 <- 0 a3 <- a2 b3 <- b2 option.betamix <- cbind.data.frame(option, nbeta, seuil1, w1, w2, diff, a1, b1, a2, b2, a3, b3) # extract the betamix function with the best criteria of goodness of fit } if (nbeta == 3) { m <- plogis(coef(beta1)[,1]) phi <- exp(coef(beta1)[,2]) a<- m * phi b <- (1 - m) * phi auc.dbeta1 <- auc.dbeta.mix3.center(w1 = prior(beta1$flexmix)[1], w2 = prior(beta1$flexmix)[2], a1 = a[1], b1 = b[1], a2 = a[2], b2 = b[2], a3 = a[3], b3 = b[3]) diff <- sum(abs(auc.dbeta1 - auc.hist)) seuil1 <- NA a1 <- a[1] b1 <- b[1] a2 <- a[2] b2 <- b[2] a3 <- a[3] b3 <- b[3] option <- "betamix" w1 <- prior(beta1$flexmix)[1] w2 <- prior(beta1$flexmix)[2] option.betamix <- cbind.data.frame(option, nbeta, seuil1, w1, w2, diff, a1, b1, a2, b2, a3, b3) # extract the betamix function with the best criteria of goodness of fit } best.auc <- compar.auc.center (y = e1) # Option manual mixture of 2 betareg function # extract the manual mixture with the best criteria of goodness of fit best.auc <-best.auc[1,] # take the first line if several mixtures with same criteria w2 <- 0 option <- "manual mixture of 2 betareg" option.manual <- cbind.data.frame(option, best.auc$nbeta, best.auc$seuil1, best.auc$w , w2, best.auc$diff, best.auc$a1, best.auc$b1, best.auc$a2, best.auc$b2, best.auc$a2, best.auc$b2) colnames(option.manual) <- c("option", "nbeta", "seuil1", "w1", "w2", "diff", "a1", "b1", "a2", "b2", "a3", "b3") best.auc$seuil1 # Option manual mixture of a betamix function and a betareg function data <- e1[e1 >= best.auc$seuil1] # extract the level for dichotomization of observed values option <- "manual mixture of betareg + betamix" beta3<-try(betamix(data ~ 1, k = 2, link = "logit")) # mixture above this threhold if (class(beta3)=="try-error") { option.manual.mix <- cbind.data.frame(option, NA, best.auc$seuil1, NA, NA, NA, NA, NA, NA, NA, NA, NA) colnames(option.manual.mix) <- c("option", "nbeta", "seuil1", "w1", "w2", "diff", "a1", "b1", "a2", "b2", "a3", "b3") } if (class(beta3)!="try-error") { p.beta3 <- prior(beta3$flexmix) w2 <- p.beta3[1] * (1-best.auc$w) mu.beta3 <- plogis(coef(beta3)[,1]) phi.beta3 <- exp(coef(beta3)[,2]) a.beta3 <- mu.beta3 * phi.beta3 b.beta3 <- (1 - mu.beta3) * phi.beta3 auc.dbeta3 <- auc.dbeta.mix3.center(w1 = best.auc$w, w2 = w2, a1 = best.auc$a1, b1 = best.auc$b1, a2 = a.beta3[1], b2 = b.beta3[1], a3 = a.beta3[2], b3 = b.beta3[2]) diff <- sum(abs(auc.dbeta3 - auc.hist)) # diff <- criteria of goodness of fit option.manual.mix <- cbind.data.frame(option, best.auc$nbeta, best.auc$seuil1, best.auc$w, w2, diff, best.auc$a1, best.auc$b1, a.beta3[1], b.beta3[1], a.beta3[2], b.beta3[2]) colnames(option.manual.mix) <- c("option", "nbeta", "seuil1", "w1", "w2", "diff", "a1", "b1", "a2", "b2", "a3", "b3") } option3 <- rbind(option.betamix, option.manual, option.manual.mix) option3.noNA <- option3[is.na(option3$diff)==F, ] best3 <- option3.noNA[option3.noNA$diff == min(option3.noNA$diff), ] # among the 3 methods, extract the mixture with the best criteria of goodness of fit best3 <- best3[1,] # save the parameters of the best mixture param.e1 <- cbind.data.frame(scenario.exp, best3) # compute base with paramters for differetn data set of experts param.experts <- rbind.data.frame(param.e1) eval(parse(text = paste("save (param.experts, file='", chemin , "param.simul.experts.Rdata')",sep=""))) ################################################################################################################################################################################################################## ####################################################################### PART B ####################################################################### ####################################################################### Compute the differences of the posterior samplers for M pairs ####################################################################### ################################################################################################################################################################################################################## scenari <- c("T1") # list the different scenari experts <- c("e1") # list the different data set of experts priori <- c("prior9") # list the different prior TR <- 10 # number of trials # Load data base of the trial ; or simulate using the above code (scenario T1) ------------------------------------------------------------------------------------------------ N = 3146 # sample size pgrp = 0.5 # proba grp p1 = 0.10 # proba prema groupe 1 p2 = 0.3666 # (proba prema groupe 2 !!!!!!! si pas groupe 1 = 0.33/0.90 ) pDEATH1 <- 0.39 # proba death in full dose born < 28 pDEATH2 <- 0.05 # proba death in full dose born 28-32 pDEATH3 <- 0.005 # proba death in full dose born >= 32 pDEATH1_hd <- pDEATH1 * 1.2 # proba death in half dose born < 28 pDEATH2_hd <- pDEATH2 * 1.2 # proba death in half dose born 28-32 pDEATH3_hd <- pDEATH3 * 1.2 # proba death in half dose born >= 32 SED = 387 for (tr in 1:TR) { set.seed(SED) tab <- NULL for (i in 1:N){ a = rbinom(1,1,prob=pgrp) # to decide the grp if (a==1) { g = rbinom(1,1,prob=p1) # to decide the subgroup of term if (g==1) { grp <- 1 group <- 9 TERME <- 1 DEATH <- rbinom(1,1,pDEATH1) pat = c(i, g, group, TERME, DEATH, a, grp) # collect all data for the same patient } if (g==0) { group = rbinom(1,1,prob=p2) if (group == 1) { grp <- 1 TERME <- 2 DEATH <- rbinom(1,1,pDEATH2) pat = c(i, g, group, TERME, DEATH, a, grp) # collect all data for the same patient } if (group == 0) { grp <- 1 TERME <- 3 DEATH <- rbinom(1,1,pDEATH3) pat = c(i, g, group, TERME, DEATH, a, grp) # collect all data for the same patient } } } if (a==0) { g = rbinom(1,1,prob=p1) # to decide the subgroup of term if (g==1) { grp <- 2 group <- 9 TERME <- 1 DEATH <- rbinom(1,1,pDEATH1_hd) pat = c(i, g, group, TERME, DEATH, a, grp) # collect all data for the same patient } if (g==0) { group = rbinom(1,1,prob=p2) if (group == 1) { grp <- 2 TERME <- 2 DEATH <- rbinom(1,1,pDEATH2_hd) pat = c(i, g, group, TERME, DEATH, a, grp) # collect all data for the same patient } if (group == 0) { grp <- 2 TERME <- 3 DEATH <- rbinom(1,1,pDEATH3_hd) pat = c(i, g, group, TERME, DEATH, a, grp) # collect all data for the same patient } } } tab <- rbind(tab,pat) #to put patients in a dataset. Each row is a pat colnames(tab)=c("i", "g", "group", "TERME", "DECES", "a", "grp") data <- as.data.frame(tab) eval(parse(text = paste("save (data, file='", chemin , "SimulT1_t", tr, ".Rdata')",sep=""))) } SED = SED + tr } # creating variable attribuating the number of the analyse to each obsevation (random) for (scenario in scenari){ for (tr in 1:TR) { eval(parse(text = paste("load('", chemin , "Simul", scenario, "_t", tr, ".Rdata')",sep=""))) data <- data data <- data [ ,c("i", "TERME", "grp", "DECES")] SEDi <- 35464 + tr ana <- c(rep(1, 300), rep(2, 300), rep(3, 300), rep(4, 300), rep(5, 300), rep(6, 300), rep(7, 300), rep(8, 300), rep(9, 300), rep(10, 300), rep(11, 146)) set.seed(SEDi) data$analyse <- sample (ana, 3146) data$scenario <- scenario data$trial <- tr eval(parse(text = paste("save (data, file='", chemin , "Simul", scenario, "_t", tr, ".Rdata')",sep=""))) } } # Create the stan model object using Stan's syntax --------------------------------------------------------------------------------------------------------------------------- stanmodelcode.bis = " data { // Data block int N1; // Sample size grp 1 int N2; // Sample size grp 2 int y1[N1] ; // Target variable int y2[N2] ; real afd ; real bfd ; real ahd ; real bhd ; } parameters { // Parameters block real p1; // arm1 real p2; // arm2 } transformed parameters { real diff; diff = p2-p1; } model { // Model block // likelihood y1 ~ bernoulli(p1); y2 ~ bernoulli(p2); // priors p1 ~ beta(afd , bfd); p2 ~ beta(ahd , bhd); } /* generated quantities { // Generated quantities block. Not used presently. } */ " # load table with prior parameters or create the table --------------------------------------------------------------------------------------------------------------------------- #eval(parse(text = paste("load('", chemin , "prior.9.RDS')",sep=""))) prior.ab <- c("death", 1, 29, 44, 32, 41) colnames(prior.ab) <- c("event", "term", "a.fd", "b.fd", "a.hd", "b.hd") # Run the stan model for each trial of the senario with the elect prior HERE prior 9 -------------------------------------------------------------------------------------------------------------------------------------------------- for (scenario in scenari){ for (tr in 1:TR) { # data eval(parse(text = paste("load('", chemin , "Simul", scenario, "_t", tr, ".Rdata')",sep=""))) for (k in 11:11) { # only the last analysis : if analyse <= k safe <- data[data$analyse <= k, ] # creating vectors for (i in 1:1) { # only terme == 1 (born before 28) for (j in 1:2) { eval(parse(text = paste("d_grp", j, "_term",i, " <- safe$DECES[safe$grp == j & safe$TERME == i & is.na(safe$DECES) ==F ]",sep=""))) } # Create the data list object for stan inupt eval(parse(text = paste("dat_d_term",i, " = list(N1=length(d_grp1_term", i , "), N2=length(d_grp2_term", i , "), y1=d_grp1_term", i, ", y2=d_grp2_term", i, ", afd=prior.ab$a.fd[prior.ab$event=='death' & prior.ab$term== i ], bfd=prior.ab$b.fd[prior.ab$event=='death' & prior.ab$term== i ], ahd=prior.ab$a.hd[prior.ab$event=='death' & prior.ab$term== i ], bhd=prior.ab$b.hd[prior.ab$event=='death' & prior.ab$term== i ])",sep=""))) } # Run the model and examine results # SED <- (2789 + tr + k) set.seed(SED) eval(parse(text = paste("fit_d_term1_analyse",k, "<- stan (model_code=stanmodelcode.bis, data=dat_d_term1, iter=4000, chains=3 , control = list(max_treedepth = 15))",sep=""))) # save stan fit eval(parse(text = paste("saveRDS(fit_d_term1_analyse",k, ", file = '" ,chemin , "fit_d_term1_scenario", scenario, "_trial", tr, "_analyse",k, ".prior9.rds')",sep=""))) } } } ################################################################################################################################################################################################################## ####################################################################### PART C ####################################################################### ####################################################################### Calculate the posterior probability that the difference of rate of events is higher ####################################################################### ####################################################################### than the acceptable difference according to experts ####################################################################### ################################################################################################################################################################################################################## # Load margins from experts: Beta distribution ------------------------------------------------------ eval(parse(text = paste("load(file='", chemin , "param.simul.experts.Rdata')",sep=""))) # Create the function for computing the probability ------------------------------------------------------ checking1 <- function(x,target,error) { sum(x>(target+error))/length(x) } # Calculate the posterior probability, using Stan stimulations proba_all_trial <- NULL for (p in 1:length(priori)){ prior <- priori[p] for (l in 1:length(scenari)){ scenario <- scenari[l] for (tr in 1:TR) { for (k in 11:11) { # k analyses # read stan fit eval(parse(text = paste("fit_d_term1_analyse",k, "<- readRDS(file = '", chemin , "fit_d_term1_scenario", scenario, "_trial", tr, "_analyse",k, ".", prior ,".rds')",sep=""))) eval(parse(text = paste("sampl_d_term1 <- extract(fit_d_term1_analyse", k, ", pars=c('p1', 'p2', 'diff'))", sep=""))) SED <- 123 + tr + l set.seed(SED) x1=runif(10000) # checking probability for each of the 3 scenarios on experts' answers for (e in 1:length(experts) ) { # checking with margin as distribution exp <- experts[e] data <- param.experts[param.experts$scenario.exp == exp, ] n=10000 a1=data$a1 b1=data$b1 a2=data$a2 b2=data$b2 a3=data$a3 b3=data$b3 w1=data$w1 w2=data$w2 temp = cbind(rbeta(n,a1,b1),rbeta(n,a2,b2),rbeta(n,a3,b3)) ##random generation of the indices id = sample(1:3,n,rep = T,prob = c(w1,w2,1-w1-w2)) id = cbind(1:n,id) x1 = temp[id] res_x1<-rep(NA,length(x1)) for(i in 1:length(x1)){ res_x1[i]=checking1(x=sampl_d_term1$diff, target= x1[i], error = 0) } pest_d_value_distrib <- mean(res_x1) # compute table with results analysis <- k trial <- tr proba_d1 <- cbind.data.frame (data$scenario.exp, pest_d_value_distrib, analysis, trial, scenario, prior) proba_all_trial <- rbind.data.frame(proba_d1, proba_all_trial) } } } } } colnames(proba_all_trial) <- c("scenario.exp" , "pest_d_value_distrib" , "analysis" , "trial" , "scenario", "prior") str(proba_all_trial) # apply the decision rule : here, we will decide that the difference is unacceptable if posterior probability >= O.5 --------------------------------------------------------------------- proba_all_trial$ccl50_distrib[proba_all_trial$pest_d_value_distrib>=0.50] <- 1 proba_all_trial$ccl50_distrib[proba_all_trial$pest_d_value_distrib < 0.50] <- 0 # save eval(parse(text = paste("save(proba_all_trial, file ='", chemin , "proba_all_trial')",sep="")))