├── .Rinstignore ├── COPYING ├── DESCRIPTION ├── MD5 ├── NAMESPACE ├── NEWS ├── R ├── abart.R ├── bartModelMatrix.R ├── class.ind.R ├── crisk.bart.R ├── crisk.pre.bart.R ├── crisk2.bart.R ├── draw_lambda.R ├── draw_lambda_i.R ├── draw_z.R ├── gbart.R ├── gewekediag.R ├── lbart.R ├── mbart.R ├── mbart2.R ├── mc.abart.R ├── mc.cores.openmp.R ├── mc.crisk.bart.R ├── mc.crisk.pwbart.R ├── mc.crisk2.bart.R ├── mc.crisk2.pwbart.R ├── mc.gbart.R ├── mc.lbart.R ├── mc.mbart.R ├── mc.mbart2.R ├── mc.pbart.R ├── mc.pwbart.R ├── mc.recur.bart.R ├── mc.recur.pwbart.R ├── mc.surv.bart.R ├── mc.surv.pwbart.R ├── mc.wbart.R ├── mc.wbart.gse.R ├── pbart.R ├── predict.crisk2bart.R ├── predict.criskbart.R ├── predict.lbart.R ├── predict.mbart.R ├── predict.mbart2.R ├── predict.pbart.R ├── predict.recurbart.R ├── predict.survbart.R ├── predict.wbart.R ├── pwbart.R ├── recur.bart.R ├── recur.pre.bart.R ├── recur.pwbart.R ├── rs.pbart.R ├── rtgamma.R ├── rtnorm.R ├── rtnorm_reject.R ├── spectrum0ar.R ├── srstepwise.R ├── stratrs.R ├── surv.bart.R ├── surv.pre.bart.R ├── surv.pwbart.R └── wbart.R ├── build └── vignette.rds ├── cleanup ├── cleanup.win ├── configure ├── configure.ac ├── data ├── ACTG175.rda ├── alligator.rda ├── arq.rda ├── bladder.rda ├── datalist ├── leukemia.rda ├── lung.rda ├── transplant.rda ├── xdm20.test.rda ├── xdm20.train.rda ├── ydm20.test.rda └── ydm20.train.rda ├── demo ├── 00Index ├── aids.itr.lbart.R ├── aids.itr.pbart.R ├── alligator.R ├── bladder.recur.bart.R ├── boston.R ├── c.surv.bart.R ├── cal.recur.bart.R ├── concord.surv.bart.R ├── cube.abart.R ├── cube.gbart.R ├── cube.gbmm.R ├── cube.lbart.R ├── cube.mbart.R ├── cube.pbart.R ├── data.recur.pre.bart.R ├── dm.recur.bart.R ├── ex.mbart.R ├── exp.recur.bart.R ├── friedman.wbart.R ├── gator.mbart2.R ├── geweke.lung.surv.bart.R ├── geweke.pbart1.R ├── geweke.pbart2.R ├── geweke.pbart3.R ├── geweke.recur.bart.R ├── geweke.rs.pbart.R ├── geweke.surv.bart.R ├── inform.alt.gbart.R ├── inform.null.gbart.R ├── leuk.R ├── liver.crisk.bart.R ├── liver.crisk2.bart.R ├── liver50.crisk.bart.R ├── lung.surv.bart.R ├── lung.surv.ice.R ├── lung.surv.lbart.R ├── missing.gbart.R ├── nhanes.pbart1.R ├── nhanes.pbart2.R ├── nox.R ├── np.recur.bart.R ├── replication.R ├── sigma.known.gbart.R ├── sparse.lbart.R ├── sparse.pbart.R ├── sparse.wbart.R ├── test.draw_lambda_i.R ├── test.rtgamma.R ├── test.rtnorm.R ├── test.srstepwise.R └── trees.pbart.R ├── inst ├── CITATION ├── cxx-ex │ ├── Makefile │ ├── README.txt │ ├── bart.cpp │ ├── bart.h │ ├── bartfuns.cpp │ ├── bartfuns.h │ ├── bd.cpp │ ├── bd.h │ ├── cdpmbart.cpp │ ├── cdpmwbart.cpp │ ├── clbart.cpp │ ├── common.h │ ├── cpbart.cpp │ ├── cpwbart.cpp │ ├── cwbart.cpp │ ├── dp.cpp │ ├── dp.h │ ├── dpm.cpp │ ├── dpm.h │ ├── dpmain.cpp │ ├── dpmwmain.cpp │ ├── dps.cpp │ ├── dps.h │ ├── heterbart.cpp │ ├── heterbart.h │ ├── heterbartfuns.cpp │ ├── heterbartfuns.h │ ├── heterbd.cpp │ ├── heterbd.h │ ├── info.h │ ├── latent.cpp │ ├── latent.h │ ├── lmain.cpp │ ├── main.cpp │ ├── mmain.cpp │ ├── pmain.cpp │ ├── rand_draws.cpp │ ├── rand_draws.h │ ├── randomkit.cpp │ ├── randomkit.h │ ├── rn.h │ ├── rtnorm.cpp │ ├── rtnorm.h │ ├── tree.cpp │ ├── tree.h │ ├── treefuns.cpp │ ├── treefuns.h │ └── wmain.cpp └── doc │ ├── the-BART-R-package.Rnw │ └── the-BART-R-package.pdf ├── man ├── ACTG175.Rd ├── BART-package.Rd ├── abart.Rd ├── alligator.Rd ├── arq.Rd ├── bartModelMatrix.Rd ├── bladder.Rd ├── class.ind.Rd ├── crisk.bart.Rd ├── crisk.pre.bart.Rd ├── crisk2.bart.Rd ├── draw_lambda_i.Rd ├── gbart.Rd ├── gewekediag.Rd ├── lbart.Rd ├── leukemia.Rd ├── lung.Rd ├── mbart.Rd ├── mbart2.Rd ├── mc.cores.openmp.Rd ├── mc.crisk.pwbart.Rd ├── mc.crisk2.pwbart.Rd ├── mc.lbart.Rd ├── mc.pbart.Rd ├── mc.surv.pwbart.Rd ├── mc.wbart.Rd ├── mc.wbart.gse.Rd ├── pbart.Rd ├── predict.crisk2bart.Rd ├── predict.criskbart.Rd ├── predict.lbart.Rd ├── predict.mbart.Rd ├── predict.pbart.Rd ├── predict.recurbart.Rd ├── predict.survbart.Rd ├── predict.wbart.Rd ├── pwbart.Rd ├── recur.bart.Rd ├── recur.pre.bart.Rd ├── rs.pbart.Rd ├── rtgamma.Rd ├── rtnorm.Rd ├── spectrum0ar.Rd ├── srstepwise.Rd ├── stratrs.Rd ├── surv.bart.Rd ├── surv.pre.bart.Rd ├── transplant.Rd ├── wbart.Rd ├── xdm20.test.Rd ├── xdm20.train.Rd └── ydm20.train.Rd ├── src ├── Makevars.in ├── Makevars.win ├── bart.cpp ├── bart.h ├── bartfuns.cpp ├── bartfuns.h ├── bd.cpp ├── bd.h ├── cabart.cpp ├── cgbart.cpp ├── clbart.cpp ├── common.h ├── cpbart.cpp ├── cpwbart.cpp ├── cwbart.cpp ├── heterbart.cpp ├── heterbart.h ├── heterbartfuns.cpp ├── heterbartfuns.h ├── heterbd.cpp ├── heterbd.h ├── info.h ├── init.c ├── lambda.cpp ├── lambda.h ├── mc_cores_openmp.cpp ├── rn.h ├── rtgamma.cpp ├── rtgamma.h ├── rtnorm.cpp ├── rtnorm.h ├── tree.cpp ├── tree.h ├── treefuns.cpp └── treefuns.h └── vignettes ├── ref.bib └── the-BART-R-package.Rnw /.Rinstignore: -------------------------------------------------------------------------------- 1 | inst/cxx-ex/.*[.]o$ 2 | inst/cxx-ex/.*[.]out$ 3 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: BART 2 | Type: Package 3 | Title: Bayesian Additive Regression Trees 4 | Version: 2.9.9 5 | Date: 2024-06-21 6 | Authors@R: c(person('Robert', 'McCulloch', role='aut'), 7 | person('Rodney', 'Sparapani', role=c('aut', 'cre'), 8 | email='rsparapa@mcw.edu'), 9 | person('Robert', 'Gramacy', role='ctb'), 10 | person('Matthew', 'Pratola', role='ctb'), 11 | person('Charles', 'Spanbauer', role='ctb'), 12 | person('Martyn', 'Plummer', role='ctb'), 13 | person('Nicky', 'Best', role='ctb'), 14 | person('Kate', 'Cowles', role='ctb'), 15 | person('Karen', 'Vines', role='ctb')) 16 | Author: Robert McCulloch [aut], 17 | Rodney Sparapani [aut, cre], 18 | Robert Gramacy [ctb], 19 | Matthew Pratola [ctb], 20 | Charles Spanbauer [ctb], 21 | Martyn Plummer [ctb], 22 | Nicky Best [ctb], 23 | Kate Cowles [ctb], 24 | Karen Vines [ctb] 25 | Maintainer: Rodney Sparapani 26 | Description: Bayesian Additive Regression Trees (BART) provide flexible nonparametric modeling of covariates for continuous, binary, categorical and time-to-event outcomes. For more information see Sparapani, Spanbauer and McCulloch . 27 | License: GPL (>= 2) 28 | Depends: R (>= 3.6), nlme, survival 29 | Imports: Rcpp (>= 0.12.3), parallel, tools 30 | LinkingTo: Rcpp 31 | Suggests: MASS, knitr, rmarkdown 32 | VignetteBuilder: knitr 33 | NeedsCompilation: yes 34 | Packaged: 2024-06-21 17:21:00 UTC; rsparapa 35 | Repository: CRAN 36 | Date/Publication: 2024-06-21 21:10:02 UTC 37 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | useDynLib('BART', .registration=TRUE) 2 | ##exportPattern("^[[:alpha:]]+") 3 | export(wbart, mc.wbart, pwbart, mc.wbart.gse, mc.pwbart) 4 | export(pbart, mc.pbart) 5 | export(gbart, mc.gbart) 6 | ##export(gbmm, mc.gbmm) 7 | export(abart, mc.abart) 8 | ##export(spbart, mc.spbart) 9 | export(stratrs, rs.pbart) 10 | export(lbart, mc.lbart) 11 | export(mbart, mc.mbart) 12 | export(mbart2, mc.mbart2) 13 | export(surv.pre.bart, surv.bart, surv.pwbart, mc.surv.bart, mc.surv.pwbart) 14 | export(recur.pre.bart, recur.bart, recur.pwbart, mc.recur.bart, mc.recur.pwbart) 15 | export(crisk.pre.bart, crisk.bart, mc.crisk.bart, mc.crisk.pwbart) 16 | export(crisk2.bart, mc.crisk2.bart, mc.crisk2.pwbart) 17 | export(mc.cores.openmp) 18 | export(rtnorm, draw_lambda_i, rtgamma) 19 | export(gewekediag, spectrum0ar) 20 | ##export(bartModelMatrix, class.ind) 21 | export(bartModelMatrix) 22 | export(srstepwise) 23 | ##export(dpgbart) 24 | ##importFrom(nnet, class.ind) 25 | export(class.ind) 26 | importFrom(Rcpp, evalCpp) 27 | importFrom(parallel, detectCores) 28 | importFrom(stats, ar, cor, dbinom, dnorm, lm, predict, pnorm, qnorm, qchisq, plogis, qlogis, quantile, residuals, runif, sd, coef, vcov) 29 | importFrom(survival, survfit, Surv, survreg) 30 | importFrom(tools, psnice) 31 | importFrom(nlme, lme) 32 | S3method(predict, wbart) 33 | S3method(predict, pbart) 34 | S3method(predict, survbart) 35 | S3method(predict, recurbart) 36 | S3method(predict, criskbart) 37 | S3method(predict, crisk2bart) 38 | S3method(predict, lbart) 39 | S3method(predict, mbart) 40 | S3method(predict, mbart2) 41 | ## export(predict.mbart2) 42 | ## export(predict.wbart, predict.pbart, predict.lbart, predict.mbart) 43 | ## export(predict.survbart, predict.recurbart) 44 | ## export(predict.criskbart, predict.crisk2bart) 45 | ##S3method(predict, gbart) 46 | ##export(predict.gbart) 47 | -------------------------------------------------------------------------------- /R/class.ind.R: -------------------------------------------------------------------------------- 1 | 2 | # copyright (C) 1994-2013 Bill Venables and Brian Ripley 3 | # 4 | # This program is free software; you can redistribute it and/or modify 5 | # it under the terms of the GNU General Public License as published by 6 | # the Free Software Foundation; either version 2 or 3 of the License 7 | # (at your option). 8 | # 9 | # This program is distributed in the hope that it will be useful, 10 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | # GNU General Public License for more details. 13 | # 14 | # A copy of the GNU General Public License is available at 15 | # http://www.r-project.org/Licenses/ 16 | # 17 | 18 | class.ind <- function(cl) 19 | { 20 | n <- length(cl) 21 | cl <- as.factor(cl) 22 | x <- matrix(0, n, length(levels(cl)) ) 23 | x[(1L:n) + n*(unclass(cl)-1L)] <- 1 24 | dimnames(x) <- list(names(cl), levels(cl)) 25 | x 26 | } 27 | 28 | -------------------------------------------------------------------------------- /R/draw_lambda.R: -------------------------------------------------------------------------------- 1 | 2 | ## BART: Bayesian Additive Regression Trees 3 | ## Copyright (C) 2017-2018 Robert McCulloch, Rodney Sparapani 4 | ## and Robert Gramacy 5 | 6 | ## This program is free software; you can redistribute it and/or modify 7 | ## it under the terms of the GNU General Public License as published by 8 | ## the Free Software Foundation; either version 2 of the License, or 9 | ## (at your option) any later version. 10 | 11 | ## This program is distributed in the hope that it will be useful, 12 | ## but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ## GNU General Public License for more details. 15 | 16 | ## You should have received a copy of the GNU General Public License 17 | ## along with this program; if not, a copy is available at 18 | ## https://www.R-project.org/Licenses/GPL-2 19 | 20 | draw_lambda=function(lambda, mean, kmax=1000, thin=1) 21 | .Call("cdraw_lambda", lambda, mean, kmax, thin) 22 | 23 | -------------------------------------------------------------------------------- /R/draw_lambda_i.R: -------------------------------------------------------------------------------- 1 | 2 | ## BART: Bayesian Additive Regression Trees 3 | ## Copyright (C) 2017-2018 Robert McCulloch, Rodney Sparapani 4 | ## and Robert Gramacy 5 | 6 | ## This program is free software; you can redistribute it and/or modify 7 | ## it under the terms of the GNU General Public License as published by 8 | ## the Free Software Foundation; either version 2 of the License, or 9 | ## (at your option) any later version. 10 | 11 | ## This program is distributed in the hope that it will be useful, 12 | ## but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ## GNU General Public License for more details. 15 | 16 | ## You should have received a copy of the GNU General Public License 17 | ## along with this program; if not, a copy is available at 18 | ## https://www.R-project.org/Licenses/GPL-2 19 | 20 | draw_lambda_i=function(lambda, mean, kmax=1000, thin=1) 21 | .Call("cdraw_lambda_i", lambda, mean, kmax, thin) 22 | 23 | -------------------------------------------------------------------------------- /R/draw_z.R: -------------------------------------------------------------------------------- 1 | 2 | ## BART: Bayesian Additive Regression Trees 3 | ## Copyright (C) 2017 Robert McCulloch and Rodney Sparapani 4 | 5 | ## This program is free software; you can redistribute it and/or modify 6 | ## it under the terms of the GNU General Public License as published by 7 | ## the Free Software Foundation; either version 2 of the License, or 8 | ## (at your option) any later version. 9 | 10 | ## This program is distributed in the hope that it will be useful, 11 | ## but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ## GNU General Public License for more details. 14 | 15 | ## You should have received a copy of the GNU General Public License 16 | ## along with this program; if not, a copy is available at 17 | ## https://www.R-project.org/Licenses/GPL-2 18 | 19 | draw_z=function(mean, tau, lambda) 20 | .Call("cdraw_z", mean, tau, lambda) 21 | 22 | -------------------------------------------------------------------------------- /R/gewekediag.R: -------------------------------------------------------------------------------- 1 | 2 | ## BART: Bayesian Additive Regression Trees 3 | ## Copyright (C) 2017 Robert McCulloch and Rodney Sparapani 4 | 5 | ## This program is free software; you can redistribute it and/or modify 6 | ## it under the terms of the GNU General Public License as published by 7 | ## the Free Software Foundation; either version 2 of the License, or 8 | ## (at your option) any later version. 9 | 10 | ## This program is distributed in the hope that it will be useful, 11 | ## but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ## GNU General Public License for more details. 14 | 15 | ## You should have received a copy of the GNU General Public License 16 | ## along with this program; if not, a copy is available at 17 | ## https://www.R-project.org/Licenses/GPL-2 18 | 19 | gewekediag <- function (x, frac1 = 0.1, frac2 = 0.5) 20 | { 21 | if (frac1 < 0 || frac1 > 1) stop("frac1 invalid") 22 | 23 | if (frac2 < 0 || frac2 > 1) stop("frac2 invalid") 24 | 25 | if (frac1 + frac2 > 1) stop("start and end sequences are overlapping") 26 | 27 | end. <- nrow(x) 28 | xstart <- c(1, floor(end. - frac2 * (end. - 1))) 29 | xend <- c(ceiling(1 + frac1 * (end. - 1)), end.) 30 | y.variance <- y.mean <- vector("list", 2) 31 | 32 | for (i in 1:2) { 33 | y <- x[xstart[i]:xend[i], ] 34 | y.mean[[i]] <- apply(y, 2, mean) 35 | y.variance[[i]] <- spectrum0ar(y)$spec/(xend[i]-xstart[i]+1) 36 | } 37 | 38 | z <- (y.mean[[1]] - y.mean[[2]])/sqrt(y.variance[[1]] + y.variance[[2]]) 39 | out <- list(z = z, frac = c(frac1, frac2)) 40 | 41 | return(out) 42 | } 43 | -------------------------------------------------------------------------------- /R/mc.cores.openmp.R: -------------------------------------------------------------------------------- 1 | 2 | ## BART: Bayesian Additive Regression Trees 3 | ## Copyright (C) 2017 Robert McCulloch and Rodney Sparapani 4 | 5 | ## This program is free software; you can redistribute it and/or modify 6 | ## it under the terms of the GNU General Public License as published by 7 | ## the Free Software Foundation; either version 2 of the License, or 8 | ## (at your option) any later version. 9 | 10 | ## This program is distributed in the hope that it will be useful, 11 | ## but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ## GNU General Public License for more details. 14 | 15 | ## You should have received a copy of the GNU General Public License 16 | ## along with this program; if not, a copy is available at 17 | ## https://www.R-project.org/Licenses/GPL-2 18 | 19 | mc.cores.openmp=function() .Call("mc_cores_openmp") 20 | -------------------------------------------------------------------------------- /R/mc.pwbart.R: -------------------------------------------------------------------------------- 1 | 2 | ## BART: Bayesian Additive Regression Trees 3 | ## Copyright (C) 2017-2018 Robert McCulloch and Rodney Sparapani 4 | ## mc.pwbart 5 | 6 | ## This program is free software; you can redistribute it and/or modify 7 | ## it under the terms of the GNU General Public License as published by 8 | ## the Free Software Foundation; either version 2 of the License, or 9 | ## (at your option) any later version. 10 | 11 | ## This program is distributed in the hope that it will be useful, 12 | ## but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ## GNU General Public License for more details. 15 | 16 | ## You should have received a copy of the GNU General Public License 17 | ## along with this program; if not, a copy is available at 18 | ## https://www.R-project.org/Licenses/GPL-2 19 | 20 | mc.pwbart = function( 21 | x.test, #x matrix to predict at 22 | treedraws, #$treedraws from wbart 23 | mu=0, #mean to add on 24 | mc.cores=2L, 25 | transposed=FALSE, 26 | dodraws=TRUE, 27 | nice=19L 28 | ) 29 | { 30 | if(.Platform$OS.type!='unix') 31 | stop('parallel::mcparallel/mccollect do not exist on windows') 32 | 33 | if(!transposed) x.test <- t(bartModelMatrix(x.test)) 34 | 35 | p <- length(treedraws$cutpoints) 36 | 37 | if(p!=nrow(x.test)) 38 | stop(paste0('The number of columns in x.test must be equal to ', p)) 39 | 40 | mc.cores.detected <- detectCores() 41 | 42 | if(!is.na(mc.cores.detected) && mc.cores>mc.cores.detected) mc.cores <- mc.cores.detected 43 | 44 | K <- ncol(x.test) 45 | if(K1) for(i in 1:(mc.cores-1)) { 66 | ## parallel::mcparallel({psnice(value=nice); 67 | ## pwbart(trees, x.test[ , max(1, (h-k)):(h-1)], mu, 1, TRUE)}, 68 | ## silent=TRUE) 69 | ## h <- h-k 70 | ## } 71 | 72 | pred.list <- parallel::mccollect() 73 | pred <- pred.list[[1]] 74 | type=class(pred)[1] 75 | if(type=='list') pred <- pred[[1]] 76 | else if(type!='matrix') return(pred.list) ## likely error messages 77 | 78 | if(mc.cores>1) for(i in 2:mc.cores) { 79 | if(type=='list') pred <- cbind(pred, pred.list[[i]][[1]]) 80 | else pred <- cbind(pred, pred.list[[i]]) 81 | } 82 | ##if(mc.cores>1) for(i in 2:mc.cores) pred <- cbind(pred, pred.list[[i]]) 83 | 84 | if(dodraws) return(pred) 85 | else return(apply(pred, 2, mean)) 86 | ## if(dodraws) return(pred+mu) 87 | ## else return(apply(pred, 2, mean)+mu) 88 | } 89 | -------------------------------------------------------------------------------- /R/mc.surv.pwbart.R: -------------------------------------------------------------------------------- 1 | 2 | ## BART: Bayesian Additive Regression Trees 3 | ## Copyright (C) 2017 Robert McCulloch and Rodney Sparapani 4 | 5 | ## This program is free software; you can redistribute it and/or modify 6 | ## it under the terms of the GNU General Public License as published by 7 | ## the Free Software Foundation; either version 2 of the License, or 8 | ## (at your option) any later version. 9 | 10 | ## This program is distributed in the hope that it will be useful, 11 | ## but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ## GNU General Public License for more details. 14 | 15 | ## You should have received a copy of the GNU General Public License 16 | ## along with this program; if not, a copy is available at 17 | ## https://www.R-project.org/Licenses/GPL-2 18 | 19 | mc.surv.pwbart <- function( 20 | x.test, #x matrix to predict at with time points expanded 21 | treedraws, #$treedraws for from surv.bart/mc.surv.bart 22 | binaryOffset=0, #mean to add on 23 | mc.cores=2L, 24 | type='pbart', 25 | transposed=FALSE, 26 | nice=19L 27 | ) 28 | { 29 | if(.Platform$OS.type!='unix') 30 | stop('parallel::mcparallel/mccollect do not exist on windows') 31 | 32 | if(!transposed) x.test <- t(bartModelMatrix(x.test)) 33 | 34 | p <- length(treedraws$cutpoints) 35 | 36 | if(p!=nrow(x.test)) 37 | stop(paste0('The number of columns in x.test must be equal to ', p)) 38 | 39 | K <- ncol(x.test) 40 | k <- K%/%mc.cores 41 | j <- K 42 | for(i in 1:mc.cores) { 43 | if(i==mc.cores) h <- 1 44 | else h <- j-k 45 | 46 | parallel::mcparallel({psnice(value=nice); 47 | pwbart(x.test[ , h:j], treedraws, binaryOffset, 1, TRUE)}, 48 | silent=(i!=1)) 49 | j <- h-1 50 | } 51 | 52 | yhat.test.list <- parallel::mccollect() 53 | 54 | pred <- list() 55 | 56 | x.test <- t(x.test) 57 | pred$tx.test <- x.test 58 | times <- unique(sort(x.test[ , 1])) 59 | pred$times <- times 60 | K <- length(times) 61 | pred$K <- K 62 | 63 | pred$yhat.test <- yhat.test.list[[1]] 64 | 65 | if(class(pred$yhat.test)[1]!='matrix') return(pred$yhat.test) 66 | 67 | if(mc.cores>1) for(i in 2:mc.cores) 68 | pred$yhat.test <- cbind(pred$yhat.test, yhat.test.list[[i]]) 69 | 70 | H <- nrow(x.test)/K ## the number of different settings 71 | 72 | if(type=='pbart') pred$prob.test <- pnorm(pred$yhat.test) 73 | else if(type=='lbart') pred$prob.test <- plogis(pred$yhat.test) 74 | 75 | pred$surv.test <- 1-pred$prob.test 76 | 77 | for(h in 1:H) 78 | for(j in 2:K) { 79 | l <- K*(h-1)+j 80 | 81 | pred$surv.test[ , l] <- pred$surv.test[ , l-1]*pred$surv.test[ , l] 82 | } 83 | 84 | pred$surv.test.mean <- apply(pred$surv.test, 2, mean) 85 | 86 | pred$binaryOffset <- binaryOffset 87 | attr(pred, 'class') <- 'survbart' 88 | 89 | return(pred) 90 | } 91 | -------------------------------------------------------------------------------- /R/predict.crisk2bart.R: -------------------------------------------------------------------------------- 1 | 2 | ## BART: Bayesian Additive Regression Trees 3 | ## Copyright (C) 2018 Robert McCulloch and Rodney Sparapani 4 | 5 | ## This program is free software; you can redistribute it and/or modify 6 | ## it under the terms of the GNU General Public License as published by 7 | ## the Free Software Foundation; either version 2 of the License, or 8 | ## (at your option) any later version. 9 | 10 | ## This program is distributed in the hope that it will be useful, 11 | ## but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ## GNU General Public License for more details. 14 | 15 | ## You should have received a copy of the GNU General Public License 16 | ## along with this program; if not, a copy is available at 17 | ## https://www.R-project.org/Licenses/GPL-2 18 | 19 | predict.crisk2bart <- function(object, newdata, newdata2, mc.cores=1, 20 | openmp=(mc.cores.openmp()>0), ...) { 21 | 22 | ## if(class(newdata) != "matrix") stop("newdata must be a matrix") 23 | ## if(class(newdata2) != "matrix") stop("newdata2 must be a matrix") 24 | 25 | p <- length(object$treedraws$cutpoints) 26 | 27 | if(p!=ncol(newdata)) 28 | stop(paste0('The number of columns in newdata must be equal to ', p)) 29 | 30 | p <- length(object$treedraws2$cutpoints) 31 | 32 | if(p!=ncol(newdata2)) 33 | stop(paste0('The number of columns in newdata2 must be equal to ', p)) 34 | 35 | if(.Platform$OS.type == "unix") mc.cores.detected <- detectCores() 36 | else mc.cores.detected <- NA 37 | 38 | if(!is.na(mc.cores.detected) && mc.cores>mc.cores.detected) 39 | mc.cores <- mc.cores.detected 40 | 41 | if(length(object$binaryOffset)==0) object$binaryOffset=object$offset 42 | if(length(object$binaryOffset2)==0) object$binaryOffset2=object$offset2 43 | 44 | return(mc.crisk2.pwbart(newdata, newdata2, 45 | object$treedraws, object$treedraws2, 46 | object$binaryOffset, object$binaryOffset2, 47 | mc.cores=mc.cores, type=object$type, ...)) 48 | } 49 | 50 | -------------------------------------------------------------------------------- /R/predict.criskbart.R: -------------------------------------------------------------------------------- 1 | 2 | ## BART: Bayesian Additive Regression Trees 3 | ## Copyright (C) 2017-2018 Robert McCulloch and Rodney Sparapani 4 | 5 | ## This program is free software; you can redistribute it and/or modify 6 | ## it under the terms of the GNU General Public License as published by 7 | ## the Free Software Foundation; either version 2 of the License, or 8 | ## (at your option) any later version. 9 | 10 | ## This program is distributed in the hope that it will be useful, 11 | ## but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ## GNU General Public License for more details. 14 | 15 | ## You should have received a copy of the GNU General Public License 16 | ## along with this program; if not, a copy is available at 17 | ## https://www.R-project.org/Licenses/GPL-2 18 | 19 | predict.criskbart <- function(object, newdata, newdata2, mc.cores=1, 20 | openmp=(mc.cores.openmp()>0), ...) { 21 | 22 | ## if(class(newdata) != "matrix") stop("newdata must be a matrix") 23 | ## if(class(newdata2) != "matrix") stop("newdata2 must be a matrix") 24 | 25 | p <- length(object$treedraws$cutpoints) 26 | 27 | if(p!=ncol(newdata)) 28 | stop(paste0('The number of columns in newdata must be equal to ', p)) 29 | 30 | p <- length(object$treedraws2$cutpoints) 31 | 32 | if(p!=ncol(newdata2)) 33 | stop(paste0('The number of columns in newdata2 must be equal to ', p)) 34 | 35 | if(.Platform$OS.type == "unix") mc.cores.detected <- detectCores() 36 | else mc.cores.detected <- NA 37 | 38 | if(!is.na(mc.cores.detected) && mc.cores>mc.cores.detected) 39 | mc.cores <- mc.cores.detected 40 | 41 | if(length(object$binaryOffset)==0) object$binaryOffset=object$offset 42 | if(length(object$binaryOffset2)==0) object$binaryOffset2=object$offset2 43 | 44 | return(mc.crisk.pwbart(newdata, newdata2, 45 | object$treedraws, object$treedraws2, 46 | object$binaryOffset, object$binaryOffset2, 47 | mc.cores=mc.cores, type=object$type, ...)) 48 | } 49 | 50 | -------------------------------------------------------------------------------- /R/predict.lbart.R: -------------------------------------------------------------------------------- 1 | 2 | ## BART: Bayesian Additive Regression Trees 3 | ## Copyright (C) 2017 Robert McCulloch and Rodney Sparapani 4 | 5 | ## This program is free software; you can redistribute it and/or modify 6 | ## it under the terms of the GNU General Public License as published by 7 | ## the Free Software Foundation; either version 2 of the License, or 8 | ## (at your option) any later version. 9 | 10 | ## This program is distributed in the hope that it will be useful, 11 | ## but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ## GNU General Public License for more details. 14 | 15 | ## You should have received a copy of the GNU General Public License 16 | ## along with this program; if not, a copy is available at 17 | ## https://www.R-project.org/Licenses/GPL-2 18 | 19 | predict.lbart <- function(object, newdata, mc.cores=1, openmp=(mc.cores.openmp()>0), ...) { 20 | 21 | ##if(class(newdata) != "matrix") stop("newdata must be a matrix") 22 | 23 | p <- length(object$treedraws$cutpoints) 24 | 25 | if(p!=ncol(newdata)) 26 | stop(paste0('The number of columns in newdata must be equal to ', p)) 27 | 28 | if(.Platform$OS.type == "unix") mc.cores.detected <- detectCores() 29 | else mc.cores.detected <- NA 30 | 31 | if(!is.na(mc.cores.detected) && mc.cores>mc.cores.detected) mc.cores <- mc.cores.detected 32 | 33 | if(.Platform$OS.type != "unix" || openmp || mc.cores==1) call <- pwbart 34 | else call <- mc.pwbart 35 | 36 | ##return(call(newdata, object$treedraws, mc.cores=mc.cores, mu=object$binaryOffset, ...)) 37 | if(length(object$binaryOffset)==0) object$binaryOffset=object$offset 38 | 39 | pred <- list(yhat.test=call(newdata, object$treedraws, mc.cores=mc.cores, 40 | mu=object$binaryOffset, ...)) 41 | 42 | pred$prob.test <- plogis(pred$yhat.test) 43 | pred$prob.test.mean <- apply(pred$prob.test, 2, mean) 44 | pred$binaryOffset <- object$binaryOffset 45 | attr(pred, 'class') <- 'lbart' 46 | 47 | return(pred) 48 | } 49 | 50 | -------------------------------------------------------------------------------- /R/predict.mbart2.R: -------------------------------------------------------------------------------- 1 | 2 | ## BART: Bayesian Additive Regression Trees 3 | ## Copyright (C) 2017-2018 Robert McCulloch and Rodney Sparapani 4 | 5 | ## This program is free software; you can redistribute it and/or modify 6 | ## it under the terms of the GNU General Public License as published by 7 | ## the Free Software Foundation; either version 2 of the License, or 8 | ## (at your option) any later version. 9 | 10 | ## This program is distributed in the hope that it will be useful, 11 | ## but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ## GNU General Public License for more details. 14 | 15 | ## You should have received a copy of the GNU General Public License 16 | ## along with this program; if not, a copy is available at 17 | ## https://www.R-project.org/Licenses/GPL-2 18 | 19 | predict.mbart2 <- function(object, newdata, mc.cores=1, 20 | openmp=(mc.cores.openmp()>0), ...) { 21 | 22 | ##if(class(newdata) != "matrix") stop("newdata must be a matrix") 23 | 24 | p <- length(object$treedraws$cutpoints) 25 | 26 | if(p!=ncol(newdata)) 27 | stop(paste0('The number of columns in newdata must be equal to ', p)) 28 | 29 | if(.Platform$OS.type == "unix") mc.cores.detected <- detectCores() 30 | else mc.cores.detected <- NA 31 | 32 | if(!is.na(mc.cores.detected) && mc.cores>mc.cores.detected) 33 | mc.cores <- mc.cores.detected 34 | 35 | if(.Platform$OS.type != "unix" || openmp || mc.cores==1) call <- pwbart 36 | else call <- mc.pwbart 37 | 38 | ##call <- predict.gbart 39 | 40 | ##return(call(newdata, object$treedraws, mc.cores=mc.cores, mu=object$binaryOffset, ...)) 41 | 42 | K <- object$K 43 | pred <- as.list(1:K) 44 | trees <- object$treedraws$trees 45 | 46 | for(j in 1:K) { 47 | object$treedraws$trees <- trees[[j]] 48 | pred[[j]] <- list(yhat.test=call(newdata, object$treedraws, 49 | mc.cores=mc.cores, 50 | mu=object$offset[j], ...)) 51 | } 52 | H <- dim(pred[[1]]$yhat.test) 53 | ndpost <- H[1] 54 | np <- H[2] 55 | res <- list() 56 | res$yhat.test <- matrix(nrow=ndpost, ncol=K*np) 57 | res$prob.test <- matrix(nrow=ndpost, ncol=K*np) 58 | res$tot.test <- matrix(0, nrow=ndpost, ncol=np) 59 | 60 | for(i in 1:np) { 61 | for(j in 1:K) { 62 | h <- (i-1)*K+j 63 | res$yhat.test[ , h] <- pred[[j]]$yhat.test[ , i] 64 | res$tot.test[ , i] <- res$tot.test[ , i]+exp(res$yhat.test[ , h]) 65 | if(j==K) 66 | for(h in (i-1)*K+1:K) 67 | res$prob.test[ , h] <- exp(res$yhat.test[ , h])/ 68 | res$tot.test[ , i] 69 | } 70 | } 71 | 72 | res$prob.test.mean <- apply(res$prob.test, 2, mean) 73 | res$yhat.test.mean <- NULL 74 | res$tot.test <- NULL 75 | res$K <- K 76 | res$offset <- object$offset 77 | attr(res, 'class') <- 'mbart2' 78 | 79 | return(res) 80 | } 81 | 82 | -------------------------------------------------------------------------------- /R/predict.pbart.R: -------------------------------------------------------------------------------- 1 | 2 | ## BART: Bayesian Additive Regression Trees 3 | ## Copyright (C) 2017 Robert McCulloch and Rodney Sparapani 4 | 5 | ## This program is free software; you can redistribute it and/or modify 6 | ## it under the terms of the GNU General Public License as published by 7 | ## the Free Software Foundation; either version 2 of the License, or 8 | ## (at your option) any later version. 9 | 10 | ## This program is distributed in the hope that it will be useful, 11 | ## but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ## GNU General Public License for more details. 14 | 15 | ## You should have received a copy of the GNU General Public License 16 | ## along with this program; if not, a copy is available at 17 | ## https://www.R-project.org/Licenses/GPL-2 18 | 19 | predict.pbart <- function(object, newdata, mc.cores=1, openmp=(mc.cores.openmp()>0), ...) { 20 | 21 | ##if(class(newdata) != "matrix") stop("newdata must be a matrix") 22 | 23 | p <- length(object$treedraws$cutpoints) 24 | 25 | if(p!=ncol(newdata)) 26 | stop(paste0('The number of columns in newdata must be equal to ', p)) 27 | 28 | if(.Platform$OS.type == "unix") mc.cores.detected <- detectCores() 29 | else mc.cores.detected <- NA 30 | 31 | if(!is.na(mc.cores.detected) && mc.cores>mc.cores.detected) mc.cores <- mc.cores.detected 32 | 33 | if(.Platform$OS.type != "unix" || openmp || mc.cores==1) call <- pwbart 34 | else call <- mc.pwbart 35 | 36 | ##return(call(newdata, object$treedraws, mc.cores=mc.cores, mu=object$binaryOffset, ...)) 37 | 38 | if(length(object$binaryOffset)==0) object$binaryOffset=object$offset 39 | 40 | pred <- list(yhat.test=call(newdata, object$treedraws, mc.cores=mc.cores, 41 | mu=object$binaryOffset, ...)) 42 | 43 | pred$prob.test <- pnorm(pred$yhat.test) 44 | pred$prob.test.mean <- apply(pred$prob.test, 2, mean) 45 | pred$binaryOffset <- object$binaryOffset 46 | attr(pred, 'class') <- 'pbart' 47 | 48 | return(pred) 49 | } 50 | 51 | -------------------------------------------------------------------------------- /R/predict.recurbart.R: -------------------------------------------------------------------------------- 1 | 2 | ## BART: Bayesian Additive Regression Trees 3 | ## Copyright (C) 2017 Robert McCulloch and Rodney Sparapani 4 | 5 | ## This program is free software; you can redistribute it and/or modify 6 | ## it under the terms of the GNU General Public License as published by 7 | ## the Free Software Foundation; either version 2 of the License, or 8 | ## (at your option) any later version. 9 | 10 | ## This program is distributed in the hope that it will be useful, 11 | ## but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ## GNU General Public License for more details. 14 | 15 | ## You should have received a copy of the GNU General Public License 16 | ## along with this program; if not, a copy is available at 17 | ## https://www.R-project.org/Licenses/GPL-2 18 | 19 | predict.recurbart <- function(object, newdata, mc.cores=1, openmp=(mc.cores.openmp()>0), ...) { 20 | 21 | ##if(class(newdata) != "matrix") stop("newdata must be a matrix") 22 | 23 | p <- length(object$treedraws$cutpoints) 24 | 25 | if(p!=ncol(newdata)) 26 | stop(paste0('The number of columns in newdata must be equal to ', p)) 27 | 28 | if(.Platform$OS.type == "unix") mc.cores.detected <- detectCores() 29 | else mc.cores.detected <- NA 30 | 31 | if(!is.na(mc.cores.detected) && mc.cores>mc.cores.detected) mc.cores <- mc.cores.detected 32 | 33 | if(.Platform$OS.type != "unix" || openmp || mc.cores==1) call <- recur.pwbart 34 | else call <- mc.recur.pwbart 35 | 36 | if(length(object$binaryOffset)==0) object$binaryOffset=object$offset 37 | 38 | return(call(newdata, object$treedraws, mc.cores=mc.cores, 39 | binaryOffset=object$binaryOffset, 40 | type=object$type, ...)) 41 | } 42 | 43 | -------------------------------------------------------------------------------- /R/predict.survbart.R: -------------------------------------------------------------------------------- 1 | 2 | ## BART: Bayesian Additive Regression Trees 3 | ## Copyright (C) 2017 Robert McCulloch and Rodney Sparapani 4 | 5 | ## This program is free software; you can redistribute it and/or modify 6 | ## it under the terms of the GNU General Public License as published by 7 | ## the Free Software Foundation; either version 2 of the License, or 8 | ## (at your option) any later version. 9 | 10 | ## This program is distributed in the hope that it will be useful, 11 | ## but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ## GNU General Public License for more details. 14 | 15 | ## You should have received a copy of the GNU General Public License 16 | ## along with this program; if not, a copy is available at 17 | ## https://www.R-project.org/Licenses/GPL-2 18 | 19 | predict.survbart <- function(object, newdata, mc.cores=1, 20 | openmp=(mc.cores.openmp()>0), ...) { 21 | 22 | ##if(class(newdata) != "matrix") stop("newdata must be a matrix") 23 | 24 | p <- length(object$treedraws$cutpoints) 25 | 26 | if(p!=ncol(newdata)) 27 | stop(paste0('The number of columns in newdata must be equal to ', p)) 28 | 29 | if(.Platform$OS.type == "unix") mc.cores.detected <- detectCores() 30 | else mc.cores.detected <- NA 31 | 32 | if(!is.na(mc.cores.detected) && mc.cores>mc.cores.detected) mc.cores <- mc.cores.detected 33 | 34 | if(.Platform$OS.type != "unix" || openmp || mc.cores==1) call <- surv.pwbart 35 | else call <- mc.surv.pwbart 36 | 37 | if(length(object$binaryOffset)==0) object$binaryOffset=object$offset 38 | 39 | return(call(newdata, object$treedraws, mc.cores=mc.cores, 40 | binaryOffset=object$binaryOffset, type=object$type, ...)) 41 | } 42 | 43 | -------------------------------------------------------------------------------- /R/predict.wbart.R: -------------------------------------------------------------------------------- 1 | 2 | ## BART: Bayesian Additive Regression Trees 3 | ## Copyright (C) 2017 Robert McCulloch and Rodney Sparapani 4 | 5 | ## This program is free software; you can redistribute it and/or modify 6 | ## it under the terms of the GNU General Public License as published by 7 | ## the Free Software Foundation; either version 2 of the License, or 8 | ## (at your option) any later version. 9 | 10 | ## This program is distributed in the hope that it will be useful, 11 | ## but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ## GNU General Public License for more details. 14 | 15 | ## You should have received a copy of the GNU General Public License 16 | ## along with this program; if not, a copy is available at 17 | ## https://www.R-project.org/Licenses/GPL-2 18 | 19 | predict.wbart <- function(object, newdata, mc.cores=1, openmp=(mc.cores.openmp()>0), ...) { 20 | 21 | ##if(class(newdata) != "matrix") stop("newdata must be a matrix") 22 | 23 | p <- length(object$treedraws$cutpoints) 24 | 25 | if(p!=ncol(newdata)) 26 | stop(paste0('The number of columns in newdata must be equal to ', p)) 27 | 28 | if(.Platform$OS.type == "unix") mc.cores.detected <- detectCores() 29 | else mc.cores.detected <- NA 30 | 31 | if(!is.na(mc.cores.detected) && mc.cores>mc.cores.detected) mc.cores <- mc.cores.detected 32 | 33 | if(.Platform$OS.type != "unix" || openmp || mc.cores==1) call <- pwbart 34 | else call <- mc.pwbart 35 | 36 | if(length(object$mu)==0) object$mu=object$offset 37 | 38 | return(call(newdata, object$treedraws, mc.cores=mc.cores, mu=object$mu, ...)) 39 | } 40 | 41 | -------------------------------------------------------------------------------- /R/pwbart.R: -------------------------------------------------------------------------------- 1 | 2 | ## BART: Bayesian Additive Regression Trees 3 | ## Copyright (C) 2017-2018 Robert McCulloch and Rodney Sparapani 4 | 5 | ## This program is free software; you can redistribute it and/or modify 6 | ## it under the terms of the GNU General Public License as published by 7 | ## the Free Software Foundation; either version 2 of the License, or 8 | ## (at your option) any later version. 9 | 10 | ## This program is distributed in the hope that it will be useful, 11 | ## but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ## GNU General Public License for more details. 14 | 15 | ## You should have received a copy of the GNU General Public License 16 | ## along with this program; if not, a copy is available at 17 | ## https://www.R-project.org/Licenses/GPL-2 18 | 19 | pwbart = function( 20 | x.test, #x matrix to predict at 21 | treedraws, #$treedraws from wbart 22 | mu=0, #mean to add on 23 | mc.cores=1L, #thread count 24 | transposed=FALSE, 25 | dodraws=TRUE, 26 | nice=19L #mc.pwbart only 27 | ) 28 | { 29 | if(!transposed) x.test <- t(bartModelMatrix(x.test)) 30 | 31 | p <- length(treedraws$cutpoints) 32 | 33 | if(p!=nrow(x.test)) 34 | stop(paste0('The number of columns in x.test must be equal to ', p)) 35 | 36 | res = .Call("cpwbart", 37 | treedraws, #trees list 38 | x.test, #the test x 39 | mc.cores #thread count 40 | ) 41 | if(dodraws) return(res$yhat.test+mu) 42 | else return(apply(res$yhat.test, 2, mean)+mu) 43 | } 44 | -------------------------------------------------------------------------------- /R/recur.pwbart.R: -------------------------------------------------------------------------------- 1 | 2 | ## BART: Bayesian Additive Regression Trees 3 | ## Copyright (C) 2017 Robert McCulloch and Rodney Sparapani 4 | 5 | ## This program is free software; you can redistribute it and/or modify 6 | ## it under the terms of the GNU General Public License as published by 7 | ## the Free Software Foundation; either version 2 of the License, or 8 | ## (at your option) any later version. 9 | 10 | ## This program is distributed in the hope that it will be useful, 11 | ## but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ## GNU General Public License for more details. 14 | 15 | ## You should have received a copy of the GNU General Public License 16 | ## along with this program; if not, a copy is available at 17 | ## https://www.R-project.org/Licenses/GPL-2 18 | 19 | recur.pwbart <- function( 20 | x.test, #x matrix to predict at with time points expanded 21 | treedraws, #$treedraws for from surv.bart/mc.surv.bart 22 | binaryOffset=0, #mean to add on 23 | mc.cores=1L, 24 | type='pbart', 25 | transposed=FALSE, 26 | nice=19L # mc.surv.pwbart only 27 | ) 28 | { 29 | if(!transposed) x.test <- t(bartModelMatrix(x.test)) 30 | 31 | p <- length(treedraws$cutpoints) 32 | 33 | if(p!=nrow(x.test)) 34 | stop(paste0('The number of columns in x.test must be equal to ', p)) 35 | 36 | pred <- list() 37 | 38 | pred$yhat.test <- pwbart(x.test, treedraws, binaryOffset, mc.cores, TRUE) 39 | 40 | if(class(pred$yhat.test)[1]!='matrix') return(pred$yhat.test) 41 | 42 | x.test <- t(x.test) 43 | pred$tx.test <- x.test 44 | times <- unique(sort(x.test[ , 1])) 45 | pred$times <- times 46 | K <- length(times) 47 | pred$K <- K 48 | 49 | if(type=='pbart') pred$prob.test <- pnorm(pred$yhat.test) 50 | else if(type=='lbart') pred$prob.test <- plogis(pred$yhat.test) 51 | 52 | pred$haz.test <- pred$prob.test 53 | pred$cum.test <- pred$haz.test 54 | 55 | H <- nrow(x.test) 56 | 57 | for(h in 1:H) { 58 | j <- which(x.test[h, 1]==times) ## for grid points only 59 | 60 | if(j==1) pred$haz.test[ , h] <- pred$haz.test[ , h]/times[1] 61 | else { 62 | pred$haz.test[ , h] <- pred$haz.test[ , h]/(times[j]-times[j-1]) 63 | pred$cum.test[ , h] <- pred$cum.test[ , h-1]+pred$cum.test[ , h] 64 | } 65 | } 66 | 67 | pred$prob.test.mean <- apply(pred$prob.test, 2, mean) 68 | pred$haz.test.mean <- apply(pred$haz.test, 2, mean) 69 | pred$cum.test.mean <- apply(pred$cum.test, 2, mean) 70 | 71 | pred$binaryOffset <- binaryOffset 72 | attr(pred, 'class') <- 'recurbart' 73 | 74 | return(pred) 75 | } 76 | -------------------------------------------------------------------------------- /R/rtgamma.R: -------------------------------------------------------------------------------- 1 | 2 | ## BART: Bayesian Additive Regression Trees 3 | ## Copyright (C) 2019 Rodney Sparapani 4 | 5 | ## This program is free software; you can redistribute it and/or modify 6 | ## it under the terms of the GNU General Public License as published by 7 | ## the Free Software Foundation; either version 2 of the License, or 8 | ## (at your option) any later version. 9 | 10 | ## This program is distributed in the hope that it will be useful, 11 | ## but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ## GNU General Public License for more details. 14 | 15 | ## You should have received a copy of the GNU General Public License 16 | ## along with this program; if not, a copy is available at 17 | ## https://www.R-project.org/Licenses/GPL-2 18 | 19 | rtgamma=function(n, shape, rate, a) .Call("crtgamma", n, shape, rate, a) 20 | 21 | -------------------------------------------------------------------------------- /R/rtnorm.R: -------------------------------------------------------------------------------- 1 | 2 | ## BART: Bayesian Additive Regression Trees 3 | ## Copyright (C) 2017-2018 Robert McCulloch, Rodney Sparapani 4 | ## and Robert Gramacy 5 | 6 | ## This program is free software; you can redistribute it and/or modify 7 | ## it under the terms of the GNU General Public License as published by 8 | ## the Free Software Foundation; either version 2 of the License, or 9 | ## (at your option) any later version. 10 | 11 | ## This program is distributed in the hope that it will be useful, 12 | ## but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ## GNU General Public License for more details. 15 | 16 | ## You should have received a copy of the GNU General Public License 17 | ## along with this program; if not, a copy is available at 18 | ## https://www.R-project.org/Licenses/GPL-2 19 | 20 | rtnorm=function(n, mean, sd, tau) .Call("crtnorm", n, mean, tau, sd) 21 | 22 | -------------------------------------------------------------------------------- /R/rtnorm_reject.R: -------------------------------------------------------------------------------- 1 | 2 | ## BART: Bayesian Additive Regression Trees 3 | ## Copyright (C) 2017 Robert McCulloch and Rodney Sparapani 4 | 5 | ## This program is free software; you can redistribute it and/or modify 6 | ## it under the terms of the GNU General Public License as published by 7 | ## the Free Software Foundation; either version 2 of the License, or 8 | ## (at your option) any later version. 9 | 10 | ## This program is distributed in the hope that it will be useful, 11 | ## but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ## GNU General Public License for more details. 14 | 15 | ## You should have received a copy of the GNU General Public License 16 | ## along with this program; if not, a copy is available at 17 | ## https://www.R-project.org/Licenses/GPL-2 18 | 19 | rtnorm_reject=function(mean, tau, sd) 20 | .Call("crtnorm_reject", mean, tau, sd) 21 | 22 | -------------------------------------------------------------------------------- /R/spectrum0ar.R: -------------------------------------------------------------------------------- 1 | 2 | ## BART: Bayesian Additive Regression Trees 3 | ## Copyright (C) 2017 Robert McCulloch and Rodney Sparapani 4 | 5 | ## This program is free software; you can redistribute it and/or modify 6 | ## it under the terms of the GNU General Public License as published by 7 | ## the Free Software Foundation; either version 2 of the License, or 8 | ## (at your option) any later version. 9 | 10 | ## This program is distributed in the hope that it will be useful, 11 | ## but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ## GNU General Public License for more details. 14 | 15 | ## You should have received a copy of the GNU General Public License 16 | ## along with this program; if not, a copy is available at 17 | ## https://www.R-project.org/Licenses/GPL-2 18 | 19 | spectrum0ar <- function(x) 20 | { 21 | v0 <- order <- numeric(ncol(x)) 22 | names(v0) <- names(order) <- colnames(x) 23 | z <- 1:nrow(x) 24 | 25 | for (i in 1:ncol(x)) { 26 | lm.out <- lm(x[,i] ~ z) 27 | 28 | if (identical(all.equal(sd(residuals(lm.out)), 0), TRUE)) { 29 | v0[i] <- 0 30 | order[i] <- 0 31 | } 32 | else { 33 | ar.out <- ar(x[,i], aic=TRUE) 34 | v0[i] <- ar.out$var.pred/(1 - sum(ar.out$ar))^2 35 | order[i] <- ar.out$order 36 | } 37 | } 38 | 39 | return(list(spec=v0, order=order)) 40 | } 41 | -------------------------------------------------------------------------------- /R/srstepwise.R: -------------------------------------------------------------------------------- 1 | 2 | ## BART: Bayesian Additive Regression Trees 3 | ## Copyright (C) 2018 Robert McCulloch and Rodney Sparapani 4 | 5 | ## This program is free software; you can redistribute it and/or modify 6 | ## it under the terms of the GNU General Public License as published by 7 | ## the Free Software Foundation; either version 2 of the License, or 8 | ## (at your option) any later version. 9 | 10 | ## This program is distributed in the hope that it will be useful, 11 | ## but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ## GNU General Public License for more details. 14 | 15 | ## You should have received a copy of the GNU General Public License 16 | ## along with this program; if not, a copy is available at 17 | ## https://www.R-project.org/Licenses/GPL-2 18 | 19 | srstepwise=function(x, times, delta, sle=0.15, sls=0.15, dist='lognormal') { 20 | x=cbind(x) 21 | 22 | P=ncol(x) 23 | 24 | in.=c() 25 | out.=1:P 26 | 27 | step=TRUE 28 | H=0 29 | L=P 30 | 31 | y=Surv(time=times, event=delta) 32 | 33 | while(step) { 34 | fits=as.list(1:L) 35 | A=matrix(nrow=L, ncol=H+1) 36 | for(i in 1:L) { 37 | if(H==0) 38 | fits[[i]]=survreg(y~x[ , out.[i]], dist=dist) 39 | else 40 | fits[[i]]=survreg(y~x[ , out.[i]]+x[ , in.], dist=dist) 41 | A[i, ]=pnorm(-abs(coef(fits[[i]])[2:(H+2)]/ 42 | sqrt(diag(vcov(fits[[i]]))[2:(H+2)]))) 43 | } 44 | ##return(A) 45 | 46 | ##forward step 47 | j=which(order(A[ , 1])==1)[1] 48 | if(A[j, 1]0) { 67 | k=which(order(-A[j, ])==1)[1] 68 | if(A[j, k]>=sls) { 69 | out.=c(out., in.[k]) 70 | L=L+1 71 | in.=in.[-k] 72 | H=H-1 73 | if(step && k==1) step=FALSE 74 | else step=TRUE 75 | } 76 | } 77 | } 78 | 79 | return(in.) 80 | } 81 | -------------------------------------------------------------------------------- /R/stratrs.R: -------------------------------------------------------------------------------- 1 | 2 | ## BART: Bayesian Additive Regression Trees 3 | ## Copyright (C) 2017 Rodney Sparapani 4 | 5 | ## This program is free software; you can redistribute it and/or modify 6 | ## it under the terms of the GNU General Public License as published by 7 | ## the Free Software Foundation; either version 2 of the License, or 8 | ## (at your option) any later version. 9 | 10 | ## This program is distributed in the hope that it will be useful, 11 | ## but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ## GNU General Public License for more details. 14 | 15 | ## You should have received a copy of the GNU General Public License 16 | ## along with this program; if not, a copy is available at 17 | ## https://www.R-project.org/Licenses/GPL-2 18 | 19 | stratrs <- function(y, C=5, P=0) 20 | { 21 | N <- length(y) 22 | rs <- integer(N) 23 | 24 | if(P>0) { 25 | ## for continuous variables 26 | Q=quantile(y, probs=(1:(P-1))/P) 27 | 28 | for(i in 1:P) { 29 | if(iQ[P-1]) 34 | rs[y>Q[P-1] ] <- sample(1:M, M)%%C 35 | } 36 | } 37 | } else { 38 | ## for categorical variables 39 | strat <- unique(sort(y)) 40 | 41 | for(i in strat) { 42 | M <- sum(y==i) 43 | rs[y==i] <- sample(1:M, M)%%C 44 | } 45 | } 46 | 47 | return(rs+1) 48 | } 49 | 50 | ## set.seed(12) 51 | ## x <- rbinom(25000, 1, 0.1) 52 | ## a <- stratrs(x) 53 | ## table(a, x) 54 | ## z <- pmin(rpois(25000, 0.8), 5) 55 | ## b <- stratrs(z) 56 | ## table(b, z) 57 | -------------------------------------------------------------------------------- /R/surv.pwbart.R: -------------------------------------------------------------------------------- 1 | 2 | ## BART: Bayesian Additive Regression Trees 3 | ## Copyright (C) 2017 Robert McCulloch and Rodney Sparapani 4 | 5 | ## This program is free software; you can redistribute it and/or modify 6 | ## it under the terms of the GNU General Public License as published by 7 | ## the Free Software Foundation; either version 2 of the License, or 8 | ## (at your option) any later version. 9 | 10 | ## This program is distributed in the hope that it will be useful, 11 | ## but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ## GNU General Public License for more details. 14 | 15 | ## You should have received a copy of the GNU General Public License 16 | ## along with this program; if not, a copy is available at 17 | ## https://www.R-project.org/Licenses/GPL-2 18 | 19 | surv.pwbart <- function( 20 | x.test, #x matrix to predict at with time points expanded 21 | treedraws, #$treedraws for from surv.bart/mc.surv.bart 22 | binaryOffset=0, #mean to add on 23 | mc.cores=1L, 24 | type='pbart', 25 | transposed=FALSE, 26 | nice=19L # mc.surv.pwbart only 27 | ) 28 | { 29 | if(!transposed) x.test <- t(bartModelMatrix(x.test)) 30 | 31 | p <- length(treedraws$cutpoints) 32 | 33 | if(p!=nrow(x.test)) 34 | stop(paste0('The number of columns in x.test must be equal to ', p)) 35 | 36 | pred <- list() 37 | 38 | pred$yhat.test <- pwbart(x.test, treedraws, binaryOffset, mc.cores, TRUE) 39 | 40 | if(class(pred$yhat.test)[1]!='matrix') return(pred$yhat.test) 41 | 42 | x.test <- t(x.test) 43 | pred$tx.test <- x.test 44 | times <- unique(sort(x.test[ , 1])) 45 | pred$times <- times 46 | K <- length(times) 47 | pred$K <- K 48 | 49 | H <- nrow(x.test)/K ## the number of different settings 50 | 51 | if(type=='pbart') pred$prob.test <- pnorm(pred$yhat.test) 52 | else if(type=='lbart') pred$prob.test <- plogis(pred$yhat.test) 53 | 54 | pred$surv.test <- 1-pred$prob.test 55 | 56 | for(h in 1:H) 57 | for(j in 2:K) { 58 | l <- K*(h-1)+j 59 | 60 | pred$surv.test[ , l] <- pred$surv.test[ , l-1]*pred$surv.test[ , l] 61 | } 62 | 63 | pred$surv.test.mean <- apply(pred$surv.test, 2, mean) 64 | 65 | pred$binaryOffset <- binaryOffset 66 | attr(pred, 'class') <- 'survbart' 67 | 68 | return(pred) 69 | } 70 | -------------------------------------------------------------------------------- /build/vignette.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cran/BART/4e177d08a14581ffa25a83b9dde35dfcc8057522/build/vignette.rds -------------------------------------------------------------------------------- /cleanup: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | rm -rf config.* src/Makevars 4 | 5 | for i in README src/TAGS src/BROWSE demo/*.pdf CopyrightReversion.pdf \ 6 | inst/cxx-ex/*.o inst/cxx-ex/*.out inst/cxx-ex/core* \ 7 | demo/myeloid.multi.state.R vignettes/wbart.Rmd vignettes/jss.* \ 8 | vignettes/Sweave.sty vignettes/jsslogo.* \ 9 | R/dpmbart.R man/dpmbart.Rd R/dpmwbart.R man/dpmwbart.Rd \ 10 | src/cdpmbart.cpp src/cdpmwbart.cpp \ 11 | src/dp.h src/dp.cpp src/dpm.h src/dpm.cpp src/dps.h src/dps.cpp \ 12 | cxx-ex/dp.* cxx-ex/dpm.* cxx-ex/dps.* \ 13 | demo/fat.tail.dpm*.R R/*crsk.*.R \ 14 | inst/bootcamp/* src/rtruncnorm.* \ 15 | src/randomkit.* src/rand_draws.* src/latent.* \ 16 | src/arms.* src/cspbart.cpp R/spbart.R R/mc.spbart.R \ 17 | src/cmbart.cpp \ 18 | data/datafromsection13.txt data/leukemia.R \ 19 | src/DpBase.* src/DpMuTau.* src/cdpgbart.cpp \ 20 | R/dpgbart.R demo/cube.dpgbart.R \ 21 | R/gbmm.R R/mc.gbmm.R man/gbmm.Rd src/cgbmm.cpp 22 | do 23 | if [ -f $i ] 24 | then rm -rf $i 25 | fi 26 | done 27 | -------------------------------------------------------------------------------- /cleanup.win: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | rm -rf src/Makevars.win 4 | 5 | for i in README src/TAGS src/BROWSE demo/*.pdf CopyrightReversion.pdf \ 6 | inst/cxx-ex/*.o inst/cxx-ex/*.out inst/cxx-ex/core* \ 7 | demo/myeloid.multi.state.R vignettes/wbart.Rmd vignettes/jss.* \ 8 | vignettes/Sweave.sty vignettes/jsslogo.* \ 9 | R/dpmbart.R man/dpmbart.Rd R/dpmwbart.R man/dpmwbart.Rd \ 10 | src/cdpmbart.cpp src/cdpmwbart.cpp \ 11 | src/dp.h src/dp.cpp src/dpm.h src/dpm.cpp src/dps.h src/dps.cpp \ 12 | cxx-ex/dp.* cxx-ex/dpm.* cxx-ex/dps.* \ 13 | demo/fat.tail.dpm*.R R/*crsk.*.R \ 14 | inst/bootcamp/* src/rtruncnorm.* \ 15 | src/randomkit.* src/rand_draws.* src/latent.* \ 16 | src/arms.* src/cspbart.cpp R/spbart.R R/mc.spbart.R \ 17 | src/cmbart.cpp \ 18 | data/datafromsection13.txt data/leukemia.R \ 19 | src/DpBase.* src/DpMuTau.* src/cdpgbart.cpp \ 20 | R/dpgbart.R demo/cube.dpgbart.R \ 21 | R/gbmm.R R/mc.gbmm.R man/gbmm.Rd src/cgbmm.cpp 22 | do 23 | if [ -f $i ] 24 | then rm -rf $i 25 | fi 26 | done 27 | -------------------------------------------------------------------------------- /configure.ac: -------------------------------------------------------------------------------- 1 | ### configure.ac -*- Autoconf -*- 2 | 3 | dnl Based on OpenMP detection in R's configure script, 4 | dnl which in turn is based on autoconf's openmp.m4, 5 | dnl with is licensed under GPL-3 with the 6 | dnl Autoconf Configure Script Exception, version 3.0. 7 | 8 | AC_PREREQ(2.62) 9 | AC_INIT([BART],[2.94],[],[],[]) 10 | 11 | dnl snippet from 1.24 Using C++11 Code 12 | dnl https://cran.r-project.org/doc/manuals/r-release/R-exts.html#Using-C_002b_002b11-code 13 | dnl C++11 is now the CRAN standard: changing to CXX 14 | CXX=`"${R_HOME}/bin/R" CMD config CXX` 15 | if test -z "$CXX"; then 16 | AC_MSG_ERROR([No C++ compiler is available]) 17 | fi 18 | dnl CXX11STD=`"${R_HOME}/bin/R" CMD config CXX11STD` 19 | dnl CXX="${CXX11} ${CXX11STD}" 20 | CXXFLAGS=`"${R_HOME}/bin/R" CMD config CXXFLAGS` 21 | AC_LANG(C++) 22 | 23 | dnl additional changes as needed 24 | LDFLAGS=`${R_HOME}/bin/R CMD config LDFLAGS` 25 | dnl CPPFLAGS="${CPPFLAGS} -D_OPENMP" 26 | 27 | dnl the meat of R's m4/openmp.m4 28 | AC_LANG(C++) 29 | OPENMP_[]_AC_LANG_PREFIX[]FLAGS= 30 | AC_ARG_ENABLE([openmp], 31 | [AS_HELP_STRING([--disable-openmp], [do not use OpenMP])]) 32 | if test "$enable_openmp" != no; then 33 | AC_CACHE_CHECK([for $[]_AC_CC[] option to support OpenMP], 34 | [ac_cv_prog_[]_AC_LANG_ABBREV[]_openmp], 35 | [AC_LINK_IFELSE([_AC_LANG_OPENMP], 36 | [ac_cv_prog_[]_AC_LANG_ABBREV[]_openmp='none needed'], 37 | [ac_cv_prog_[]_AC_LANG_ABBREV[]_openmp='unsupported' 38 | for ac_option in -xopenmp -fopenmp -qopenmp \ 39 | -openmp -mp -omp -qsmp=omp -homp \ 40 | -fopenmp=libomp \ 41 | -Popenmp --openmp \ 42 | "-Xclang -fopenmp"; do 43 | ac_save_[]_AC_LANG_PREFIX[]FLAGS=$[]_AC_LANG_PREFIX[]FLAGS 44 | _AC_LANG_PREFIX[]FLAGS="$[]_AC_LANG_PREFIX[]FLAGS $ac_option" 45 | AC_LINK_IFELSE([_AC_LANG_OPENMP], 46 | [ac_cv_prog_[]_AC_LANG_ABBREV[]_openmp=$ac_option]) 47 | _AC_LANG_PREFIX[]FLAGS=$ac_save_[]_AC_LANG_PREFIX[]FLAGS 48 | if test "$ac_cv_prog_[]_AC_LANG_ABBREV[]_openmp" != unsupported; then 49 | break 50 | fi 51 | done])]) 52 | case $ac_cv_prog_[]_AC_LANG_ABBREV[]_openmp in #( 53 | "none needed" | unsupported) 54 | ;; #( 55 | *) 56 | OPENMP_[]_AC_LANG_PREFIX[]FLAGS=$ac_cv_prog_[]_AC_LANG_ABBREV[]_openmp ;; 57 | esac 58 | fi 59 | 60 | AC_SUBST(OPENMP_CXXFLAGS) 61 | AC_CONFIG_FILES([src/Makevars]) 62 | AC_OUTPUT 63 | 64 | -------------------------------------------------------------------------------- /data/ACTG175.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cran/BART/4e177d08a14581ffa25a83b9dde35dfcc8057522/data/ACTG175.rda -------------------------------------------------------------------------------- /data/alligator.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cran/BART/4e177d08a14581ffa25a83b9dde35dfcc8057522/data/alligator.rda -------------------------------------------------------------------------------- /data/arq.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cran/BART/4e177d08a14581ffa25a83b9dde35dfcc8057522/data/arq.rda -------------------------------------------------------------------------------- /data/bladder.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cran/BART/4e177d08a14581ffa25a83b9dde35dfcc8057522/data/bladder.rda -------------------------------------------------------------------------------- /data/datalist: -------------------------------------------------------------------------------- 1 | ACTG175 2 | alligator 3 | arq 4 | bladder: bladder bladder1 bladder2 5 | leukemia 6 | lung 7 | transplant 8 | xdm20.test 9 | xdm20.train 10 | ydm20.test 11 | ydm20.train 12 | -------------------------------------------------------------------------------- /data/leukemia.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cran/BART/4e177d08a14581ffa25a83b9dde35dfcc8057522/data/leukemia.rda -------------------------------------------------------------------------------- /data/lung.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cran/BART/4e177d08a14581ffa25a83b9dde35dfcc8057522/data/lung.rda -------------------------------------------------------------------------------- /data/transplant.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cran/BART/4e177d08a14581ffa25a83b9dde35dfcc8057522/data/transplant.rda -------------------------------------------------------------------------------- /data/xdm20.test.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cran/BART/4e177d08a14581ffa25a83b9dde35dfcc8057522/data/xdm20.test.rda -------------------------------------------------------------------------------- /data/xdm20.train.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cran/BART/4e177d08a14581ffa25a83b9dde35dfcc8057522/data/xdm20.train.rda -------------------------------------------------------------------------------- /data/ydm20.test.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cran/BART/4e177d08a14581ffa25a83b9dde35dfcc8057522/data/ydm20.test.rda -------------------------------------------------------------------------------- /data/ydm20.train.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cran/BART/4e177d08a14581ffa25a83b9dde35dfcc8057522/data/ydm20.train.rda -------------------------------------------------------------------------------- /demo/c.surv.bart.R: -------------------------------------------------------------------------------- 1 | 2 | library(BART) 3 | 4 | ## estimate concordance probability: P(t1 -1 24 | j <- y.train > 1 25 | 26 | y.train[!i] <- 1 27 | y.train[i] <- 2 28 | y.train[j] <- 3 29 | 30 | table(y.train) 31 | 32 | ## set.seed(99) 33 | ## post = mbart(x.train, y.train, x.train) 34 | 35 | post = mc.mbart(x.train, y.train, x.train, mc.cores=8, seed=99) 36 | 37 | h <- seq(1, K*N, by=K) 38 | 39 | print(cor(post$prob.test.mean[h], pnorm(-1, Ey.train, sigma))^2) 40 | print(cor(post$prob.test.mean[h+1], pnorm(1, Ey.train, sigma)-pnorm(-1, Ey.train, sigma))^2) 41 | print(cor(post$prob.test.mean[h+2], pnorm(1, Ey.train, sigma, 0))^2) 42 | 43 | par(mfrow=c(2, 2)) 44 | plot(pnorm(-1, Ey.train, sigma), post$prob.test.mean[h], pch='.', 45 | xlim=0:1, ylim=0:1, xlab='Known P(y=1)', ylab='Est. P(y=1)') 46 | abline(0, 1) 47 | plot(pnorm(1, Ey.train, sigma)-pnorm(-1, Ey.train, sigma), post$prob.test.mean[h+1], pch='.', 48 | xlim=0:1, ylim=0:1, xlab='Known P(y=2)', ylab='Est. P(y=2)') 49 | abline(0, 1) 50 | plot(pnorm(1, Ey.train, sigma, 0), post$prob.test.mean[h+2], pch='.', 51 | xlim=0:1, ylim=0:1, xlab='Known P(y=3)', ylab='Est. P(y=3)') 52 | abline(0, 1) 53 | par(mfrow=c(1, 1)) 54 | 55 | -------------------------------------------------------------------------------- /demo/exp.recur.bart.R: -------------------------------------------------------------------------------- 1 | 2 | library(BART) 3 | 4 | ## simulate recurrent events data set with Exponential proportional intensity 5 | N <- 250 6 | K <- 60 7 | NK <- N*K 8 | C <- 8 9 | 10 | set.seed(-1) 11 | 12 | x <- matrix(nrow=NK, ncol=23) 13 | dimnames(x)[[2]] <- c('t', 'v', 'N', paste0('x', 1:20)) 14 | 15 | b <- c(1.0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 16 | 1.5, 0, 0, 0, 0, 0, 0, 0, 0, 0) 17 | 18 | N. <- double(NK) 19 | y <- integer(NK) 20 | cum <- double(NK) 21 | k <- 1 22 | 23 | for(i in 1:N) { 24 | v <- 0 25 | x[k, 4:13] <- runif(10) 26 | x[k, 14:23] <- rbinom(10, 1, 0.5) 27 | 28 | for(j in 1:K) { 29 | x[k, 1:3] <- c(j, j-v, N.[k]) 30 | if(j>1) x[k, 4:23] <- x[k-1, 4:23] 31 | alpha <- 0.0001*exp(sum(b*x[k, 4:23])+sqrt(N.[k])) 32 | cum[k] <- pexp(30, alpha) 33 | y[k] <- rbinom(1, 1, cum[k]) 34 | 35 | if(y[k]==1) v <- j 36 | 37 | if(j>1) cum[k] <- cum[k-1]+cum[k] 38 | if(j1] <- 2 21 | table(delta, transplant$event) 22 | 23 | times <- pmax(1, transplant$futime/7) ## weeks 24 | ##times <- pmax(1, ceiling(transplant$futime/30.5)) ## months 25 | 26 | typeO <- 1*(transplant$abo=='O') 27 | typeA <- 1*(transplant$abo=='A') 28 | typeB <- 1*(transplant$abo=='B') 29 | typeAB <- 1*(transplant$abo=='AB') 30 | table(typeA, typeO) 31 | 32 | x.train <- cbind(typeO, typeA, typeB, typeAB) 33 | 34 | x.test <- cbind(1, 0, 0, 0) 35 | dimnames(x.test)[[2]] <- dimnames(x.train)[[2]] 36 | 37 | ## pre <- crisk.pre.bart(x.train=x.train, times=times, delta=delta, 38 | ## x.test=x.test, K=50) 39 | 40 | ## run one long MCMC chain in one process 41 | ## set.seed(99) 42 | ## post <- crisk.bart(x.train=x.train, times=times, delta=delta, x.test=x.test) 43 | 44 | ## in the interest of time, consider speeding it up by parallel processing 45 | ## run "mc.cores" number of shorter MCMC chains in parallel processes 46 | post <- mc.crisk.bart(x.train=x.train, times=times, delta=delta, x.test=x.test, 47 | K=50, seed=99, mc.cores=8) 48 | 49 | K <- post$K 50 | 51 | typeO.cif.mean <- apply(post$cif.test, 2, mean) 52 | typeO.cif.025 <- apply(post$cif.test, 2, quantile, probs=0.025) 53 | typeO.cif.975 <- apply(post$cif.test, 2, quantile, probs=0.975) 54 | 55 | plot(pfit[4,], xscale=7, xmax=735, col=1:3, lwd=2, ylim=c(0, 0.8), 56 | xlab='t (weeks)', ylab='CI(t)') 57 | points(c(0, post$times)*7, c(0, typeO.cif.mean), col=4, type='s', lwd=2) 58 | points(c(0, post$times)*7, c(0, typeO.cif.025), col=4, type='s', lwd=2, lty=2) 59 | points(c(0, post$times)*7, c(0, typeO.cif.975), col=4, type='s', lwd=2, lty=2) 60 | legend(450, .4, c("Transplant(BART)", "Transplant(AJ)", 61 | "Death(AJ)", "Withdrawal(AJ)"), 62 | col=c(4, 2, 1, 3), lwd=2) 63 | ## plot(pfit[4,], xscale=30.5, xmax=735, col=1:3, lwd=2, ylim=c(0, 0.8), 64 | ## xlab='t (months)', ylab='CI(t)') 65 | ## points(c(0, post$times)*30.5, c(0, typeO.cif.mean), col=4, type='s', lwd=2) 66 | ## points(c(0, post$times)*30.5, c(0, typeO.cif.025), col=4, type='s', lwd=2, lty=2) 67 | ## points(c(0, post$times)*30.5, c(0, typeO.cif.975), col=4, type='s', lwd=2, lty=2) 68 | ## legend(450, .4, c("Transplant(BART)", "Transplant(AJ)", 69 | ## "Death(AJ)", "Withdrawal(AJ)"), 70 | ## col=c(4, 2, 1, 3), lwd=2) 71 | -------------------------------------------------------------------------------- /demo/lung.surv.bart.R: -------------------------------------------------------------------------------- 1 | 2 | library(BART) 3 | 4 | B <- getOption('mc.cores', 1) 5 | figures = getOption('figures', default='NONE') 6 | 7 | ## load survival package for the advanced lung cancer example 8 | data(lung) 9 | 10 | N <- length(lung$status) 11 | 12 | table(lung$ph.karno, lung$pat.karno) 13 | 14 | ## if physician's KPS unavailable, then use the patient's 15 | h <- which(is.na(lung$ph.karno)) 16 | lung$ph.karno[h] <- lung$pat.karno[h] 17 | 18 | times <- lung$time 19 | delta <- lung$status-1 ##lung$status: 1=censored, 2=dead 20 | ##delta: 0=censored, 1=dead 21 | 22 | ## this study reports time in days rather than weeks or months 23 | ## coarsening from days to weeks or months will reduce the computational burden 24 | ##times <- ceiling(times/30) 25 | times <- ceiling(times/7) ## weeks 26 | 27 | ##table(times) 28 | table(delta) 29 | 30 | ## matrix of observed covariates 31 | x.train <- cbind(lung$sex, lung$age, lung$ph.karno) 32 | 33 | ## lung$sex: Male=1 Female=2 34 | ## lung$age: Age in years 35 | ## lung$ph.karno: Karnofsky performance score (dead=0:normal=100:by=10) 36 | ## rated by physician 37 | 38 | dimnames(x.train)[[2]] <- c('M(1):F(2)', 'age(39:82)', 'ph.karno(50:100:10)') 39 | 40 | table(x.train[ , 1]) 41 | summary(x.train[ , 2]) 42 | table(x.train[ , 3]) 43 | 44 | ## run one long MCMC chain in one process 45 | ## set.seed(99) 46 | ## post <- surv.bart(x.train=x.train, times=times, delta=delta, x.test=x.test) 47 | 48 | ## in the interest of time, consider speeding it up by parallel processing 49 | ## run "mc.cores" number of shorter MCMC chains in parallel processes 50 | post <- mc.surv.bart(x.train=x.train, times=times, delta=delta, 51 | mc.cores=B, seed=99)##(, K=50) 52 | 53 | pre <- surv.pre.bart(times=times, delta=delta, x.train=x.train, 54 | x.test=x.train)##(, K=50) 55 | 56 | K <- pre$K 57 | M <- post$ndpost 58 | 59 | pre$tx.test <- rbind(pre$tx.test, pre$tx.test) 60 | pre$tx.test[ , 2] <- c(rep(1, N*K), rep(2, N*K)) 61 | ## sex pushed to col 2, since time is always in col 1 62 | 63 | pred <- predict(post, newdata=pre$tx.test, mc.cores=B) 64 | 65 | pd <- matrix(nrow=M, ncol=2*K) 66 | 67 | for(j in 1:K) { 68 | h <- seq(j, N*K, by=K) 69 | pd[ , j] <- apply(pred$surv.test[ , h], 1, mean) 70 | pd[ , j+K] <- apply(pred$surv.test[ , h+N*K], 1, mean) 71 | } 72 | 73 | pd.mu <- apply(pd, 2, mean) 74 | pd.025 <- apply(pd, 2, quantile, probs=0.025) 75 | pd.975 <- apply(pd, 2, quantile, probs=0.975) 76 | 77 | males <- 1:K 78 | females <- males+K 79 | 80 | plot(c(0, pre$times), c(1, pd.mu[males]), type='s', col='blue', 81 | ylim=0:1, ylab='S(t, x)', xlab='t (weeks)') 82 | ## main=paste('Advanced Lung Cancer ex. (BART::lung)', 83 | ## "Friedman's partial dependence function", 84 | ## 'Male (blue) vs. Female (red)', sep='\n')) 85 | lines(c(0, pre$times), c(1, pd.025[males]), col='blue', type='s', lty=2) 86 | lines(c(0, pre$times), c(1, pd.975[males]), col='blue', type='s', lty=2) 87 | lines(c(0, pre$times), c(1, pd.mu[females]), col='red', type='s') 88 | lines(c(0, pre$times), c(1, pd.025[females]), col='red', type='s', lty=2) 89 | lines(c(0, pre$times), c(1, pd.975[females]), col='red', type='s', lty=2) 90 | if(figures!='NONE') 91 | dev.copy2pdf(file=paste(figures, 'lung.pdf', sep='/')) 92 | -------------------------------------------------------------------------------- /demo/lung.surv.ice.R: -------------------------------------------------------------------------------- 1 | 2 | library(BART) 3 | 4 | B <- getOption('mc.cores', 1) 5 | figures = getOption('figures', default='NONE') 6 | 7 | ## load survival package for the advanced lung cancer example 8 | data(lung) 9 | 10 | N <- length(lung$status) 11 | 12 | table(lung$ph.karno, lung$pat.karno) 13 | 14 | ## if physician's KPS unavailable, then use the patient's 15 | h <- which(is.na(lung$ph.karno)) 16 | lung$ph.karno[h] <- lung$pat.karno[h] 17 | 18 | times <- lung$time 19 | delta <- lung$status-1 ##lung$status: 1=censored, 2=dead 20 | ##delta: 0=censored, 1=dead 21 | 22 | ## this study reports time in days rather than weeks or months 23 | ## coarsening from days to weeks or months will reduce the computational burden 24 | ##times <- ceiling(times/30) 25 | times <- ceiling(times/7) ## weeks 26 | 27 | ##table(times) 28 | table(delta) 29 | 30 | ## matrix of observed covariates 31 | x.train <- cbind(lung$sex, lung$age, lung$ph.karno) 32 | 33 | ## lung$sex: Male=1 Female=2 34 | ## lung$age: Age in years 35 | ## lung$ph.karno: Karnofsky performance score (dead=0:normal=100:by=10) 36 | ## rated by physician 37 | 38 | dimnames(x.train)[[2]] <- c('M(1):F(2)', 'age(39:82)', 'ph.karno(50:100:10)') 39 | 40 | table(x.train[ , 1]) 41 | summary(x.train[ , 2]) 42 | table(x.train[ , 3]) 43 | 44 | ## run one long MCMC chain in one process 45 | ## set.seed(99) 46 | ## post <- surv.bart(x.train=x.train, times=times, delta=delta, x.test=x.test) 47 | 48 | ## in the interest of time, consider speeding it up by parallel processing 49 | ## run "mc.cores" number of shorter MCMC chains in parallel processes 50 | post <- mc.surv.bart(x.train=x.train, times=times, delta=delta, 51 | mc.cores=B, seed=99, K=100) 52 | 53 | pre <- surv.pre.bart(times=times, delta=delta, x.train=x.train, 54 | x.test=x.train, K=100) 55 | 56 | K <- pre$K 57 | M <- post$ndpost 58 | NK <- N*K 59 | 60 | pre$tx.test <- rbind(pre$tx.test, pre$tx.test) 61 | pre$tx.test[ , 2] <- c(rep(1, N*K), rep(2, N*K)) 62 | ## sex pushed to col 2, since time is always in col 1 63 | 64 | pred <- predict(post, newdata=pre$tx.test, mc.cores=B) 65 | 66 | for(i in seq(1, N, by=5)) { 67 | ##for(i in 1:N) { 68 | h=(i-1)*K+1:K 69 | if(i==1) 70 | plot(c(0, pre$times), c(1, pred$surv.test.mean[h]), 71 | type='s', col=4, lty=2, 72 | ylim=0:1, ylab='S(t, x)', xlab='t (weeks)',) 73 | else lines(c(0, pre$times), c(1, pred$surv.test.mean[h]), 74 | type='s', col=4, lty=2) 75 | lines(c(0, pre$times), c(1, pred$surv.test.mean[h+NK]), 76 | type='s', col=2, lty=3) 77 | } 78 | 79 | if(figures!='NONE') 80 | dev.copy2pdf(file=paste(figures, 'lung-ice.pdf', sep='/')) 81 | -------------------------------------------------------------------------------- /demo/lung.surv.lbart.R: -------------------------------------------------------------------------------- 1 | 2 | library(BART) 3 | 4 | ## load survival package for the advanced lung cancer example 5 | data(lung) 6 | 7 | N <- length(lung$status) 8 | 9 | table(lung$ph.karno, lung$pat.karno) 10 | 11 | ## if physician's KPS unavailable, then use the patient's 12 | h <- which(is.na(lung$ph.karno)) 13 | lung$ph.karno[h] <- lung$pat.karno[h] 14 | 15 | times <- lung$time 16 | delta <- lung$status-1 ##lung$status: 1=censored, 2=dead 17 | ##delta: 0=censored, 1=dead 18 | 19 | ## this study reports time in days rather than weeks or months 20 | ## coarsening from days to weeks or months will reduce the computational burden 21 | ##times <- ceiling(times/30) 22 | ##times <- ceiling(times/7) ## weeks 23 | 24 | ##table(times) 25 | table(delta) 26 | 27 | ## matrix of observed covariates 28 | x.train <- cbind(lung$sex, lung$age, lung$ph.karno) 29 | 30 | ## lung$sex: Male=1 Female=2 31 | ## lung$age: Age in years 32 | ## lung$ph.karno: Karnofsky performance score (dead=0:normal=100:by=10) 33 | ## rated by physician 34 | 35 | dimnames(x.train)[[2]] <- c('M(1):F(2)', 'age(39:82)', 'ph.karno(50:100:10)') 36 | 37 | table(x.train[ , 1]) 38 | summary(x.train[ , 2]) 39 | table(x.train[ , 3]) 40 | 41 | ## run one long MCMC chain in one process 42 | ## set.seed(99) 43 | ## post <- surv.bart(x.train=x.train, times=times, delta=delta, x.test=x.test) 44 | 45 | ## in the interest of time, consider speeding it up by parallel processing 46 | ## run "mc.cores" number of shorter MCMC chains in parallel processes 47 | post <- mc.surv.bart(x.train=x.train, times=times, delta=delta, 48 | K=50, type='lbart', mc.cores=8, seed=99) 49 | 50 | pre <- surv.pre.bart(times=times, delta=delta, x.train=x.train, 51 | x.test=x.train, K=50) 52 | 53 | K <- pre$K 54 | M <- nrow(post$yhat.train) 55 | 56 | pre$tx.test <- rbind(pre$tx.test, pre$tx.test) 57 | pre$tx.test[ , 2] <- c(rep(1, N*K), rep(2, N*K)) 58 | ## sex pushed to col 2, since time is always in col 1 59 | 60 | pred <- predict(post, newdata=pre$tx.test, mc.cores=8) 61 | 62 | pd <- matrix(nrow=M, ncol=2*K) 63 | 64 | for(j in 1:K) { 65 | h <- seq(j, N*K, by=K) 66 | pd[ , j] <- apply(pred$surv.test[ , h], 1, mean) 67 | pd[ , j+K] <- apply(pred$surv.test[ , h+N*K], 1, mean) 68 | } 69 | 70 | pd.mu <- apply(pd, 2, mean) 71 | pd.025 <- apply(pd, 2, quantile, probs=0.025) 72 | pd.975 <- apply(pd, 2, quantile, probs=0.975) 73 | 74 | males <- 1:K 75 | females <- males+K 76 | 77 | par(mfrow=c(2, 1)) 78 | 79 | plot(c(0, pre$times), c(1, pd.mu[males]), type='s', col='blue', 80 | ylim=0:1, ylab='S(t, x)', xlab='t (days)', ##xlab='t (weeks)', 81 | main=paste('Advanced Lung Cancer ex. (BART::lung)', 82 | "Friedman's partial dependence function", 83 | 'Top: Logistic BART, Bottom: Probit BART', 84 | sep='\n')) 85 | lines(c(0, pre$times), c(1, pd.025[males]), col='blue', type='s', lty=2) 86 | lines(c(0, pre$times), c(1, pd.975[males]), col='blue', type='s', lty=2) 87 | lines(c(0, pre$times), c(1, pd.mu[females]), col='red', type='s') 88 | lines(c(0, pre$times), c(1, pd.025[females]), col='red', type='s', lty=2) 89 | lines(c(0, pre$times), c(1, pd.975[females]), col='red', type='s', lty=2) 90 | 91 | source(system.file('demo/lung.surv.bart.R', package='BART')) 92 | 93 | par(mfrow=c(1, 1)) 94 | -------------------------------------------------------------------------------- /demo/missing.gbart.R: -------------------------------------------------------------------------------- 1 | 2 | library(BART) 3 | 4 | set.seed(12) 5 | N=50 6 | P=3 7 | 8 | x.train=matrix(runif(N*P, -1, 1), nrow=N, ncol=P) 9 | y=x.train[ , 1]^3 10 | x.miss=matrix(1*(runif(N*P)<0.05), nrow=N, ncol=P) 11 | x.train=x.train*(1-x.miss) 12 | x.train[x.train==0]=NA 13 | 14 | post=gbart(x.train, y, x.train) 15 | 16 | summary(post$yhat.train.mean) 17 | summary(post$yhat.test.mean) 18 | 19 | plot(post$yhat.train.mean, post$yhat.test.mean) 20 | 21 | -------------------------------------------------------------------------------- /demo/nhanes.pbart2.R: -------------------------------------------------------------------------------- 1 | 2 | library(BART) 3 | 4 | B <- getOption('mc.cores', 1) 5 | figures = getOption('figures', default='NONE') 6 | 7 | data(arq) 8 | str(arq) 9 | arth <- as.matrix(arq) 10 | 11 | N <- length(arth[ , 'riagendr']) 12 | table(arth[ , 'riagendr']) 13 | summary(arth[ , 'bmxbmi']) 14 | 15 | post1 <- mc.pbart(x.train=arth[ , 5:10], y.train=arth[ , 4], 16 | mc.cores=B, seed=99) 17 | 18 | post2 <- mc.pbart(x.train=arth[ , 5:10], y.train=arth[ , 3], 19 | mc.cores=B, seed=99) 20 | 21 | bmxbmi <- seq(15, 45, by=5) 22 | H <- length(bmxbmi) 23 | 24 | for(i in 1:2) 25 | for(j in 1:H) { 26 | x. <- arth[ , 5:10] 27 | x.[ , 'riagendr'] <- i 28 | x.[ , 'bmxbmi'] <- bmxbmi[j] 29 | if(i==1 && j==1) x.test <- x. 30 | else x.test <- rbind(x.test, x.) 31 | } 32 | 33 | table(x.test[ , 'riagendr']) 34 | table(x.test[ , 'bmxbmi']) 35 | 36 | pred1 <- predict(post1, newdata=x.test, mc.cores=B) 37 | pred2 <- predict(post2, newdata=x.test, mc.cores=B) 38 | 39 | M <- nrow(pred1$prob.test) 40 | ##Friedman's partial dependence function 41 | pd1 <- matrix(nrow=M, ncol=H) 42 | pd2 <- matrix(nrow=M, ncol=H) 43 | k <- (H+2)*N ## baseline: 25 BMI for women 44 | ##k <- 2*N ## baseline: 25 BMI for men 45 | for(j in 1:H) { 46 | h <- (H+j-1)*N ## women 47 | ##h <- (j-1)*N ## men 48 | pd1[ , j] <- apply(pred1$prob.test[ , h+1:N]- 49 | pred1$prob.test[ , k+1:N], 1, mean) 50 | pd2[ , j] <- apply(pred2$prob.test[ , h+1:N]- 51 | pred2$prob.test[ , k+1:N], 1, mean) 52 | } 53 | pd1.mean <- apply(pd1, 2, mean) 54 | pd2.mean <- apply(pd2, 2, mean) 55 | pd1.025 <- apply(pd1, 2, quantile, probs=0.025) 56 | pd2.025 <- apply(pd2, 2, quantile, probs=0.025) 57 | pd1.975 <- apply(pd1, 2, quantile, probs=0.975) 58 | pd2.975 <- apply(pd2, 2, quantile, probs=0.975) 59 | 60 | par(mfrow=c(1, 2)) 61 | 62 | plot(bmxbmi, pd1.mean, type='l', col='blue', 63 | ylim=c(-0.2, 0.2), 64 | ## ylim=c(min(pd1.025, pd2.025, -pd1.975, -pd2.975), 65 | ## max(-pd1.025, -pd2.025, pd1.975, pd2.975)), 66 | xlab='BMI', ylab=expression(p(x)-p(25)), 67 | sub='Chronic pain: low-back(blue)') 68 | ##sub='Chronic pain: low-back/buttock(blue)') 69 | lines(bmxbmi, pd1.025, type='l', col='blue', lty=2) 70 | lines(bmxbmi, pd1.975, type='l', col='blue', lty=2) 71 | lines(bmxbmi, rep(0, H)) 72 | 73 | plot(bmxbmi, pd2.mean, type='l', col='red', 74 | ylim=c(-0.2, 0.2), 75 | ## ylim=c(min(pd1.025, pd2.025, -pd1.975, -pd2.975), 76 | ## max(-pd1.025, -pd2.025, pd1.975, pd2.975)), 77 | xlab='BMI', ylab=expression(p(x)-p(25)), 78 | sub='Chronic pain: neck(red)') 79 | lines(bmxbmi, pd2.025, type='l', col='red', lty=2) 80 | lines(bmxbmi, pd2.975, type='l', col='red', lty=2) 81 | lines(bmxbmi, rep(0, H)) 82 | 83 | par(mfrow=c(1, 1)) 84 | 85 | if(figures!='NONE') 86 | dev.copy2pdf(file=paste(figures, 'chronic-pain2.pdf', sep='/')) 87 | ##dev.copy2pdf(file='../vignettes/figures/chronic-pain2.pdf') 88 | 89 | -------------------------------------------------------------------------------- /demo/nox.R: -------------------------------------------------------------------------------- 1 | library(BART) 2 | library(MASS) 3 | 4 | ##options(figures='../vignettes/figures') 5 | 6 | B <- getOption('mc.cores', 1) 7 | figures = getOption('figures', default='NONE') 8 | 9 | y = Boston$medv # median value 10 | x.train = as.matrix(cbind(Boston[ , -c(5, 14)], Boston[ , 5])) 11 | dimnames(x.train)[[2]][13] = 'nox' 12 | N=length(y) ## total sample size 13 | post = mc.gbart(x.train, y, mc.cores=B, seed=99) 14 | 15 | L=41 16 | x=seq(min(x.train[ , 13]), max(x.train[ , 13]), length.out=L) 17 | 18 | x.test = cbind(x.train[ , -13], x[1]) 19 | names(x.test)[13]='nox' 20 | for(j in 2:L) 21 | x.test = rbind(x.test, cbind(x.train[ , -13], x[j])) 22 | 23 | pred = predict(post, x.test, mc.cores=B) 24 | 25 | partial = matrix(nrow=1000, ncol=L) 26 | for(j in 1:L) { 27 | h=(j-1)*N+1:N 28 | partial[ , j] = apply(pred[ , h], 1, mean) 29 | } 30 | 31 | plot(x, apply(partial, 2, mean), type='l', lwd=2, 32 | ##xlab='nox', ylab='mdev', 33 | xlab='nox: Nitrogen Oxides air pollution', 34 | ylab='mdev: median home value (in thousands)', 35 | ylim=c(0, 50)) 36 | lines(x, apply(partial, 2, quantile, probs=0.025), lty=2, lwd=2) 37 | lines(x, apply(partial, 2, quantile, probs=0.975), lty=2, lwd=2) 38 | abline(h=c(0, 50), col='gray') 39 | ## uncomment for an ICE plot 40 | ## for(i in seq(1, N, by=10)) 41 | ## lines(x, apply(pred[ , seq(i, N*L, by=N)], 2, mean), type='l', 42 | ## lty=3, col='green') 43 | 44 | ## model similar to that presented in Harrison and Rubinfeld (1978) 45 | fit=lm(log(y)~I(rm^2)+age+I(log(dis))+I(log(rad))+tax+ptratio+ 46 | I((black-0.63)^2)+I(log(lstat))+crim+zn+indus+chas+ 47 | I((nox-0.55)^2), data=Boston) 48 | summary(fit) 49 | lines(x, mean(y)*exp((x-0.55)^2*fit$coefficients[14]), lty=3, col='red', lwd=2) 50 | 51 | if(figures!='NONE') 52 | dev.copy2pdf(file=paste(figures, 'nox.pdf', sep='/')) 53 | 54 | if(figures!='NONE') 55 | dev.copy2eps(file=paste(figures, 'nox.eps', sep='/')) 56 | -------------------------------------------------------------------------------- /demo/np.recur.bart.R: -------------------------------------------------------------------------------- 1 | 2 | library(BART) 3 | 4 | ## simulate recurrent events data set with Exponential nonproportional intensity 5 | N <- 250 6 | K <- 60 7 | NK <- N*K 8 | C <- 8 9 | 10 | set.seed(-1) 11 | 12 | x <- matrix(nrow=NK, ncol=23) 13 | dimnames(x)[[2]] <- c('t', 'v', 'N', paste0('x', 1:20)) 14 | 15 | b <- c(1.0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 16 | 1.5, 0, 0, 0, 0, 0, 0, 0, 0, 0) 17 | 18 | N. <- double(NK) 19 | y <- integer(NK) 20 | cum <- double(NK) 21 | k <- 1 22 | 23 | for(i in 1:N) { 24 | v <- 0 25 | x[k, 4:13] <- runif(10) 26 | x[k, 14:23] <- rbinom(10, 1, 0.5) 27 | 28 | for(j in 1:K) { 29 | x[k, 1:3] <- c(j, j-v, N.[k]) 30 | if(j>1) x[k, 4:23] <- x[k-1, 4:23] 31 | alpha <- 0.0001*exp(sum(b*x[k, 4:23])*2*(N.[k]+1)/sqrt(j)) 32 | cum[k] <- pexp(30, alpha) 33 | y[k] <- rbinom(1, 1, cum[k]) 34 | 35 | if(y[k]==1) v <- j 36 | 37 | if(j>1) cum[k] <- cum[k-1]+cum[k] 38 | if(j0)*1 27 | 28 | post[[i]] = mc.lbart(x.train, y.train, mc.cores=C, 29 | keepevery=1, sparse=TRUE, seed=99) 30 | 31 | plot(post[[i]]$varprob.mean, col=c(rep(2, 5), rep(1, P-5)), 32 | main=paste0('N:', N, ', P:', P, ', thin:', thin[i]), 33 | ylab='Selection Probability', ylim=c(0, 0.2), 34 | pch=1+45*(post[[i]]$varprob.mean <= 1/P)) 35 | lines(c(0, 100), c(1/P, 1/P)) 36 | 37 | table(1+45*(post[[i]]$varprob.mean <= 1/P)) 38 | } 39 | 40 | par(mfrow=c(1, 1)) 41 | 42 | ##dev.copy2pdf(file='sparse-lbart.pdf') 43 | -------------------------------------------------------------------------------- /demo/sparse.pbart.R: -------------------------------------------------------------------------------- 1 | 2 | library(BART) 3 | 4 | B <- getOption('mc.cores', 1) 5 | figures = getOption('figures', default='NONE') 6 | 7 | ##simulate from Friedman's five-dimensional test function 8 | ##Friedman JH. Multivariate adaptive regression splines 9 | ##(with discussion and a rejoinder by the author). 10 | ##Annals of Statistics 1991; 19:1-67. 11 | 12 | f = function(x) #only the first 5 matter 13 | sin(pi*x[ , 1]*x[ , 2]) + 2*(x[ , 3]-.5)^2+x[ , 4]+0.5*x[ , 5]-1.5 14 | 15 | sigma = 1.0 #y = f(x) + sigma*z where z~N(0, 1) 16 | P = 100 #number of covariates 17 | thin <- c(10, 10, 10) 18 | n <- c(200, 1000, 5000) 19 | 20 | post <- as.list(1:3) 21 | 22 | for(i in 1:3) { 23 | N <- n[i] 24 | set.seed(12) 25 | x.train=matrix(runif(N*P), N, P) 26 | Ey.train = f(x.train) 27 | y.train=((Ey.train+sigma*rnorm(N))>0)*1 28 | 29 | post[[i]] = mc.pbart(x.train, y.train, mc.cores=B, 30 | keepevery=thin[i], sparse=TRUE, seed=99) 31 | } 32 | 33 | par(mfrow=c(3, 1)) 34 | 35 | for(i in 1:3) { 36 | N <- n[i] 37 | plot(post[[i]]$varprob.mean, col=c(rep(2, 5), rep(1, P-5)), 38 | main=paste0('N:', N, ', P:', P, ', thin:', thin[i]), 39 | ylab='Selection Probability', ylim=c(0, 0.3), 40 | pch=1+45*(post[[i]]$varprob.mean <= 1/P)) 41 | lines(c(0, 100), c(1/P, 1/P)) 42 | 43 | table(1+45*(post[[i]]$varprob.mean <= 1/P)) 44 | } 45 | 46 | par(mfrow=c(1, 1)) 47 | 48 | if(figures!='NONE') 49 | dev.copy2pdf(file=paste(figures, 'sparse-pbart.pdf', sep='/')) 50 | -------------------------------------------------------------------------------- /demo/sparse.wbart.R: -------------------------------------------------------------------------------- 1 | 2 | library(BART) 3 | 4 | ##simulate from Friedman's five-dimensional test function 5 | ##Friedman JH. Multivariate adaptive regression splines 6 | ##(with discussion and a rejoinder by the author). 7 | ##Annals of Statistics 1991; 19:1-67. 8 | 9 | f = function(x) #only the first 5 matter 10 | sin(pi*x[ , 1]*x[ , 2]) + 2*(x[ , 3]-.5)^2+x[ , 4]+0.5*x[ , 5]-1.5 11 | 12 | sigma = 1.0 #y = f(x) + sigma*z where z~N(0, 1) 13 | k = 100 #number of covariates 14 | ndpost = 1000 15 | nskip = 100 16 | C = 8 17 | 18 | par(mfrow=c(3, 2)) 19 | 20 | post <- as.list(1:6) 21 | 22 | for(i in 1:3) { 23 | n <- 10^(1+i) 24 | set.seed(12) 25 | x.train=matrix(runif(n*k), n, k) 26 | Ey.train = f(x.train) 27 | y.train=Ey.train+sigma*rnorm(n) 28 | 29 | for(j in c(TRUE, FALSE)) { 30 | h <- (i-1)*2+j+1 31 | post[[h]] = mc.wbart(x.train, y.train, mc.cores=C, sparse=TRUE, 32 | augment=j, seed=99, ndpost=ndpost, nskip=nskip) 33 | 34 | plot(post[[h]]$varprob.mean, col=c(rep(2, 5), rep(1, k-5)), 35 | main=paste0('N:', n, ', P:', k, ', Assumption:', c(2.2, 2.1)[j+1]), 36 | ##sub=expression(-1.5+sin(pi*x[1]*x[2]) + 2*(x[3]-.5)^2+x[4]+0.5*x[5]), 37 | ylab='Selection Probability', ylim=0:1) 38 | lines(c(0, 100), c(1/k, 1/k)) 39 | } 40 | } 41 | 42 | par(mfrow=c(1, 1)) 43 | 44 | ##dev.copy2pdf(file='sparse.wbart.pdf') 45 | 46 | ## check1=pwbart(x.train, post[[6]]$treedraws, post[[6]]$mu) 47 | ## plot(apply(check1, 2, mean), post[[6]]$yhat.train.mean) 48 | 49 | ## check2=pwbart(x.train, post[[6]]$treedraws, post[[6]]$mu, dodraws=FALSE) 50 | ## plot(check2, post[[6]]$yhat.train.mean) 51 | 52 | ## check1=mc.pwbart(x.train, post[[6]]$treedraws, post[[6]]$mu, mc.cores=C) 53 | ## plot(apply(check1, 2, mean), post[[6]]$yhat.train.mean) 54 | 55 | ## check2=mc.pwbart(x.train, post[[6]]$treedraws, post[[6]]$mu, mc.cores=C, 56 | ## dodraws=FALSE) 57 | ## plot(check2, post[[6]]$yhat.train.mean) 58 | -------------------------------------------------------------------------------- /demo/test.draw_lambda_i.R: -------------------------------------------------------------------------------- 1 | library(BART) 2 | 3 | T <- 1 4 | MU <- 0 5 | 6 | set.seed(12) 7 | 8 | lambda <- draw_lambda_i(1, MU) 9 | rtnorm(1, MU, sqrt(lambda), T) 10 | ##rtnorm(MU, T, sqrt(lambda)) 11 | 12 | set.seed(12) 13 | 14 | N <- 10000 15 | 16 | lambda <- draw_lambda_i(1, MU) 17 | y <- rtnorm(N, MU, sqrt(lambda), T) 18 | ##y <- rtnorm(MU, T, sqrt(lambda)) 19 | 20 | for(i in 2:N) { 21 | lambda[i] <- draw_lambda_i(lambda[i-1], MU) 22 | ##y[i] <- rtnorm(MU, T, sqrt(lambda[i])) 23 | } 24 | 25 | x <- seq(T, T+2, length.out=1000) 26 | 27 | plot(x, dlogis(x, MU, 1)/plogis(T, MU, 1, lower.tail=FALSE), 28 | lty=2, type='l', 29 | ylab=expression(Logistic(MU, 1))) 30 | lines(density(y)) 31 | abline(v=T) 32 | 33 | ##dev.copy2pdf(file='test.draw_lambda_i.pdf') 34 | -------------------------------------------------------------------------------- /demo/test.rtgamma.R: -------------------------------------------------------------------------------- 1 | library(BART) 2 | 3 | N <- 1 4 | A <- 3 5 | SHAPE <- 5 6 | RATE <- 0.5 7 | 8 | set.seed(12) 9 | 10 | rtgamma(N, SHAPE, RATE, A) 11 | 12 | set.seed(12) 13 | 14 | rtgamma(N, SHAPE, RATE, A) 15 | 16 | set.seed(12) 17 | 18 | N <- 10000 19 | 20 | y <- 0 21 | 22 | y <- rtgamma(N, SHAPE, RATE, A) 23 | ##for(i in 1:N) y[i] <- rtgamma(SHAPE, RATE, A) 24 | 25 | x <- seq(A, 4*A, length.out=1000) 26 | plot(x, dgamma(x, SHAPE, RATE)/pgamma(A, SHAPE, RATE, lower.tail=FALSE), 27 | lty=2, type='l', ylim=c(0, 1), 28 | ylab=expression(Gam(SHAPE, RATE))) 29 | lines(density(y, from=A), col='red') 30 | abline(v=A) 31 | dev.copy2pdf(file='test.rtgamma.pdf') 32 | -------------------------------------------------------------------------------- /demo/test.rtnorm.R: -------------------------------------------------------------------------------- 1 | library(BART) 2 | 3 | N <- 1 4 | T <- 8 5 | MU <- 5 6 | SD <- 0.5 7 | 8 | set.seed(12) 9 | 10 | rtnorm(N, MU, SD, T) 11 | 12 | set.seed(12) 13 | 14 | rtnorm(N, MU, SD, T) 15 | 16 | set.seed(12) 17 | 18 | N <- 10000 19 | 20 | y <- rtnorm(N, MU, SD, T) 21 | 22 | x <- seq(T, T+2*SD, length.out=1000) 23 | 24 | plot(x, dnorm(x, MU, SD)/pnorm(T, MU, SD, lower.tail=FALSE), 25 | lty=2, type='l', 26 | ylab=expression(N(MU, SD^2))) 27 | lines(density(y, from=T)) 28 | abline(v=T) 29 | 30 | ##dev.copy2pdf(file='test.rtnorm.pdf') 31 | -------------------------------------------------------------------------------- /demo/test.srstepwise.R: -------------------------------------------------------------------------------- 1 | 2 | library(BART) 3 | 4 | set.seed(12) 5 | N=500 6 | P=501 7 | X=matrix(runif(N*P, -1, 1), nrow=N, ncol=P) 8 | dimnames(X)[[2]]=paste0('x', 1:P) 9 | y=rnorm(N, (X[ , 1]^3)+(X[ , 2]^3)+(X[ , 3]^3)+(X[ , 4]^3)+(X[ , 5]^3)) 10 | T=exp(y) 11 | C=rexp(N, 0.65) 12 | delta=(T0)*1 22 | table(y.train) 23 | 24 | set.seed(21) 25 | post = pbart(x.train, y.train, sparse=TRUE) 26 | post$varprob.mean>1/P 27 | 28 | ##write(post$treedraws$trees, 'trees.pbart.txt') 29 | tc <- textConnection(post$treedraws$tree) 30 | trees <- read.table(file=tc, fill=TRUE, 31 | row.names=NULL, header=FALSE, 32 | col.names=c('node', 'var', 'cut', 'leaf')) 33 | close(tc) 34 | m <- 1 ## MCMC samples 35 | M <- trees$node[1] 36 | n <- 0 ## trees 37 | H <- trees$var[1] 38 | branch <- matrix(0, nrow=P, ncol=P) 39 | dimnames(branch)[[1]] <- paste0('x', 1:P) 40 | dimnames(branch)[[2]] <- paste0('x', 1:P) 41 | L <- nrow(trees) 42 | for(l in 2:L) { 43 | if(is.na(trees$leaf[l])) { 44 | n <- n+1 45 | if(n>H) { 46 | n <- 1 47 | m <- m+1 48 | } 49 | C <- trees$node[l] ## nodes in tree 50 | B <- (C-1)/2 ## branches in tree 51 | i <- 0 52 | j <- 0 53 | if(C>1) vars <- integer(C) 54 | branch. <- 0*branch 55 | } 56 | else if(B>1) { 57 | i <- i+1 58 | h <- trees$node[l] 59 | if(iB) stop('Too many branches') 66 | } 67 | } 68 | else { 69 | for(h. in (C-1):2) { 70 | h <- h. 71 | j <- vars[h] 72 | if(j!=0) 73 | for(t in (floor(log2(h))-1):0) { 74 | if((h%%2)==0) k <- (h-2^(t+1))/2 75 | else k <- (h-2^(t+1)-1)/2 76 | h <- 2^t+k 77 | i <- vars[h] 78 | if(i!=j) branch.[min(i, j), max(i, j)] <- 1 79 | vars[h] <- 0 80 | } 81 | } 82 | branch <- branch+branch. 83 | } 84 | } 85 | } 86 | C <- sum(c(branch)) 87 | for(i in 1:(P-1)) 88 | for(j in (i+1):P) 89 | if(i!=j) branch[j, i] <- branch[i, j]/C 90 | round(branch, digits=2) 91 | 92 | -------------------------------------------------------------------------------- /inst/CITATION: -------------------------------------------------------------------------------- 1 | bibentry(bibtype = "Article", 2 | title = "Nonparametric Machine Learning and Efficient Computation with {B}ayesian Additive Regression Trees: The {BART} {R} Package", 3 | author = c(person(given = "Rodney", 4 | family = "Sparapani", 5 | email = "rsparapa@mcw.edu"), 6 | person(given = "Charles", 7 | family = "Spanbauer"), 8 | person(given = "Robert", 9 | family = "McCulloch")), 10 | journal = "Journal of Statistical Software", 11 | year = "2021", 12 | volume = "97", 13 | number = "1", 14 | pages = "1--66", 15 | doi = "10.18637/jss.v097.i01", 16 | 17 | header = "To cite BART in publications use:" 18 | ) 19 | 20 | -------------------------------------------------------------------------------- /inst/cxx-ex/Makefile: -------------------------------------------------------------------------------- 1 | 2 | ##CXX = g++ 3 | ##CXXFLAGS = -std=gnu++11 -Wall -g -O2 -fpic -mtune=native 4 | CXX = `R CMD config CXX11` 5 | CXXFLAGS = `R CMD config CXX11STD` `R CMD config CXX11FLAGS` `R CMD config CXX11PICFLAGS` 6 | 7 | ## Rmath library for random number generation and other needs 8 | CPPFLAGS = `R CMD config CPPFLAGS` -I. -DMATHLIB_STANDALONE -DRNG_Rmath 9 | LIB = `R CMD config LDFLAGS` -lRmath 10 | 11 | ## STL random class for random number generation and the Rmath functions for other needs 12 | ## CPPFLAGS = -I. -I/usr/local/include -DMATHLIB_STANDALONE -DRNG_random 13 | 14 | .cpp.o : Makefile common.h rn.h 15 | $(CXX) $(CPPFLAGS) $(CXXFLAGS) -c $< -o $*.o 16 | 17 | main.out : Makefile main.o bart.o bartfuns.o bd.o heterbart.o heterbartfuns.o heterbd.o tree.o treefuns.o 18 | $(CXX) $(CPPFLAGS) $(CXXFLAGS) main.o bart.o bartfuns.o bd.o heterbart.o heterbartfuns.o heterbd.o tree.o treefuns.o -o main.out $(LIB) 19 | 20 | wmain.out : Makefile cwbart.cpp wmain.o bart.o bartfuns.o bd.o heterbart.o heterbartfuns.o heterbd.o tree.o treefuns.o 21 | $(CXX) $(CPPFLAGS) $(CXXFLAGS) wmain.o bart.o bartfuns.o bd.o heterbart.o heterbartfuns.o heterbd.o tree.o treefuns.o -o wmain.out $(LIB) 22 | 23 | pmain.out : Makefile cpbart.cpp pmain.o rtnorm.o bart.o bartfuns.o bd.o tree.o treefuns.o 24 | $(CXX) $(CPPFLAGS) $(CXXFLAGS) pmain.o bart.o bartfuns.o bd.o tree.o treefuns.o rtnorm.o -o pmain.out $(LIB) 25 | 26 | lmain.out : Makefile clbart.cpp lmain.o bart.o bartfuns.o bd.o heterbart.o heterbartfuns.o heterbd.o tree.o treefuns.o rand_draws.o randomkit.o latent.o 27 | $(CXX) $(CPPFLAGS) $(CXXFLAGS) lmain.o bart.o bartfuns.o bd.o heterbart.o heterbartfuns.o heterbd.o tree.o treefuns.o rand_draws.o randomkit.o latent.o -o lmain.out $(LIB) 28 | 29 | mmain.out : Makefile cmbart.cpp mmain.o bart.o bartfuns.o bd.o heterbart.o heterbartfuns.o heterbd.o tree.o treefuns.o rand_draws.o randomkit.o latent.o 30 | $(CXX) $(CPPFLAGS) $(CXXFLAGS) mmain.o bart.o bartfuns.o bd.o heterbart.o heterbartfuns.o heterbd.o tree.o treefuns.o rand_draws.o randomkit.o latent.o -o mmain.out $(LIB) 31 | 32 | dpmain.out : Makefile cdpmbart.cpp dpmain.o bart.o bartfuns.o bd.o heterbart.o heterbartfuns.o heterbd.o tree.o treefuns.o dp.o dpm.o dps.o 33 | $(CXX) $(CPPFLAGS) $(CXXFLAGS) dpmain.o bart.o bartfuns.o bd.o heterbart.o heterbartfuns.o heterbd.o tree.o treefuns.o dp.o dpm.o dps.o -o dpmain.out $(LIB) 34 | 35 | dpmwmain.out : Makefile cdpmwbart.cpp dpmwmain.o bart.o bartfuns.o bd.o heterbart.o heterbartfuns.o heterbd.o tree.o treefuns.o dp.o dpm.o dps.o 36 | $(CXX) $(CPPFLAGS) $(CXXFLAGS) dpmwmain.o bart.o bartfuns.o bd.o heterbart.o heterbartfuns.o heterbd.o tree.o treefuns.o dp.o dpm.o dps.o -o dpmwmain.out $(LIB) 37 | 38 | clean : 39 | rm -f *.o *main.out 40 | 41 | check : 42 | @echo CXX=$(CXX) 43 | @echo CXXFLAGS=$(CXXFLAGS) 44 | @echo CPPFLAGS=$(CPPFLAGS) 45 | @echo LIB=$(LIB) 46 | -------------------------------------------------------------------------------- /inst/cxx-ex/README.txt: -------------------------------------------------------------------------------- 1 | 2 | This directory contains the BART source code and an example 3 | of how to create an executable for BART that does not require 4 | R. This is may be useful when you are trying to debug your 5 | R code that generates a seg-fault with BART. Or for other 6 | reasons such as calling BART from another language like 7 | python. See the Makefile for building an executable. For 8 | example, "make pmain.out". 9 | -------------------------------------------------------------------------------- /inst/cxx-ex/bd.h: -------------------------------------------------------------------------------- 1 | /* 2 | * BART: Bayesian Additive Regression Trees 3 | * Copyright (C) 2017 Robert McCulloch and Rodney Sparapani 4 | * 5 | * This program is free software; you can redistribute it and/or modify 6 | * it under the terms of the GNU General Public License as published by 7 | * the Free Software Foundation; either version 2 of the License, or 8 | * (at your option) any later version. 9 | * 10 | * This program is distributed in the hope that it will be useful, 11 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | * GNU General Public License for more details. 14 | * 15 | * You should have received a copy of the GNU General Public License 16 | * along with this program; if not, a copy is available at 17 | * https://www.R-project.org/Licenses/GPL-2 18 | */ 19 | 20 | #ifndef GUARD_bd_h 21 | #define GUARD_bd_h 22 | 23 | #include "info.h" 24 | #include "tree.h" 25 | #include "treefuns.h" 26 | #include "bartfuns.h" 27 | 28 | bool bd(tree& x, xinfo& xi, dinfo& di, pinfo& pi, double sigma, 29 | std::vector& nv, std::vector& pv, bool aug, rn& gen); 30 | 31 | #endif 32 | -------------------------------------------------------------------------------- /inst/cxx-ex/common.h: -------------------------------------------------------------------------------- 1 | /* 2 | * BART: Bayesian Additive Regression Trees 3 | * Copyright (C) 2017 Robert McCulloch and Rodney Sparapani 4 | * 5 | * This program is free software; you can redistribute it and/or modify 6 | * it under the terms of the GNU General Public License as published by 7 | * the Free Software Foundation; either version 2 of the License, or 8 | * (at your option) any later version. 9 | * 10 | * This program is distributed in the hope that it will be useful, 11 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | * GNU General Public License for more details. 14 | * 15 | * You should have received a copy of the GNU General Public License 16 | * along with this program; if not, a copy is available at 17 | * https://www.R-project.org/Licenses/GPL-2 18 | */ 19 | 20 | #ifndef GUARD_common_h 21 | #define GUARD_common_h 22 | 23 | #ifdef MATHLIB_STANDALONE 24 | #define NoRcpp 25 | #else 26 | #define RNG_Rcpp 27 | #endif 28 | 29 | #include 30 | #include 31 | #include 32 | #include 33 | #include 34 | 35 | using std::endl; 36 | 37 | #ifdef _OPENMP 38 | #include 39 | #endif 40 | 41 | #ifdef NoRcpp 42 | 43 | #include // for printf 44 | 45 | using std::cout; 46 | 47 | #define PI 3.141592653589793238462643383280 48 | 49 | #else // YesRcpp 50 | 51 | #include 52 | 53 | #define printf Rprintf 54 | #define cout Rcpp::Rcout 55 | 56 | #endif 57 | 58 | // log(2*pi) 59 | #define LTPI 1.837877066409345483560659472811 60 | // sqrt(2*pi) 61 | #define RTPI 2.506628274631000502415765284811 62 | 63 | #include "rn.h" 64 | 65 | #endif 66 | -------------------------------------------------------------------------------- /inst/cxx-ex/dpm.cpp: -------------------------------------------------------------------------------- 1 | #include "dpm.h" 2 | 3 | //################################################################################ 4 | //### f(y,theta) 5 | double dpm::f(double y, double theta, double eta) 6 | { 7 | double sigma = eta; 8 | double r = (y-theta)/sigma; 9 | return exp(-.5*r*r)/(sigma*RTPI); 10 | } 11 | //################################################################################ 12 | //### dpm::draw_one_theta 13 | double dpm::draw_one_theta(std::list& ind, rn& gen) 14 | { 15 | double mmu,mvar; //mean and var for suff stat normal likelihood 16 | 17 | if(eta == nullptr) { 18 | double sigma = etaconst; 19 | 20 | size_t nn = ind.size(); 21 | double ybar=0.0; 22 | double yy; 23 | for(theta_gp::iiter i=ind.begin();i!=ind.end();i++) { 24 | yy = y[*i]; 25 | ybar += yy; 26 | } 27 | mmu = ybar/(1.0*nn); 28 | mvar = (sigma*sigma)/(1.0*nn); 29 | } else { 30 | mvar = 0.0; 31 | mmu = 0.0; 32 | for(theta_gp::iiter i=ind.begin();i!=ind.end();i++) { 33 | double sigma = eta[*i]; 34 | double w = 1.0/(sigma*sigma); 35 | mvar += w; 36 | mmu += w*y[*i]; 37 | } 38 | mvar = 1.0/mvar; 39 | mmu *= mvar; 40 | } 41 | /* 42 | std::cout << "ybar: " << ybar << std::endl; 43 | std::cout << "sigma: " << sigma << std::endl; 44 | std::cout << "nn: " << nn << std::endl; 45 | */ 46 | 47 | std::vector pv(m,0.0); 48 | 49 | for(size_t i=0;imaxel) maxel = pv[i]; 64 | double sum = 0.0; 65 | for(size_t i=0;i& ind, rn& gen); 40 | 41 | //-------------------------------------------------- 42 | //private 43 | }; 44 | 45 | 46 | #endif 47 | -------------------------------------------------------------------------------- /inst/cxx-ex/dpmain.cpp: -------------------------------------------------------------------------------- 1 | 2 | #include "cdpmbart.cpp" 3 | 4 | int main(void) { 5 | size_t n=10, p=1, np=1, m=50, nc=100, nd=1000, burn=250, nkeeptrain=nd; 6 | unsigned int n1=111, n2=222; 7 | double k=2., power=2., mybeta=power, base=0.95, alpha=base, initm=0., inits=1., 8 | range=6., tau=range/(2.*k*sqrt(m)); 9 | double xtrain[10]={0., 0., 0., 0., 0., 1., 1., 1., 1., 1.}, xtest[1]={0.}; 10 | double y[10]={-3., -2., -1., 0., 0., 0., 0., 1., 2., 3.}; 11 | /* 12 | double _gm[10]={-0.8, -0.6, -0.4, -0.2, 0., 0.2, 0.4, 0.6, 0.8, 1.}; 13 | double _pm[10]={0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1}; 14 | double _gs[10]={0.4, 0.6, 0.8, 1.0, 1.2, 1.4, 1.6, 1.8, 2.0, 2.2}; 15 | double _ps[10]={0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1}; 16 | */ 17 | double nu=3., qchi=::qchisq(0.1, nu, 1, 0), lambda=pow(inits, 2.)*qchi/nu; 18 | 19 | std::vector gm={-0.8, -0.6, -0.4, -0.2, 0., 0.2, 0.4, 0.6, 0.8, 1.}; 20 | std::vector pm={0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1}; 21 | std::vector gs={0.4, 0.6, 0.8, 1.0, 1.2, 1.4, 1.6, 1.8, 2.0, 2.2}; 22 | std::vector ps={0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1}; 23 | 24 | double* sigmadr=new double[nd+burn]; 25 | double* _trdraw=new double[nkeeptrain*n]; 26 | double* trmean=new double[n]; 27 | double* _mdraw=new double[nkeeptrain*n]; 28 | double* _sdraw=new double[nkeeptrain*n]; 29 | int* istar=new int[nkeeptrain]; 30 | 31 | cdpmbart(n, p, np, &xtrain[0], &y[0], &xtest[0], nd, burn, m, nc, mybeta, alpha, tau, initm, inits, 32 | gm, 0.1, pm, gs, 0.1, ps, lambda, nu, 1, 1, n1, n2, 33 | sigmadr, _trdraw, trmean, _mdraw, _sdraw, istar); 34 | 35 | #ifdef RNG_random 36 | cout << "RNG_random" << '\n'; 37 | #elif defined (RNG_Rmath) 38 | cout << "RNG_Rmath" << '\n'; 39 | #endif 40 | 41 | delete[] sigmadr; 42 | delete[] _trdraw; 43 | delete[] trmean; 44 | delete[] _mdraw; 45 | delete[] _sdraw; 46 | delete[] istar; 47 | 48 | return 0; 49 | } 50 | -------------------------------------------------------------------------------- /inst/cxx-ex/dpmwmain.cpp: -------------------------------------------------------------------------------- 1 | 2 | #include "cdpmwbart.cpp" 3 | 4 | int main(void) { 5 | size_t n=10, p=1, np=1, m=50, nc=100, nd=1000, burn=250, nkeeptrain=nd; 6 | unsigned int n1=111, n2=222; 7 | double k=2., power=2., mybeta=power, base=0.95, alpha=base, initm=0., inits=1., 8 | range=6., tau=range/(2.*k*sqrt(m)); 9 | double xtrain[10]={0., 0., 0., 0., 0., 1., 1., 1., 1., 1.}, xtest[1]={0.}; 10 | double y[10]={-3., -2., -1., 0., 0., 0., 0., 1., 2., 3.}; 11 | double w[10]={1., 1., 1., 1., 1., 1., 1., 1., 1., 1.}; 12 | double nu=3., qchi=::qchisq(0.1, nu, 1, 0), lambda=pow(inits, 2.)*qchi/nu; 13 | 14 | std::vector gm={-0.8, -0.6, -0.4, -0.2, 0., 0.2, 0.4, 0.6, 0.8, 1.}; 15 | std::vector pm={0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1}; 16 | std::vector gs={0.4, 0.6, 0.8, 1.0, 1.2, 1.4, 1.6, 1.8, 2.0, 2.2}; 17 | std::vector ps={0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1}; 18 | 19 | double* sigmadr=new double[nd+burn]; 20 | double* _trdraw=new double[nkeeptrain*n]; 21 | double* trmean=new double[n]; 22 | double* _mdraw=new double[nkeeptrain*n]; 23 | double* _sdraw=new double[nkeeptrain*n]; 24 | int* istar=new int[nkeeptrain]; 25 | 26 | cdpmwbart(n, p, np, &xtrain[0], &y[0], &xtest[0], nd, burn, m, nc, mybeta, alpha, tau, initm, inits, 27 | gm, 0.1, pm, gs, 0.1, ps, lambda, nu, w, 1, n1, n2, 28 | sigmadr, _trdraw, trmean, _mdraw, _sdraw, istar); 29 | 30 | #ifdef RNG_random 31 | cout << "RNG_random" << '\n'; 32 | #elif defined (RNG_Rmath) 33 | cout << "RNG_Rmath" << '\n'; 34 | #endif 35 | 36 | delete[] sigmadr; 37 | delete[] _trdraw; 38 | delete[] trmean; 39 | delete[] _mdraw; 40 | delete[] _sdraw; 41 | delete[] istar; 42 | 43 | return 0; 44 | } 45 | -------------------------------------------------------------------------------- /inst/cxx-ex/dps.cpp: -------------------------------------------------------------------------------- 1 | #include "dps.h" 2 | //################################################################################ 3 | //### f(y,theta) 4 | double dps::f(double y, double theta, double eta) 5 | { 6 | //ignore eta, mu=0 7 | double r = y/theta; 8 | return exp(-.5*r*r)/(theta*RTPI); 9 | } 10 | //################################################################################ 11 | //### dps::draw_one_theta 12 | double dps::draw_one_theta(std::list& ind, rn& gen) 13 | { 14 | size_t nn = ind.size(); 15 | double s=0.0; 16 | double yy; 17 | for(theta_gp::iiter i=ind.begin();i!=ind.end();i++) { 18 | yy = y[*i]; 19 | s += yy*yy; 20 | } 21 | 22 | std::vector pv(m,0.0); 23 | 24 | for(size_t i=0;imaxel) maxel = pv[i]; 30 | double sum = 0.0; 31 | for(size_t i=0;i& ind, rn& gen); 46 | }; 47 | 48 | 49 | #endif 50 | -------------------------------------------------------------------------------- /inst/cxx-ex/heterbart.cpp: -------------------------------------------------------------------------------- 1 | /* 2 | * BART: Bayesian Additive Regression Trees 3 | * Copyright (C) 2017 Robert McCulloch and Rodney Sparapani 4 | * 5 | * This program is free software; you can redistribute it and/or modify 6 | * it under the terms of the GNU General Public License as published by 7 | * the Free Software Foundation; either version 2 of the License, or 8 | * (at your option) any later version. 9 | * 10 | * This program is distributed in the hope that it will be useful, 11 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | * GNU General Public License for more details. 14 | * 15 | * You should have received a copy of the GNU General Public License 16 | * along with this program; if not, a copy is available at 17 | * https://www.R-project.org/Licenses/GPL-2 18 | */ 19 | 20 | #include "heterbart.h" 21 | 22 | //-------------------------------------------------- 23 | void heterbart::pr() 24 | { 25 | cout << "+++++heterbart object:\n"; 26 | bart::pr(); 27 | } 28 | //-------------------------------------------------- 29 | void heterbart::draw(double *sigma, rn& gen) 30 | { 31 | for(size_t j=0;j& bv, std::vector& Mv, double *sigma); 42 | //-------------------------------------------------- 43 | //heter version of drmu, need b and M instead of n and sy 44 | void heterdrmu(tree& t, xinfo& xi, dinfo& di, pinfo& pi, double *sigma, rn& gen); 45 | 46 | #endif 47 | -------------------------------------------------------------------------------- /inst/cxx-ex/heterbd.h: -------------------------------------------------------------------------------- 1 | /* 2 | * BART: Bayesian Additive Regression Trees 3 | * Copyright (C) 2017 Robert McCulloch and Rodney Sparapani 4 | * 5 | * This program is free software; you can redistribute it and/or modify 6 | * it under the terms of the GNU General Public License as published by 7 | * the Free Software Foundation; either version 2 of the License, or 8 | * (at your option) any later version. 9 | * 10 | * This program is distributed in the hope that it will be useful, 11 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | * GNU General Public License for more details. 14 | * 15 | * You should have received a copy of the GNU General Public License 16 | * along with this program; if not, a copy is available at 17 | * https://www.R-project.org/Licenses/GPL-2 18 | */ 19 | 20 | #ifndef GUARD_heterbd_h 21 | #define GUARD_heterbd_h 22 | 23 | #include "info.h" 24 | #include "tree.h" 25 | #include "treefuns.h" 26 | #include "bartfuns.h" 27 | #include "heterbartfuns.h" 28 | 29 | bool heterbd(tree& x, xinfo& xi, dinfo& di, pinfo& pi, double *sigma, 30 | std::vector& nv, std::vector& pv, bool aug, rn& gen); 31 | 32 | #endif 33 | -------------------------------------------------------------------------------- /inst/cxx-ex/info.h: -------------------------------------------------------------------------------- 1 | /* 2 | * BART: Bayesian Additive Regression Trees 3 | * Copyright (C) 2017 Robert McCulloch and Rodney Sparapani 4 | * 5 | * This program is free software; you can redistribute it and/or modify 6 | * it under the terms of the GNU General Public License as published by 7 | * the Free Software Foundation; either version 2 of the License, or 8 | * (at your option) any later version. 9 | * 10 | * This program is distributed in the hope that it will be useful, 11 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | * GNU General Public License for more details. 14 | * 15 | * You should have received a copy of the GNU General Public License 16 | * along with this program; if not, a copy is available at 17 | * https://www.R-project.org/Licenses/GPL-2 18 | */ 19 | 20 | #ifndef GUARD_info_h 21 | #define GUARD_info_h 22 | #include "common.h" 23 | //data 24 | class dinfo { 25 | public: 26 | dinfo() {p=0;n=0;x=0;y=0;} 27 | size_t p; //number of vars 28 | size_t n; //number of observations 29 | double *x; // jth var of ith obs is *(x + p*i+j) 30 | double *y; // ith y is *(y+i) or y[i] 31 | }; 32 | //prior and mcmc 33 | class pinfo 34 | { 35 | public: 36 | pinfo(): pbd(1.0),pb(.5),alpha(.95),mybeta(2.0),tau(1.0) {} 37 | //mcmc info 38 | double pbd; //prob of birth/death 39 | double pb; //prob of birth 40 | //prior info 41 | double alpha; 42 | double mybeta; 43 | double tau; 44 | void pr() { 45 | cout << "pbd,pb: " << pbd << ", " << pb << std::endl; 46 | cout << "alpha,beta,tau: " << alpha << 47 | ", " << mybeta << ", " << tau << std::endl; 48 | } 49 | }; 50 | 51 | #endif 52 | -------------------------------------------------------------------------------- /inst/cxx-ex/latent.h: -------------------------------------------------------------------------------- 1 | /* 2 | * BART: Bayesian Additive Regression Trees 3 | * Copyright (C) 2017 Robert McCulloch and Rodney Sparapani 4 | * 5 | * This program is free software; you can redistribute it and/or modify 6 | * it under the terms of the GNU General Public License as published by 7 | * the Free Software Foundation; either version 2 of the License, or 8 | * (at your option) any later version. 9 | * 10 | * This program is distributed in the hope that it will be useful, 11 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | * GNU General Public License for more details. 14 | * 15 | * You should have received a copy of the GNU General Public License 16 | * along with this program; if not, a copy is available at 17 | * https://www.R-project.org/Licenses/GPL-2 18 | */ 19 | 20 | #ifndef GUARD_latent 21 | #define GUARD_latent 22 | 23 | #include "common.h" 24 | #include "randomkit.h" 25 | #include 26 | #include 27 | #include "rand_draws.h" 28 | 29 | #ifdef NoRcpp 30 | using ::pnorm; 31 | #else 32 | using R::pnorm; 33 | #endif 34 | 35 | extern int NS; 36 | extern rk_state** states; 37 | 38 | #ifndef NoRcpp 39 | 40 | RcppExport SEXP cdraw_lambda(SEXP lambda, SEXP mean, SEXP kmax, SEXP thin); 41 | 42 | RcppExport SEXP cdraw_z(SEXP mean, SEXP tau, SEXP lambda); 43 | 44 | #endif 45 | 46 | void draw_z(int n, double *xbeta, double *lambda, double *z_out); 47 | void draw_lambda(int n, double *xbeta_in, int kmax, int thin, double *lambda_inout); 48 | double draw_lambda_i(double lambda_old, double xbeta, int kmax, int thin, rk_state *state); 49 | double draw_lambda_prior(double *psii, int kmax, rk_state *state); 50 | 51 | #endif 52 | -------------------------------------------------------------------------------- /inst/cxx-ex/lmain.cpp: -------------------------------------------------------------------------------- 1 | 2 | #include "clbart.cpp" 3 | 4 | int main(void) { 5 | size_t n=10, p=1, np=2, m=50, nd=1000, burn=250, 6 | nkeeptrain=nd, nkeeptest=nd, nkeeptreedraws=nd, 7 | printevery=100; 8 | unsigned int n1=111, n2=222; 9 | double k=2., power=2., mybeta=power, base=0.95, alpha=base, 10 | binaryOffset=.0, tau=3./(k*sqrt(m)); 11 | double xtrain[10]={0., 0., 0., 0., 0., 1., 1., 1., 1., 1.}, xtest[2]={0., 1.}; 12 | int y[10]={1, -1, -1, 1, -1, -1, 1, 1, -1, 1}; 13 | double* _trdraw=new double[nkeeptrain*n]; 14 | double* _tedraw=new double[nkeeptest*np]; 15 | int nc[1]={100}; 16 | 17 | std::vector trdraw(nkeeptrain); 18 | std::vector tedraw(nkeeptest); 19 | 20 | for(size_t i=0; i trdraw(nkeeptrain); 20 | std::vector tedraw(nkeeptest); 21 | 22 | for(size_t i=0; i trdraw(nkeeptrain); 19 | std::vector tedraw(nkeeptest); 20 | 21 | for(size_t i=0; i 26 | #include 27 | 28 | void newRNGstates(void); 29 | void deleteRNGstates(void); 30 | double runi(rk_state *state); 31 | void rnor(double *x, rk_state *state); 32 | double rexpo(double lambda, rk_state *state); 33 | double sq(double x); 34 | double rinvgauss(const double mu, const double lambda); 35 | double rtnorm_reject(double mean, double tau, double sd, rk_state* state); 36 | double rexpo(double scale, rk_state* state); 37 | double expo_rand(rk_state *state); 38 | 39 | #ifndef NoRcpp 40 | 41 | RcppExport SEXP crtnorm_reject(SEXP, SEXP, SEXP); 42 | 43 | #endif 44 | 45 | #endif 46 | -------------------------------------------------------------------------------- /inst/cxx-ex/rtnorm.cpp: -------------------------------------------------------------------------------- 1 | /* 2 | * BART: Bayesian Additive Regression Trees 3 | * Copyright (C) 2017-2018 Robert McCulloch, Rodney Sparapani 4 | * and Robert Gramacy 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/GPL-2 19 | */ 20 | 21 | #include "rtnorm.h" 22 | 23 | #ifndef NoRcpp 24 | 25 | RcppExport SEXP crtnorm(SEXP n, SEXP mean, SEXP tau, SEXP sd) { 26 | arn gen; 27 | size_t N = Rcpp::as(n); 28 | //double a=Rcpp::as(mean), b=Rcpp::as(tau), 29 | //c=Rcpp::as(sd); 30 | Rcpp::NumericVector z(N), a(mean), b(tau), c(sd); 31 | size_t A=a.size(), B=b.size(), C=c.size(); 32 | for(size_t i=0; i exp(-0.5*pow(z - lambda, 2.))); 62 | } 63 | 64 | /* put x back on the right scale */ 65 | x = z*sd + mean; 66 | 67 | //assert(x > 0); //assert unnecessary: Rodney's way 68 | return(x); 69 | 70 | } 71 | 72 | -------------------------------------------------------------------------------- /inst/cxx-ex/rtnorm.h: -------------------------------------------------------------------------------- 1 | /* 2 | * BART: Bayesian Additive Regression Trees 3 | * Copyright (C) 2017-2018 Robert McCulloch, Rodney Sparapani 4 | * and Robert Gramacy 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/GPL-2 19 | */ 20 | 21 | #ifndef GUARD_rtnorm 22 | #define GUARD_rtnorm 23 | 24 | #include "common.h" 25 | 26 | double rtnorm(double mean, double tau, double sd, rn& gen); 27 | 28 | #ifndef NoRcpp 29 | 30 | RcppExport SEXP crtnorm(SEXP, SEXP, SEXP, SEXP); 31 | 32 | #endif 33 | 34 | #endif 35 | -------------------------------------------------------------------------------- /inst/cxx-ex/treefuns.h: -------------------------------------------------------------------------------- 1 | /* 2 | * BART: Bayesian Additive Regression Trees 3 | * Copyright (C) 2017 Robert McCulloch and Rodney Sparapani 4 | * 5 | * This program is free software; you can redistribute it and/or modify 6 | * it under the terms of the GNU General Public License as published by 7 | * the Free Software Foundation; either version 2 of the License, or 8 | * (at your option) any later version. 9 | * 10 | * This program is distributed in the hope that it will be useful, 11 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | * GNU General Public License for more details. 14 | * 15 | * You should have received a copy of the GNU General Public License 16 | * along with this program; if not, a copy is available at 17 | * https://www.R-project.org/Licenses/GPL-2 18 | */ 19 | 20 | #ifndef GUARD_treefuns_h 21 | #define GUARD_treefuns_h 22 | 23 | #include "tree.h" 24 | 25 | //-------------------------------------------------- 26 | //write cutpoint information to screen 27 | void prxi(xinfo& xi); 28 | //-------------------------------------------------- 29 | //evaluate tree tr on grid xi, write to os 30 | void grm(tree& tr, xinfo& xi, std::ostream& os); 31 | //-------------------------------------------------- 32 | //fit tree at matrix of x, matrix is stacked columns x[i,j] is *(x+p*i+j) 33 | void fit(tree& t, xinfo& xi, size_t p, size_t n, double *x, double* fv); 34 | //-------------------------------------------------- 35 | //does a (bottom) node have variables you can split on? 36 | bool cansplit(tree::tree_p n, xinfo& xi); 37 | //-------------------------------------------------- 38 | //find variables n can split on, put their indices in goodvars 39 | void getgoodvars(tree::tree_p n, xinfo& xi, std::vector& goodvars); 40 | 41 | #endif 42 | -------------------------------------------------------------------------------- /inst/cxx-ex/wmain.cpp: -------------------------------------------------------------------------------- 1 | 2 | #include "cwbart.cpp" 3 | 4 | int main(void) { 5 | size_t n=10, p=1, np=2, m=50, nd=1000, burn=250, 6 | nkeeptrain=nd, nkeeptest=nd, nkeeptestmean=nd, nkeeptreedraws=nd, 7 | printevery=100; 8 | unsigned int n1=111, n2=222; 9 | double k=2., power=2., mybeta=power, base=0.95, alpha=base, 10 | tau=14./(2.*k*sqrt(m)), nu=3., ymu=0., ysd=0., sigquant=0.9, lambda; 11 | double xtrain[10]={0., 0., 0., 0., 0., 1., 1., 1., 1., 1.}, xtest[2]={0., 1.}; 12 | double y[10]={0., 1., -1., 2., -2., 10., 11., 9., 12., 8.}; 13 | double w[10]={1., 1., 1., 1., 1., 1., 1., 1., 1., 1.}; 14 | int nc[1]={100}; 15 | 16 | for(size_t i=0; i trdraw(nkeeptrain); 28 | std::vector tedraw(nkeeptest); 29 | 30 | for(size_t i=0; i& nv, std::vector& pv, bool aug, rn& gen); 30 | 31 | #endif 32 | -------------------------------------------------------------------------------- /src/common.h: -------------------------------------------------------------------------------- 1 | /* 2 | * BART: Bayesian Additive Regression Trees 3 | * Copyright (C) 2017 Robert McCulloch and Rodney Sparapani 4 | * 5 | * This program is free software; you can redistribute it and/or modify 6 | * it under the terms of the GNU General Public License as published by 7 | * the Free Software Foundation; either version 2 of the License, or 8 | * (at your option) any later version. 9 | * 10 | * This program is distributed in the hope that it will be useful, 11 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | * GNU General Public License for more details. 14 | * 15 | * You should have received a copy of the GNU General Public License 16 | * along with this program; if not, a copy is available at 17 | * https://www.R-project.org/Licenses/GPL-2 18 | */ 19 | 20 | #ifndef GUARD_common_h 21 | #define GUARD_common_h 22 | 23 | #ifdef MATHLIB_STANDALONE 24 | #define NoRcpp 25 | #else 26 | #define RNG_Rcpp 27 | #endif 28 | 29 | #include 30 | #include 31 | #include 32 | #include 33 | #include 34 | 35 | using std::endl; 36 | 37 | #ifdef _OPENMP 38 | #include 39 | #endif 40 | 41 | #ifdef NoRcpp 42 | 43 | #include // for printf 44 | 45 | using std::cout; 46 | 47 | #define PI 3.141592653589793238462643383280 48 | 49 | #else // YesRcpp 50 | 51 | #include 52 | 53 | #define printf Rprintf 54 | #define cout Rcpp::Rcout 55 | 56 | #endif 57 | 58 | // log(2*pi) 59 | #define LTPI 1.837877066409345483560659472811 60 | // sqrt(2*pi) 61 | #define RTPI 2.506628274631000502415765284811 62 | 63 | #include "rn.h" 64 | 65 | #endif 66 | -------------------------------------------------------------------------------- /src/heterbart.cpp: -------------------------------------------------------------------------------- 1 | /* 2 | * BART: Bayesian Additive Regression Trees 3 | * Copyright (C) 2017 Robert McCulloch and Rodney Sparapani 4 | * 5 | * This program is free software; you can redistribute it and/or modify 6 | * it under the terms of the GNU General Public License as published by 7 | * the Free Software Foundation; either version 2 of the License, or 8 | * (at your option) any later version. 9 | * 10 | * This program is distributed in the hope that it will be useful, 11 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | * GNU General Public License for more details. 14 | * 15 | * You should have received a copy of the GNU General Public License 16 | * along with this program; if not, a copy is available at 17 | * https://www.R-project.org/Licenses/GPL-2 18 | */ 19 | 20 | #include "heterbart.h" 21 | 22 | //-------------------------------------------------- 23 | void heterbart::pr() 24 | { 25 | cout << "+++++heterbart object:\n"; 26 | bart::pr(); 27 | } 28 | //-------------------------------------------------- 29 | void heterbart::draw(double *sigma, rn& gen) 30 | { 31 | for(size_t j=0;j& bv, std::vector& Mv, double *sigma); 42 | //-------------------------------------------------- 43 | //heter version of drmu, need b and M instead of n and sy 44 | void heterdrmu(tree& t, xinfo& xi, dinfo& di, pinfo& pi, double *sigma, rn& gen); 45 | 46 | #endif 47 | -------------------------------------------------------------------------------- /src/heterbd.h: -------------------------------------------------------------------------------- 1 | /* 2 | * BART: Bayesian Additive Regression Trees 3 | * Copyright (C) 2017 Robert McCulloch and Rodney Sparapani 4 | * 5 | * This program is free software; you can redistribute it and/or modify 6 | * it under the terms of the GNU General Public License as published by 7 | * the Free Software Foundation; either version 2 of the License, or 8 | * (at your option) any later version. 9 | * 10 | * This program is distributed in the hope that it will be useful, 11 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | * GNU General Public License for more details. 14 | * 15 | * You should have received a copy of the GNU General Public License 16 | * along with this program; if not, a copy is available at 17 | * https://www.R-project.org/Licenses/GPL-2 18 | */ 19 | 20 | #ifndef GUARD_heterbd_h 21 | #define GUARD_heterbd_h 22 | 23 | #include "info.h" 24 | #include "tree.h" 25 | #include "treefuns.h" 26 | #include "bartfuns.h" 27 | #include "heterbartfuns.h" 28 | 29 | bool heterbd(tree& x, xinfo& xi, dinfo& di, pinfo& pi, double *sigma, 30 | std::vector& nv, std::vector& pv, bool aug, rn& gen); 31 | 32 | #endif 33 | -------------------------------------------------------------------------------- /src/info.h: -------------------------------------------------------------------------------- 1 | /* 2 | * BART: Bayesian Additive Regression Trees 3 | * Copyright (C) 2017 Robert McCulloch and Rodney Sparapani 4 | * 5 | * This program is free software; you can redistribute it and/or modify 6 | * it under the terms of the GNU General Public License as published by 7 | * the Free Software Foundation; either version 2 of the License, or 8 | * (at your option) any later version. 9 | * 10 | * This program is distributed in the hope that it will be useful, 11 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | * GNU General Public License for more details. 14 | * 15 | * You should have received a copy of the GNU General Public License 16 | * along with this program; if not, a copy is available at 17 | * https://www.R-project.org/Licenses/GPL-2 18 | */ 19 | 20 | #ifndef GUARD_info_h 21 | #define GUARD_info_h 22 | #include "common.h" 23 | //data 24 | class dinfo { 25 | public: 26 | dinfo() {p=0;n=0;x=0;y=0;} 27 | size_t p; //number of vars 28 | size_t n; //number of observations 29 | double *x; // jth var of ith obs is *(x + p*i+j) 30 | double *y; // ith y is *(y+i) or y[i] 31 | }; 32 | //prior and mcmc 33 | class pinfo 34 | { 35 | public: 36 | pinfo(): pbd(1.0),pb(.5),alpha(.95),mybeta(2.0),tau(1.0) {} 37 | //mcmc info 38 | double pbd; //prob of birth/death 39 | double pb; //prob of birth 40 | //prior info 41 | double alpha; 42 | double mybeta; 43 | double tau; 44 | void pr() { 45 | cout << "pbd,pb: " << pbd << ", " << pb << std::endl; 46 | cout << "alpha,beta,tau: " << alpha << 47 | ", " << mybeta << ", " << tau << std::endl; 48 | } 49 | }; 50 | 51 | #endif 52 | -------------------------------------------------------------------------------- /src/lambda.cpp: -------------------------------------------------------------------------------- 1 | /* 2 | * BART: Bayesian Additive Regression Trees 3 | * Copyright (C) 2017-2018 Robert McCulloch, Rodney Sparapani 4 | * and Robert Gramacy 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/GPL-2 19 | */ 20 | 21 | #include "lambda.h" 22 | 23 | #ifndef NoRcpp 24 | 25 | RcppExport SEXP cdraw_lambda_i(SEXP lambda, SEXP mean, SEXP kmax, SEXP thin) { 26 | arn gen; 27 | return Rcpp::wrap(draw_lambda_i(Rcpp::as(lambda), 28 | Rcpp::as(mean), 29 | Rcpp::as(kmax), 30 | Rcpp::as(thin), gen)); 31 | } 32 | 33 | #endif 34 | 35 | /* draw lambda from its (infinite mixture) prior */ 36 | 37 | double draw_lambda_prior(double *psii, int kmax, rn& gen) 38 | { 39 | double lambda; 40 | int k; 41 | 42 | lambda = 0.0; 43 | for(k=0; k<=kmax; k++) { 44 | lambda += psii[k] * gen.exp(); 45 | //lambda += psii[k] * expo_rand(state); 46 | } 47 | 48 | return lambda; 49 | } 50 | 51 | 52 | /* Metropolis-Hastings algorithm for drawing lambda from its * 53 | * full conditional -- uses proposals from the prior */ 54 | 55 | double draw_lambda_i(double lambda_old, double xbeta, 56 | int kmax, int thin, rn& gen) 57 | { 58 | int t, k; 59 | double lambda, lp, lpold, m, s; 60 | double *psii; 61 | 62 | /* calculate the probability og the previous lambda */ 63 | s = sqrt(lambda_old); 64 | m = xbeta; 65 | lpold = pnorm(0.0, m, s, 0, 1); 66 | 67 | /* allocate psii */ 68 | psii = (double*) malloc(sizeof(double) * (kmax+1)); 69 | for(k=0; k<=kmax; k++) psii[k] = 2.0/((1.0+k)*(1.0+k)); 70 | 71 | /* thinning is essential when kappa is large */ 72 | for(t=0; t(n); 27 | //double arg1=Rcpp::as(shape), arg2=Rcpp::as(rate), 28 | // arg3=Rcpp::as(a); 29 | Rcpp::NumericVector z(N), A(shape), B(rate), C(a); 30 | size_t nA=A.size(), nB=B.size(), nC=C.size(); 31 | for(size_t i=0; ix) { // do at least once 47 | x=gen.exp(); 48 | y=a_scale+gen.exp()/lambda; 49 | c=lambda_shift*y-shape_shift*(log(y)+C); 50 | } 51 | return y/rate; 52 | } 53 | -------------------------------------------------------------------------------- /src/rtgamma.h: -------------------------------------------------------------------------------- 1 | /* 2 | * BART: Bayesian Additive Regression Trees 3 | * Copyright (C) 2019 Rodney Sparapani 4 | * 5 | * This program is free software; you can redistribute it and/or modify 6 | * it under the terms of the GNU General Public License as published by 7 | * the Free Software Foundation; either version 2 of the License, or 8 | * (at your option) any later version. 9 | * 10 | * This program is distributed in the hope that it will be useful, 11 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | * GNU General Public License for more details. 14 | * 15 | * You should have received a copy of the GNU General Public License 16 | * along with this program; if not, a copy is available at 17 | * https://www.R-project.org/Licenses/GPL-2 18 | */ 19 | 20 | #ifndef GUARD_rtgamma 21 | #define GUARD_rtgamma 22 | 23 | #include "common.h" 24 | 25 | double rtgamma(double shape, double rate, double a, rn& gen); 26 | 27 | #ifndef NoRcpp 28 | 29 | RcppExport SEXP crtgamma(SEXP, SEXP, SEXP, SEXP); 30 | 31 | #endif 32 | 33 | #endif 34 | -------------------------------------------------------------------------------- /src/rtnorm.cpp: -------------------------------------------------------------------------------- 1 | /* 2 | * BART: Bayesian Additive Regression Trees 3 | * Copyright (C) 2017-2018 Robert McCulloch, Rodney Sparapani 4 | * and Robert Gramacy 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/GPL-2 19 | */ 20 | 21 | #include "rtnorm.h" 22 | 23 | #ifndef NoRcpp 24 | 25 | RcppExport SEXP crtnorm(SEXP n, SEXP mean, SEXP tau, SEXP sd) { 26 | arn gen; 27 | size_t N = Rcpp::as(n); 28 | //double a=Rcpp::as(mean), b=Rcpp::as(tau), 29 | //c=Rcpp::as(sd); 30 | Rcpp::NumericVector z(N), a(mean), b(tau), c(sd); 31 | size_t A=a.size(), B=b.size(), C=c.size(); 32 | for(size_t i=0; i exp(-0.5*pow(z - lambda, 2.))); 62 | } 63 | 64 | /* put x back on the right scale */ 65 | x = z*sd + mean; 66 | 67 | //assert(x > 0); //assert unnecessary: Rodney's way 68 | return(x); 69 | 70 | } 71 | 72 | -------------------------------------------------------------------------------- /src/rtnorm.h: -------------------------------------------------------------------------------- 1 | /* 2 | * BART: Bayesian Additive Regression Trees 3 | * Copyright (C) 2017-2018 Robert McCulloch, Rodney Sparapani 4 | * and Robert Gramacy 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/GPL-2 19 | */ 20 | 21 | #ifndef GUARD_rtnorm 22 | #define GUARD_rtnorm 23 | 24 | #include "common.h" 25 | 26 | double rtnorm(double mean, double tau, double sd, rn& gen); 27 | 28 | #ifndef NoRcpp 29 | 30 | RcppExport SEXP crtnorm(SEXP, SEXP, SEXP, SEXP); 31 | 32 | #endif 33 | 34 | #endif 35 | -------------------------------------------------------------------------------- /src/treefuns.cpp: -------------------------------------------------------------------------------- 1 | /* 2 | * BART: Bayesian Additive Regression Trees 3 | * Copyright (C) 2017 Robert McCulloch and Rodney Sparapani 4 | * 5 | * This program is free software; you can redistribute it and/or modify 6 | * it under the terms of the GNU General Public License as published by 7 | * the Free Software Foundation; either version 2 of the License, or 8 | * (at your option) any later version. 9 | * 10 | * This program is distributed in the hope that it will be useful, 11 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | * GNU General Public License for more details. 14 | * 15 | * You should have received a copy of the GNU General Public License 16 | * along with this program; if not, a copy is available at 17 | * https://www.R-project.org/Licenses/GPL-2 18 | */ 19 | 20 | #include "treefuns.h" 21 | 22 | //-------------------------------------------------- 23 | //write cutpoint information to screen 24 | void prxi(xinfo& xi) 25 | { 26 | cout << "xinfo: \n"; 27 | for(size_t v=0;v!=xi.size();v++) { 28 | cout << "v: " << v << std::endl; 29 | for(size_t j=0;j!=xi[v].size();j++) cout << "j,xi[v][j]: " << j << ", " << xi[v][j] << std::endl; 30 | } 31 | cout << "\n\n"; 32 | } 33 | //-------------------------------------------------- 34 | //evalute tree tr on grid given by xi and write to os 35 | void grm(tree& tr, xinfo& xi, std::ostream& os) 36 | { 37 | size_t p = xi.size(); 38 | if(p!=2) { 39 | cout << "error in grm, p !=2\n"; 40 | return; 41 | } 42 | size_t n1 = xi[0].size(); 43 | size_t n2 = xi[1].size(); 44 | tree::tree_p bp; //pointer to bottom node 45 | double *x = new double[2]; 46 | for(size_t i=0;i!=n1;i++) { 47 | for(size_t j=0;j!=n2;j++) { 48 | x[0] = xi[0][i]; 49 | x[1] = xi[1][j]; 50 | bp = tr.bn(x,xi); 51 | os << x[0] << " " << x[1] << " " << bp->gettheta() << " " << bp->nid() << std::endl; 52 | } 53 | } 54 | delete[] x; 55 | } 56 | //-------------------------------------------------- 57 | //fit tree at matrix of x, matrix is stacked columns x[i,j] is *(x+p*i+j) 58 | void fit(tree& t, xinfo& xi, size_t p, size_t n, double *x, double* fv) 59 | { 60 | tree::tree_p bn; 61 | for(size_t i=0;igettheta(); 64 | } 65 | } 66 | //-------------------------------------------------- 67 | //does this bottom node n have any variables it can split on. 68 | bool cansplit(tree::tree_p n, xinfo& xi) 69 | { 70 | int L,U; 71 | bool v_found = false; //have you found a variable you can split on 72 | size_t v=0; 73 | while(!v_found && (v < xi.size())) { //invar: splitvar not found, vars left 74 | L=0; U = xi[v].size()-1; 75 | n->rg(v,&L,&U); 76 | if(U>=L) v_found=true; 77 | v++; 78 | } 79 | return v_found; 80 | } 81 | //-------------------------------------------------- 82 | //find variables n can split on, put their indices in goodvars 83 | void getgoodvars(tree::tree_p n, xinfo& xi, std::vector& goodvars) 84 | { 85 | goodvars.clear(); 86 | int L,U; 87 | for(size_t v=0;v!=xi.size();v++) {//try each variable 88 | L=0; U = xi[v].size()-1; 89 | n->rg(v,&L,&U); 90 | if(U>=L) goodvars.push_back(v); 91 | } 92 | } 93 | -------------------------------------------------------------------------------- /src/treefuns.h: -------------------------------------------------------------------------------- 1 | /* 2 | * BART: Bayesian Additive Regression Trees 3 | * Copyright (C) 2017 Robert McCulloch and Rodney Sparapani 4 | * 5 | * This program is free software; you can redistribute it and/or modify 6 | * it under the terms of the GNU General Public License as published by 7 | * the Free Software Foundation; either version 2 of the License, or 8 | * (at your option) any later version. 9 | * 10 | * This program is distributed in the hope that it will be useful, 11 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | * GNU General Public License for more details. 14 | * 15 | * You should have received a copy of the GNU General Public License 16 | * along with this program; if not, a copy is available at 17 | * https://www.R-project.org/Licenses/GPL-2 18 | */ 19 | 20 | #ifndef GUARD_treefuns_h 21 | #define GUARD_treefuns_h 22 | 23 | #include "tree.h" 24 | 25 | //-------------------------------------------------- 26 | //write cutpoint information to screen 27 | void prxi(xinfo& xi); 28 | //-------------------------------------------------- 29 | //evaluate tree tr on grid xi, write to os 30 | void grm(tree& tr, xinfo& xi, std::ostream& os); 31 | //-------------------------------------------------- 32 | //fit tree at matrix of x, matrix is stacked columns x[i,j] is *(x+p*i+j) 33 | void fit(tree& t, xinfo& xi, size_t p, size_t n, double *x, double* fv); 34 | //-------------------------------------------------- 35 | //does a (bottom) node have variables you can split on? 36 | bool cansplit(tree::tree_p n, xinfo& xi); 37 | //-------------------------------------------------- 38 | //find variables n can split on, put their indices in goodvars 39 | void getgoodvars(tree::tree_p n, xinfo& xi, std::vector& goodvars); 40 | 41 | #endif 42 | -------------------------------------------------------------------------------- /vignettes/ref.bib: -------------------------------------------------------------------------------- 1 | @article{SparSpan21, 2 | title={Nonparametric Machine Learning and Efficient Computation with Bayesian Additive Regression Trees: the \pkg{BART} \proglang{R} Package}, 3 | author={Sparapani, R and Spanbauer, C and McCulloch, R}, 4 | journal={Journal of Statistical Software}, 5 | volume={97}, 6 | number={1}, 7 | pages = {1-66}, 8 | year={2021}, 9 | doi={10.18637/jss.v097.i01} 10 | } 11 | --------------------------------------------------------------------------------