################ ################ ################ #### Health Technology Assessment for fertility treatments #### Cost-effectiveness of stimulation agents for IUI #### Full function and all parameters provided, all supporting functions #### and R libraries are provided in a seperate file. #### Coded by: Rik van Eekelen, PhD #### Amsterdam UMC, Academic Medical Centre Amsterdam #### Last update: 21-07-2020 ################ ################ ################ ## Start with model parameters nsim=2e4 # Number of simulation replications # (needs to be sufficient to allow all possible combinations of parameter draws) ## Costs data ## These are our estimates, feel free to change as you wish. ## More details are in the Excel parameter file. costsCC <- 0.18*5*4 # costs for 4 cycles of IUI with CC costsFSH <- 32.76*8*4 # costs for 4 cycles of IUI with FSH costsFSHsd <- 60 costslet <- 0.2*5*4 # costs for 4 cycles of IUI with Letrozole costsMPmean <- (16419-3107)*1.078524 # Costs for multiple pregnancy delivery costsMPsd <- 250 # Expected variation in multiple pregnancy delivery costs in terms of a standard deviation base <- .246 # livebirth/ongoing pregnancy rate for trials with 4 cycles of IUI-OS using CC sebase <- sqrt(base*(1-base)/740) baseIPD <- .2975 # livebirth/ongoing pregnancy rate over 4 for trials that gave IPD sebaseIPD <- sqrt(baseIPD*(1-baseIPD)/1002) RRFSH=1.20 # Relative risk for FSH compared to CC with strict cancellation criteria (NMA, Danhof., 2020) RRFSH2=1.39 # Relative risk for FSH compared to CC (NMA, Danhof., 2020) RRlet=1.09 # Relative risk for Letrozole compared to CC (NMA, Danhof., 2020) seFSH <- (log(1.51)-log(1.20))/qnorm(.975) # Standard error around estimate from NMA (Danhof et al., 2020) seFSH2 <- (log(1.76)-log(1.39))/qnorm(.975) # Standard error around estimate from NMA (Danhof et al., 2020) selet <- (log(1.57)-log(1.09))/qnorm(.975) # Standard error around estimate from NMA (Danhof et al., 2020) RRFSHIPD <- 1.28 # Odds ratio obtained from IPD RRletIPD <- 0.80 # Odds ratio obtained from IPD seFSHIPD <- 0.09765 # Standard error obtained from IPD seletIPD <- 0.16248 # Standard error obtained from IPD cycles <- 4 # on average, 4 cycles conducted when protocol goes for 6 (Custers et al., 2006) cyclerate <- 140/1676 # livebirth/ongoing pregnancy rate per cycle from NMA (Danhof et al., 2020) cyclerateIPD <- 218/2580 # livebirth/ongoing pregnancy rate per cycle from IPD wd <-"E:/R code/" # Choose working directory setwd(wd) # Set working directory source("HTA_IUI_functions_clean.R") # Load functions from seperate R file # Full health economic model with all 3 agents at once #### Run simulation #### # Base scenario with rate per cycle, applied to 4 cycles set.seed(9451) res <- HTAfunc_OI(nsim=nsim,base=base,sebase=sebase,costsCC=costsCC,costsFSH=costsFSH,costsFSHsd=costsFSHsd, costslet=costslet,costsMPmean=costsMPmean,costsMPsd=costsMPsd,RRFSH=RRFSH,RRlet=RRlet, seFSH=seFSH,selet=selet,cycles=cycles,cycle=T) head(res) # With RR from all trials # set.seed(9) # res <- HTAfunc_OI(nsim=nsim,base=base,sebase=sebase,costsCC=costsCC,costsFSH=costsFSH,costsFSHsd=costsFSHsd, # costslet=costslet,costsMPmean=costsMPmean,costsMPsd=costsMPsd,RRFSH=RRFSH2,RRlet=RRlet, # seFSH=seFSH2,selet=selet,cycles=cycles,cycle=T) # head(res) # Over 2 cycles # set.seed(4823) # res <- HTAfunc_OI(nsim=nsim,base=base,sebase=sebase,costsCC=costsCC,costsFSH=costsFSH,costsFSHsd=costsFSHsd, # costslet=costslet,costsMPmean=costsMPmean,costsMPsd=costsMPsd,RRFSH=RRFSH,RRlet=RRlet, # seFSH=seFSH,selet=selet,cycles=2,cycle=T) # head(res) # Over 6 cycles # set.seed(255549) # res <- HTAfunc_OI(nsim=nsim,base=base,sebase=sebase,costsCC=costsCC,costsFSH=costsFSH, # costsFSHsd=costsFSHsd,costslet=costslet,costsMPmean=costsMPmean,costsMPsd=costsMPsd, # RRFSH=RRFSH,RRlet=RRlet,seFSH=seFSH,selet=selet,cycles=6,cycle=T) # head(res) # With livebirth rate from those 3 trials # set.seed(741282) # res <- HTAfunc_OI(nsim=nsim,base=base,sebase=sebase,costsCC=costsCC,costsFSH=costsFSH, # costsFSHsd=costsFSHsd,costslet=costslet,costsMPmean=costsMPmean,costsMPsd=costsMPsd,RRFSH=RRFSH, # RRlet=RRlet,seFSH=seFSH,selet=selet,cycles=cycles,cycle=F) # head(res) # With IPD parameters # set.seed(1111) # res <- HTAfunc_OI_IPD(nsim=nsim,base=baseIPD,sebase=sebaseIPD,costsCC=costsCC,costsFSH=costsFSH, # costsFSHsd=costsFSHsd,costslet=costslet,costsMPmean=costsMPmean,costsMPsd=costsMPsd,RRFSH=RRFSHIPD, # RRlet=RRletIPD,seFSH=seFSHIPD,selet=seletIPD,cycles=cycles,cycle=T) # head(res) ### Analyse results ### d <- data.frame(drugs=c("Clomiphene citrate","Letrozole","Gonadotrophins"),livebirth=rbind(mean(res$pCC), mean(res$plet),mean(res$pFSH)),costs=rbind(mean(res$cCC),mean(res$clet),mean(res$cFSH)), multiples=rbind(mean(res$mpCC),mean(res$mplet),mean(res$mpFSH))) d # For IPD parameters, because Letrozole now leads to the lowest chance of livebirth # d <- data.frame(drugs=c("Letrozole","Clomiphene citrate","Gonadotrophins"), # livebirth=rbind(mean(res$plet),mean(res$pCC),mean(res$pFSH)),costs=rbind(mean(res$clet), # mean(res$cCC),mean(res$cFSH)),multiples=rbind(mean(res$mplet),mean(res$mpCC),mean(res$mpFSH))) # d # Add ICER d$icer <- NA d$icer[1] <- 0 d$icer[2] <- (d$costs[2]-d$costs[1])/(d$livebirth[2]-d$livebirth[1]) d$icer[3] <- (d$costs[3]-d$costs[2])/(d$livebirth[3]-d$livebirth[2]) d icer <- d$icer # Calculate differences res$pdif1 <- res$plet-res$pCC res$cdif1 <- res$clet-res$cCC res$pdif2 <- res$pFSH-res$plet res$cdif2 <- res$cFSH-res$clet # For IPD parameters # res$pdif1 <- res$pCC-res$plet # res$cdif1 <- res$cCC-res$clet # res$pdif2 <- res$pFSH-res$pCC # res$cdif2 <- res$cFSH-res$cCC # Cost-effectiveness plane # plot(res$pdif1,res$cdif1,xlim=c(-.3,.4),ylim=c(-5000,5500),las=1, # xlab="Difference in chance of achieving live birth",ylab="Difference in average costs (EUR)",pch=2,col=2) # points(res$pdif2,res$cdif2,col=3,pch=3) # # legend(.11,4800,box.lty=0,legend=c("Letrozole vs. CC","FSH versus letrozole"),pch=2:3,col=2:4) # abline(h=0,lty=2,lwd=2) # abline(v=0,lty=2,lwd=2) # points(mean(res$pdif1),mean(res$cdif1),col=1,pch=20,lwd=4) # lines(quantile(res$pdif1,c(.025,.975)),rep(mean(res$cdif1),2),lwd=2) # lines(rep(mean(res$pdif1),2),quantile(res$cdif1,c(.025,.975)),lwd=2) # points(mean(res$pdif2),mean(res$cdif2),col=1,pch=20,lwd=4) # lines(quantile(res$pdif2,c(.025,.975)),rep(mean(res$cdif2),2),lwd=2) # lines(rep(mean(res$pdif2),2),quantile(res$cdif2,c(.025,.975)),lwd=2) # Percentage in each quadrant of the plane? q1 <- NA q1[res$plet>res$pCC & res$cletres$cCC] <- "Inferior" q1[res$pletres$pCC & res$clet>res$cCC] <- "North-east" q2 <- NA q2[res$pFSH>res$plet & res$cFSHres$clet] <- "Inferior" q2[res$pFSHres$plet & res$cFSH>res$clet] <- "North-east" round(table(q1)/nsim*100,1) round(table(q2)/nsim*100,1) # Percentage in each quadrant of the plane for IPD parameters # q1 <- NA # q1[res$pCC>res$plet & res$cCCres$clet] <- "Inferior" # q1[res$pCCres$plet & res$cCC>res$clet] <- "North-east" # q2 <- NA # q2[res$pFSH>res$pCC & res$cFSHres$cCC] <- "Inferior" # q2[res$pFSHres$pCC & res$cFSH>res$cCC] <- "North-east" # # round(table(q1)/nsim*100,1) # round(table(q2)/nsim*100,1) # Qantiles or interquartile range quantile(res$cdif1/res$pdif1,prob=c(.025,.5,.975)) quantile(res$cdif2/res$pdif2,prob=c(.025,.5,.975)) quantile(res$cdif1/res$pdif1,prob=c(.25,.5,.75)) quantile(res$cdif2/res$pdif2,prob=c(.25,.5,.75)) # Quickly create and print results table icer <- d$icer d$icer <- NA d$icer[1] <- paste("0 (reference)") d$icer[2] <- paste(round(icer[2],0)," (95%CI: ",round(quantile(res$cdif1/res$pdif1,prob=.025),0), " to ",round(quantile(res$cdif1/res$pdif1,prob=.975),0),")",sep="") d$icer[3] <- paste(round(icer[3],0)," (95%CI: ",round(quantile(res$cdif2/res$pdif2,prob=.025),0), " to ",round(quantile(res$cdif2/res$pdif2,prob=.975),0),")",sep="") d$livebirth <- d$livebirth*100 d$multiples <- d$multiples*100 d$costs <- round(d$costs,0) d printfunc(d,digits=1) # Prints a table you can copy/paste in your working directory #### #### Create net benefit curves #### Please note that this function is quite slow! It can take up to a couple of minutes to run. y <- seq(50,1e5,by=50) nb <- data.frame(nb1=rep(NA,nsim),nb2=NA,nb3=NA,best=NA) ceac <- data.frame(y=y,best1=NA,best2=NA,best3=NA) for(i in 1:length(y)){ nb$nb1 <- res$pCC*ceac$y[i]-res$cCC nb$nb2 <- res$plet*ceac$y[i]-res$clet nb$nb3 <- res$pFSH*ceac$y[i]-res$cFSH nb$best <- apply(nb[,1:3],1,which.max) ceac$best1[i] <- sum(nb$best==1)/nsim ceac$best2[i] <- sum(nb$best==2)/nsim ceac$best3[i] <- sum(nb$best==3)/nsim } mean(ceac$best1) mean(ceac$best2) mean(ceac$best3) # tiff("nb.tiff",width=7.5,height=5.8,units="in",res=300,compression="none") par(mfrow=c(1,1)) plot(y/1000,rep(-20,length(y)),ylim=c(-0.02,1.05),las=1,lwd=1,xlim=c(0,100), xlab="monetary value per live birth (x 1000 EUR)",ylab="probability of having the highest net benefit") grid() lines(y/1000,ceac$best1,lwd=3,col=2,lty=2) lines(y/1000,ceac$best2,lwd=3,col=3,lty=3) lines(y/1000,ceac$best3,lwd=3,col=4,lty=4) legend(2,1.04,box.lty=0,legend=d$drug,lwd=3,col=2:4,lty=c(2:4)) # legend(62,.55,box.lty=0,legend=c("Clomiphene citrate","Letrozole","Gonadotrophins"), # lwd=3,col=2:4,lty=c(2:4)) ## Frontier of 'best' options on the net benefit curve, easier to look at which(ceac$best1<=ceac$best2)[1] which(ceac$best2<=ceac$best3)[1] # tiff("nb_frontier.tiff",width=7.5,height=5.8,units="in",res=300,compression="none") # par(mfrow=c(1,1)) plot(y/1000,rep(-20,length(y)),ylim=c(-0.02,1.05),las=1,lwd=1,xlim=c(0,100), xlab="monetary value per live birth (x 1000 EUR)",ylab="probability of having the highest net benefit") grid() lines(y[1:which(ceac$best1<=ceac$best2)[1]]/1000, ceac$best1[1:which(ceac$best1<=ceac$best2)[1]],lwd=3,col=2,lty=2) lines(y[which(ceac$best1<=ceac$best2)[1]:which(ceac$best2<=ceac$best3)[1]]/1000, ceac$best2[which(ceac$best1<=ceac$best2)[1]:which(ceac$best2<=ceac$best3)[1]],lwd=3,col=3,lty=3) lines(y[which(ceac$best2<=ceac$best3)[1]:2000]/1000, ceac$best3[which(ceac$best2<=ceac$best3)[1]:2000],lwd=3,col=4,lty=4) legend(2,1.04,box.lty=0,legend=d$drug,lwd=3,col=2:4,lty=c(2:4)) ##### END OF FILE. #### ### ## #