├── .Rbuildignore ├── .gitignore ├── DESCRIPTION ├── NAMESPACE ├── R ├── SummaryReport.R ├── archive │ └── cervical.R ├── calibSim.R ├── plugin.R ├── pqueue.R ├── rcpp_hello_world.R ├── simulate.R └── zzz.R ├── README.org ├── clean.sh ├── data └── fhcrcData.rda ├── inst ├── develop_to_master.sh ├── doc │ ├── examples.html │ ├── examples.org │ ├── illness_death.png │ ├── index.html │ ├── index.org │ ├── rates.png │ ├── reporting.png │ └── tick_tock.png ├── include │ ├── RngStream.cpp │ ├── RngStream.h │ ├── c_optim.h │ ├── gsm.h │ ├── heap.h │ ├── microsimulation.h │ ├── rcpp_table.h │ ├── siena │ │ └── ssim.h │ ├── splines.h │ └── ssim.cc └── lib │ └── keeplib.txt ├── man ├── Classes.Rd ├── Data.Rd ├── Examples.Rd ├── Internal.Rd ├── RNGStream.Rd ├── SummaryReport.Rd ├── Utilities.Rd ├── discountedInterval.Rd ├── microsimulation-package.Rd └── simulate.Rd ├── microsimulation.Rproj ├── src ├── Makevars ├── Makevars.win ├── RngStream.cpp ├── archive │ ├── cervical.cpp │ └── person-r-20121231.cc ├── calibperson-r.cc ├── doc │ ├── Doxyfile │ ├── Makefile │ ├── fdl.txt │ ├── footer.html │ ├── header.html │ └── maindoc.h ├── gsm.cpp ├── illness-death.cpp ├── init.c ├── microsimulation.cc ├── person-r.cc ├── pqueue.cpp ├── rngstream-boost.hpp ├── rngstream-example.cpp ├── simple-example.cc ├── simple-example2.cc ├── splines.cpp └── ssim.cc ├── test ├── Rcpp-tests.R ├── RngStream-revised.cpp ├── RngStream-revised.h ├── TODO.org ├── cluster.sh ├── cluster_mic.R ├── rescreen.R ├── rngstream-c++-example.cpp ├── rngstream-c++11.hpp ├── submit_cluster.sh └── test_microsimulation.R └── tests ├── testthat.R └── testthat ├── test-callIllnessDeath.R └── test-callPersonSimulation2.R /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | ^microsimulation.*\.tar\.gz$ 4 | Makefile 5 | NEWS\.html 6 | README\.html 7 | README\.org 8 | clean\.sh 9 | log$ 10 | [~]$ 11 | ^.*\.bbl$ 12 | ^.*\.blg$ 13 | ^.*\.tex$ 14 | jss\.bst 15 | ^.*\.dvi$ 16 | test 17 | microsimulation\.a 18 | rngstream-example\.cpp 19 | rngstream-boost\.hpp 20 | cervical.R 21 | NAMESPACE_old 22 | archive 23 | dll$ 24 | ^R\.h$ 25 | README\.4\.vrb 26 | README\.5\.vrb 27 | README\.aux 28 | README\.out 29 | auto 30 | index\.org 31 | 32 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.so 3 | *.o 4 | ..Rcheck/* 5 | autom4te.cache/* 6 | src/tprocessconf.h 7 | .Rhistory 8 | */.Rhistory 9 | .log 10 | .lst 11 | Makefile 12 | README.html 13 | .Rproj.user 14 | microsimulation_*.tar.gz 15 | microsimulation.Rcheck/ 16 | inst/lib/libmicrosimulation.a 17 | *.dll 18 | src/R.h 19 | auto 20 | NAMESPACE_old 21 | README.4.vrb 22 | README.5.vrb 23 | README.aux 24 | README.bbl 25 | README.blg 26 | README.log 27 | README.out 28 | README.tex 29 | inst/doc/html 30 | src/doc/Doxyfile.bak 31 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: microsimulation 2 | Type: Package 3 | Title: Discrete Event Simulation in R and C++, with Tools for Cost-Effectiveness Analysis 4 | Version: 1.4.4 5 | Date: 2024-08-13 6 | Authors@R: c(person("Mark", "Clements", role=c("aut","cre","cph"),email="mark.clements@ki.se"), 7 | person("Alexandra", "Jauhiainen", role="aut"), 8 | person("Andreas", "Karlsson", role="aut"), 9 | person("Antonio","Carzaniga", role="cph"), 10 | person("University of Colorado", role="cph"), 11 | person("Pierre", "L'Ecuyer", role="cph")) 12 | Description: Discrete event simulation using both R and C++ (Karlsson et al 2016; ). The C++ code is adapted from the SSIM library , allowing for event-oriented simulation. The code includes a SummaryReport class for reporting events and costs by age and other covariates. The C++ code is available as a static library for linking to other packages. A priority queue implementation is given in C++ together with an S3 closure and a reference class implementation. Finally, some tools are provided for cost-effectiveness analysis. 13 | License: GPL (>= 3) 14 | Depends: Rcpp (>= 0.10.2), methods 15 | Imports: parallel, grDevices, ascii, survival 16 | Suggests: testthat 17 | LinkingTo: Rcpp, RcppArmadillo 18 | LazyData: true 19 | URL: https://github.com/mclements/microsimulation 20 | BugReports: https://github.com/mclements/microsimulation/issues 21 | Encoding: UTF-8 22 | RoxygenNote: 7.3.2 23 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method(ICER,SummaryReport) 4 | S3method(ascii,ICER.SummaryReport) 5 | S3method(ascii,SummaryReport) 6 | S3method(print,SummaryReport) 7 | S3method(print,summary.SummaryReport) 8 | S3method(rbind,SummaryReport) 9 | S3method(simulate,survreg) 10 | S3method(summary,SummaryReport) 11 | export("enum<-") 12 | export(ICER) 13 | export(LdFlags) 14 | export(RNGStream) 15 | export(RNGstate) 16 | export(advance.substream) 17 | export(callCalibrationPerson) 18 | export(callIllnessDeath) 19 | export(callPersonSimulation) 20 | export(callSimplePerson) 21 | export(callSimplePerson2) 22 | export(discountedInterval) 23 | export(discountedPoint) 24 | export(enum) 25 | export(frontier) 26 | export(inlineCxxPlugin) 27 | export(microsimulation.exit) 28 | export(microsimulation.init) 29 | export(next.user.Random.substream) 30 | export(pqueue) 31 | export(pqueue__cancel) 32 | export(pqueue__clear) 33 | export(pqueue__empty) 34 | export(pqueue__new) 35 | export(pqueue__pop) 36 | export(pqueue__push) 37 | export(r_create_current_stream) 38 | export(r_get_user_random_seed) 39 | export(r_next_rng_substream) 40 | export(r_remove_current_stream) 41 | export(r_rng_advance_substream) 42 | export(r_set_user_random_seed) 43 | export(rnormPos) 44 | export(set.user.Random.seed) 45 | export(signed) 46 | export(unsigned) 47 | export(user.Random.seed) 48 | exportClasses(EventQueue) 49 | exportClasses(PQueueRef) 50 | exportClasses(RNGStream) 51 | import(Rcpp) 52 | import(methods) 53 | importFrom(ascii,ascii) 54 | importFrom(graphics,lines) 55 | importFrom(graphics,plot) 56 | importFrom(stats,predict) 57 | importFrom(stats,rnorm) 58 | importFrom(stats,runif) 59 | importFrom(stats,sd) 60 | importFrom(stats,simulate) 61 | importFrom(survival,survreg.distributions) 62 | useDynLib(microsimulation, .registration=TRUE) 63 | -------------------------------------------------------------------------------- /R/SummaryReport.R: -------------------------------------------------------------------------------- 1 | #' summary method for a SummaryReport object 2 | #' 3 | #' @param object SummaryReport object 4 | #' @param ... other arguments 5 | #' @return a list of class summary.SummaryReport with components: 6 | #' \describe{ 7 | #' \item{n}{Number of simulations} 8 | #' \item{indivip}{boolean with whether individual values were retained} 9 | #' \item{utilityDiscountRate}{discount rate for utilities/QALYs} 10 | #' \item{costDiscountRate}{discount rate for costs} 11 | #' \item{QALE}{Quality-adjusted life expectancy (discounted)} 12 | #' \item{LE}{Life expectancy (not discounted)} 13 | #' \item{ECosts}{Life-time expected costs (discounted)} 14 | #' \item{se.QALE}{standard error for QALE} 15 | #' \item{se.Ecosts}{standard error Ecosts} 16 | #' } 17 | #' @rdname SummaryReport 18 | #' @export 19 | summary.SummaryReport = function(object, ...) 20 | with(object, 21 | structure(list(n = n, 22 | indivp = indivp, 23 | utilityDiscountRate = utilityDiscountRate, 24 | costDiscountRate = costDiscountRate, 25 | QALE = sum(ut$utility)/n, 26 | LE = sum(pt$pt)/n, 27 | Ecosts = sum(costs$cost)/n, 28 | se.QALE = sd(indiv$utilities)/sqrt(n), 29 | se.Ecosts = sd(indiv$costs)/sqrt(n)), 30 | class="summary.SummaryReport")) 31 | 32 | #' Print summary from SummaryReport object 33 | #' 34 | #' @param x summary.SummaryReport object 35 | #' @param ... other arguments passed to print 36 | #' @rdname SummaryReport 37 | #' @export 38 | print.summary.SummaryReport <- function(x,...) 39 | with(x, 40 | print(c("n"=n,"Utility discount rate"=utilityDiscountRate,"Cost discount rate"=costDiscountRate,"Cost"=Ecosts,"(se)"=se.Ecosts,"QALYs"=QALE, 41 | "(se)"=se.QALE), 42 | ...)) 43 | 44 | #' Print SummaryReport object 45 | #' 46 | #' At present, this passes the object to summary and then prints 47 | #' 48 | #' @param x SummaryReport object 49 | #' @param ... other arguments passed to print 50 | #' @rdname SummaryReport 51 | #' @export 52 | print.SummaryReport <- function(x,...) 53 | print(summary(x),...) 54 | 55 | #' Row bind a set of SummaryReport objects 56 | #' 57 | #' @param ... a set of SummaryReport objects 58 | #' @return a SummaryReport object 59 | #' @rdname SummaryReport 60 | #' @export 61 | rbind.SummaryReport <- function(...) { 62 | objects = list(...) 63 | stopifnot(all(sapply(objects, function(obj) obj$param$utilityDiscountRate)== 64 | objects[[1]]$param$utilityDiscountRate)) 65 | stopifnot(all(sapply(objects, function(obj) obj$param$costDiscountRate)== 66 | objects[[1]]$param$costDiscountRate)) 67 | newobject = objects[[1]] 68 | newobject$n = sum(sapply(objects, "[[", "n")) 69 | for (name in c("pt","ut","events","prev","costs","indiv")) 70 | newobject[[name]] = do.call(rbind,lapply(objects, "[[", name)) 71 | newobject 72 | } 73 | 74 | #' ascii output from a SummaryReport 75 | #' 76 | #' @param x a SummaryReport object 77 | #' @param include.rownames logical for whether to include rownames (default=FALSE) 78 | #' @param include.colnames logical for whether to include colnames (default=TRUE) 79 | #' @param header logical for whether to include the header (default=TRUE) 80 | #' @param digits vector of the number of digits to use for each column 81 | #' @param ... other arguments to pass to ascii 82 | #' @return ascii object 83 | #' @rdname SummaryReport 84 | #' @export 85 | ascii.SummaryReport <- function(x,include.rownames=FALSE,include.colnames=TRUE,header=TRUE, 86 | digits=c(0,3,2,2,4,4),...) { 87 | if (requireNamespace("ascii")) { 88 | with(summary(x), 89 | ascii(c("n"=n,"Discount rate"=discountRate,"Cost"=Ecosts,"(se)"=se.Ecosts,"QALYs"=QALE, 90 | "(se)"=se.QALE), 91 | include.rownames, include.colnames, header=header, digits=digits, ...)) 92 | } else stop("ascii package not available") 93 | } 94 | 95 | #' ICER for two SummaryReport objects 96 | #' 97 | #' @param object1 SummaryReport object (reference) 98 | #' @param object2 SummaryReport object 99 | #' @param ... other arguments (not currently used) 100 | #' @return a list of type ICER.SummaryReport with components: 101 | #' \describe{ 102 | #' \item{n}{number of simulations} 103 | #' \item{utilityDiscountRate}{Discount rate for the utilities/QALE} 104 | #' \item{costDiscountRate}{Discount rate for the costs} 105 | #' \item{s1}{summary for object1} 106 | #' \item{s2}{summary for object2} 107 | #' \item{dQALE}{QALE for object2 minus QALE for object1} 108 | #' \item{dCosts}{Costs for object2 minus costs for object1} 109 | #' \item{ICER}{change of costs divided by change in QALEs} 110 | #' \item{se.dQALE}{standard error for dQALE} 111 | #' \item{se.dCosts}{standard error for dCosts} 112 | #' } 113 | #' @rdname SummaryReport 114 | #' @export 115 | ICER.SummaryReport = function(object1, object2, ...) { 116 | stopifnot(object1$n == object2$n) 117 | stopifnot(object1$utilityDiscountRate == object2$utilityDiscountRate) 118 | stopifnot(object1$costDiscountRate == object2$costDiscountRate) 119 | stopifnot(object1$indivp == object2$indivp) 120 | s1 = summary(object1) 121 | s2 = summary(object2) 122 | dQALE = s2$QALE - s1$QALE 123 | dCosts = s2$Ecosts - s1$Ecosts 124 | structure(list(n=object1$n, 125 | utilityDiscountRate=object1$utilityDiscountRate, 126 | costDiscountRate=object1$costDiscountRate, 127 | s1=s1, s2=s2, 128 | dQALE=dQALE, dCosts=dCosts, ICER=dCosts/dQALE, 129 | se.dQALE = sd(object2$indiv$utilities-object1$indiv$utilities)/sqrt(object1$n), 130 | se.dCosts = sd(object2$indiv$costs-object1$indiv$costs)/sqrt(object1$n)), 131 | class="ICER.SummaryReport") 132 | } 133 | 134 | #' ascii output from a ICER.SummaryReport object 135 | #' 136 | #' @param x an ICER.SummaryReport object 137 | #' @param include.rownames logical for whether to include rownames (default=FALSE) 138 | #' @param include.colnames logical for whether to include colnames (default=TRUE) 139 | #' @param header logical for whether to include the header (default=TRUE) 140 | #' @param digits vector of the number of digits to use for each column 141 | #' @param rownames rownames for output 142 | #' @param colnames colnames for output 143 | #' @param tgroup tgroup arg passed to ascii 144 | #' @param n.tgroup arg passed to ascii 145 | #' @param ... other arguments to pass to ascii 146 | #' @return ascii object 147 | #' @rdname SummaryReport 148 | #' @export 149 | ascii.ICER.SummaryReport <- 150 | function(x,include.rownames=TRUE,include.colnames=TRUE,header=TRUE, 151 | digits=c(1,1,3,3,1,1,3,3,1), 152 | rownames=c("Reference","Treatment"), 153 | colnames=c("Costs","(se)","QALYs","(se)","Costs","(se)","QALYs","(se)","ICER"), 154 | tgroup=c("Total","Incremental"),n.tgroup=c(4,5),...) { 155 | if (requireNamespace("ascii")) { 156 | m <- with(x, 157 | matrix(c(s1$Ecosts,s1$se.Ecosts,s1$QALE,s1$se.QALE,NA,NA,NA,NA,NA, 158 | s2$Ecosts,s2$se.Ecosts,s2$QALE,s2$se.QALE,dCosts,se.dCosts, 159 | dQALE, se.dQALE, ICER),2,byrow=TRUE)) 160 | dimnames(m) = list(rownames,colnames) 161 | ascii(m,include.rownames,include.colnames,header=header,digits=digits, 162 | tgroup=tgroup, n.tgroup=n.tgroup, ...) 163 | } else stop("ascii package not available") 164 | } 165 | 166 | -------------------------------------------------------------------------------- /R/archive/cervical.R: -------------------------------------------------------------------------------- 1 | 2 | ## initial values for the cervical model 3 | CervicalParameters <- list( 4 | nLifeHistories = 10L, screen = 0L, ## integers 5 | discountRate.effectiveness = 0.03, 6 | discountRate.costs = 0.03, 7 | full_report = 1.0, 8 | ## this needs to be changed 9 | mu0=c(0.00219, 0.000304, 5.2e-05, 0.000139, 0.000141, 3.6e-05, 7.3e-05, 10 | 0.000129, 3.8e-05, 0.000137, 6e-05, 8.1e-05, 6.1e-05, 0.00012, 11 | 0.000117, 0.000183, 0.000185, 0.000397, 0.000394, 0.000585, 0.000448, 12 | 0.000696, 0.000611, 0.000708, 0.000659, 0.000643, 0.000654, 0.000651, 13 | 0.000687, 0.000637, 0.00063, 0.000892, 0.000543, 0.00058, 0.00077, 14 | 0.000702, 0.000768, 0.000664, 0.000787, 0.00081, 0.000991, 9e-04, 15 | 0.000933, 0.001229, 0.001633, 0.001396, 0.001673, 0.001926, 0.002217, 16 | 0.002562, 0.002648, 0.002949, 0.002729, 0.003415, 0.003694, 0.004491, 17 | 0.00506, 0.004568, 0.006163, 0.006988, 0.006744, 0.00765, 0.007914, 18 | 0.009153, 0.010231, 0.011971, 0.013092, 0.013839, 0.015995, 0.017693, 19 | 0.018548, 0.020708, 0.022404, 0.02572, 0.028039, 0.031564, 0.038182, 20 | 0.042057, 0.047361, 0.05315, 0.058238, 0.062619, 0.074934, 0.089776, 21 | 0.099887, 0.112347, 0.125351, 0.143077, 0.153189, 0.179702, 0.198436, 22 | 0.240339, 0.256215, 0.275103, 0.314157, 0.345252, 0.359275, 0.41768, 23 | 0.430279, 0.463636, 0.491275, 0.549738, 0.354545, 0.553846, 0.461538, 24 | 0.782609), 25 | cost_parameters = c(Invitation = 50, 26 | FormalPSA = 130, 27 | OpportunisticPSA = 1910, 28 | FormalPSABiomarker = 730, 29 | OpportunisticPSABiomarker = 2510, #N.B. This one is new and should be used 30 | Biopsy = 12348, 31 | Prostatectomy = 117171, 32 | RadiationTherapy = 117171, 33 | ActiveSurveillance = 141358, 34 | CancerDeath = 585054, 35 | Death = 0), 36 | ## IHE doesn't use the postrecovery period (as reported in the Heijnsdijk 2012 reference), should we? 37 | utility_estimates = 1 - c(Invitation = 1, 38 | FormalPSA = 0.99, 39 | FormalPSABiomarker = 0.90, 40 | Biopsy = 0.90, 41 | OpportunisticPSA = 0.99, 42 | ProstatectomyPart1 = 0.67, 43 | ProstatectomyPart2 = 0.77, 44 | RadiationTherapyPart1 = 0.73, 45 | RadiationTherapyPart2 = 0.78, 46 | ActiveSurveillance = 0.97, 47 | PalliativeTherapy = 0.60, 48 | TerminalIllness = 0.40, 49 | MetastaticCancer = 0.85, 50 | Death = 0.00), 51 | ## Utility duration is given in years. 52 | utility_duration = c(Invitation = 0.0, 53 | FormalPSA = 1/52, 54 | FormalPSABiomarker = 3/52, 55 | Biopsy = 3/52, 56 | OpportunisticPSA = 1/52, 57 | ProstatectomyPart1 = 2/12, 58 | ProstatectomyPart2 = 10/12, 59 | RadiationTherapyPart1 = 2/12, 60 | RadiationTherapyPart2 = 10/12, 61 | ActiveSurveillance = 7, 62 | PalliativeTherapy = 30/12, 63 | TerminalIllness = 6/12) 64 | ) 65 | ## This needs to be changed 66 | pop1 <- data.frame(cohort=2012:1900, 67 | pop=c(rep(17239,9), 16854, 16085, 15504, 15604, 16381, 16705, 68 | 16762, 16853, 15487, 14623, 14066, 13568, 13361, 13161, 13234, 69 | 13088, 12472, 12142, 12062, 12078, 11426, 12027, 11963, 12435, 70 | 12955, 13013, 13125, 13065, 12249, 11103, 9637, 9009, 8828, 71 | 8350, 7677, 7444, 7175, 6582, 6573, 6691, 6651, 6641, 6268, 72 | 6691, 6511, 6857, 7304, 7308, 7859, 7277, 8323, 8561, 7173, 73 | 6942, 7128, 6819, 5037, 6798, rep(6567,46))) 74 | CervicalData <- list() 75 | cervicalEnum <- list(stateT=NULL, eventT=NULL) 76 | ## Hcervical <- data.frame(hpv, age, from, to, survival) 77 | Hcervical <- data.frame() 78 | hpvT <- c("LR_HPV","HPV_16","HPV_18","Other_HR_HPV") 79 | cervStateT <- c("Normal", "HPV", "CIN1", "CIN23", "LocalCancer", "RegionalCancer", "DistantCancer", "Death") 80 | cervEventT <- c("toHPV", "toCIN1", "toNormal", "toCIN23", "toNoCIN", "toLocalCancer", "toRegionalCancer, 81 | toDistantCancer", "toUtility", "toUtilityChange", "toOtherDeath", "toCancerDeath") 82 | cervicalData <- list(H=Hcervical) 83 | 84 | callCervical <- function(n=10, nLifeHistories=10, 85 | seed=12345, 86 | flatPop = FALSE, pop = pop1, tables = list(), debug=FALSE, 87 | discountRate = 0.03, parms = NULL, mc.cores=1) { 88 | ## save the random number state for resetting later 89 | state <- RNGstate(); on.exit(state$reset()) 90 | ## yes, we use the user-defined RNG 91 | RNGkind("user") 92 | set.user.Random.seed(seed) 93 | ## birth cohorts that should give approximately the number of men alive in Stockholm in 2012 94 | ## check the input arguments 95 | stopifnot(is.na(n) || is.integer(as.integer(n))) 96 | stopifnot(is.integer(as.integer(nLifeHistories))) 97 | ## NB: sample() calls the random number generator (!) 98 | if (is.vector(pop)) { 99 | flatPop <- TRUE 100 | pop <- data.frame(cohort=pop,pop=1) 101 | } 102 | if (is.na(n)) { 103 | cohort <- pop$cohort[rep.int(1:nrow(pop),times=pop$pop)] 104 | n <- length(cohort) 105 | } else { 106 | if (flatPop) { 107 | cohort <- rep(pop$cohort,each=ceiling(n/nrow(pop))) #Need ceiling so int n=!0 108 | n <- ceiling(n/nrow(pop)) * nrow(pop) #To get the chunks right 109 | } else 110 | cohort <- sample(pop$cohort,n,prob=pop$pop/sum(pop$pop),replace=TRUE) 111 | } 112 | cohort <- sort(cohort) 113 | ## now separate the data into chunks 114 | chunks <- tapply(cohort, sort((0:(n-1)) %% mc.cores), I) 115 | ## set the initial random numbers 116 | currentSeed <- user.Random.seed() 117 | powerFun <- function(obj,FUN,n,...) { 118 | for(i in 1:n) 119 | obj <- FUN(obj,...) 120 | obj 121 | } 122 | initialSeeds <- Reduce(function(seed,i) powerFun(seed,parallel::nextRNGStream,10), 123 | 1:mc.cores, currentSeed, accumulate=TRUE)[-1] 124 | ns <- cumsum(sapply(chunks,length)) 125 | ns <- c(0,ns[-length(ns)]) 126 | ## Minor changes to cervicalData 127 | if (!is.null(tables)) 128 | for (name in names(tables)) 129 | cervicalData[[name]] <- tables[[name]] 130 | updateParameters <- c(parms, 131 | list(nLifeHistories=as.integer(nLifeHistories), 132 | discountRate.costs=discountRate, 133 | discountRate.effectiveness=discountRate)) 134 | parameter <- CervicalParameters 135 | for (name in names(updateParameters)) 136 | parameter[[name]] <- updateParameters[[name]] 137 | pind <- sapply(parameter,class)=="numeric" & sapply(parameter,length)==1 138 | bInd <- sapply(parameter,class)=="logical" & sapply(parameter,length)==1 139 | ## now run the chunks separately 140 | print(system.time(out <- parallel::mclapply(1:mc.cores, 141 | function(i) { 142 | chunk <- chunks[[i]] 143 | set.user.Random.seed(initialSeeds[[i]]) 144 | .Call("callCervical", 145 | parms=list(n=as.integer(length(chunk)), 146 | firstId=ns[i], 147 | debug=debug, # bool 148 | cohort=as.double(chunk), 149 | parameter=unlist(parameter[pind]), 150 | bparameter=unlist(parameter[bInd]), 151 | otherParameters=parameter[!pind & !bInd], 152 | tables=cervicalData), 153 | PACKAGE="microsimulation") 154 | }, mc.cores = mc.cores))) 155 | cbindList <- function(obj) # recursive 156 | if (is.list(obj)) do.call("cbind",lapply(obj,cbindList)) else data.frame(obj) 157 | rbindList <- function(obj) # recursive 158 | if (is.list(obj)) do.call("rbind",lapply(obj,rbindList)) else data.frame(obj) 159 | reader <- function(obj) { 160 | obj <- cbindList(obj) 161 | out <- cbind(data.frame(state=enum(obj[[1]],stateT), 162 | grade=enum(obj[[2]],gradeT), 163 | dx=enum(obj[[3]],diagnosisT), 164 | psa=enum(obj[[4]],psaT), 165 | cohort=obj[[5]]), 166 | data.frame(obj[,-(1:5)])) 167 | out 168 | } 169 | ## grab all of the pt, prev, ut, events from summary 170 | ## pt <- lapply(out, function(obj) obj$summary$pt) 171 | if (length(out[[1]]$summary) == 0) summary <- list() 172 | else { 173 | summary <- lapply(seq_along(out[[1]]$summary), 174 | function(i) do.call("rbind", 175 | lapply(out, function(obj) reader(obj$summary[[i]])))) 176 | names(summary) <- names(out[[1]]$summary) 177 | states <- c("state","grade","dx","psa","cohort") 178 | names(summary$prev) <- c(states,"age","count") 179 | names(summary$pt) <- c(states,"age","pt") 180 | names(summary$ut) <- c(states,"age","ut") 181 | names(summary$events) <- c(states,"event","age","n") 182 | summary <- lapply(summary,function(obj) within(obj,year <- cohort+age)) 183 | enum(summary$events$event) <- eventT 184 | } 185 | map2df <- function(obj) as.data.frame(do.call("cbind",obj)) 186 | lifeHistories <- do.call("rbind",lapply(out,function(obj) map2df(obj$lifeHistories))) 187 | parameters <- map2df(out[[1]]$parameters) 188 | ## Identifying elements without name which also need to be rbind:ed 189 | ## costs <- do.call("rbind",lapply(out,function(obj) data.frame(obj$costs))) 190 | ## names(costs) <- c("item","cohort","age","costs") 191 | names(lifeHistories) <- c("id","state","ext_grade","dx","event","begin","end","year","psa") 192 | enum(lifeHistories$state) <- stateT 193 | enum(lifeHistories$event) <- eventT 194 | enum <- list(stateT = stateT, eventT = eventT) 195 | out <- list(n=n,enum=enum,lifeHistories=lifeHistories, 196 | parameters=parameters, 197 | ## summary=summary, costs=costs, 198 | cohort=data.frame(table(cohort)), 199 | discountRate = discountRate) 200 | class(out) <- "cervical" 201 | out 202 | } 203 | -------------------------------------------------------------------------------- /R/calibSim.R: -------------------------------------------------------------------------------- 1 | #' call CalibrationPerson example 2 | #' 3 | #' @param seed random number seed 4 | #' @param n number of simulations 5 | #' @param runpar parameters 6 | #' @param mc.cores number of cores 7 | #' @return data-frame 8 | #' @export 9 | #' @rdname Examples 10 | callCalibrationPerson <- function(seed=12345,n=500,runpar=c(4,0.5,0.05,10,3,0.5),mc.cores=1) { 11 | 12 | state <- RNGstate(); on.exit(state$reset()) 13 | RNGkind("user") 14 | set.user.Random.seed(seed) 15 | 16 | f <- as.factor(rep(1:mc.cores,length.out=n)) 17 | chunks <- split(1:n,f) 18 | initialSeeds <- list() 19 | currentSeed <- user.Random.seed() 20 | 21 | fun <- function(obj, i) if(i==1)obj else parallel::nextRNGStream(obj) 22 | for(i in 1:mc.cores){ 23 | initialSeeds[[i]] <- fun(currentSeed,i) 24 | currentSeed <- initialSeeds[[i]] 25 | } 26 | out <- parallel::mclapply(1:mc.cores, function(i) { 27 | chunk <- chunks[[i]] 28 | set.user.Random.seed(initialSeeds[[i]]) 29 | .Call("callCalibrationSimulation",list(n=as.integer(length(chunk)),runpar=as.double(runpar)),PACKAGE="microsimulation") 30 | }) 31 | states <- c("DiseaseFree","Precursor","PreClinical","Clinical") 32 | out <- lapply(out, function(o){ 33 | curnames <- names(o) 34 | mat <- matrix(0,nrow=10,ncol=length(states)) 35 | colnames(mat) <- states; rownames(mat) <- seq(10,100,10) 36 | mat[,states[states %in% curnames]]<-data.matrix(transform(as.data.frame(o[states[states %in% curnames]]))) 37 | list(StateOccupancy=mat, TimeAtRisk=o$TimeAtRisk) 38 | }) 39 | Reduce(function(u,z) list(StateOccupancy=u$StateOccupancy + z$StateOccupancy, TimeAtRisk = u$TimeAtRisk + z$TimeAtRisk),out) 40 | } 41 | -------------------------------------------------------------------------------- /R/plugin.R: -------------------------------------------------------------------------------- 1 | 2 | #' Internal function 3 | #' 4 | #' @rdname Utilities 5 | .microsimulationLdFlags <- function(){ 6 | paste( '-L"', system.file( "lib", package = "microsimulation" ), '" -lmicrosimulation', 7 | sep = "" ) 8 | } 9 | 10 | #' Code to use the microsimulation package inline 11 | #' @param ... arguments 12 | #' @rdname Utilities 13 | #' @export 14 | inlineCxxPlugin <- function(...) { 15 | ismacos <- Sys.info()[["sysname"]] == "Darwin" 16 | openmpflag <- if (ismacos) "" else "$(SHLIB_OPENMP_CFLAGS)" 17 | plugin <- Rcpp::Rcpp.plugin.maker(include.before = "#include ", 18 | libs = paste(openmpflag, 19 | .microsimulationLdFlags(), 20 | "$(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS)"), 21 | package = "microsimulation") 22 | settings <- plugin() 23 | settings$env$PKG_CPPFLAGS <- paste("-I../inst/include", openmpflag) 24 | ## if (!ismacos) settings$env$USE_CXX11 <- "yes" 25 | settings 26 | } 27 | -------------------------------------------------------------------------------- /R/pqueue.R: -------------------------------------------------------------------------------- 1 | #' S3 priority queue implementation using C++ 2 | #' 3 | #' This provides a priority queue that is sorted by the priority and entry order. The priority is assumed to be numeric. The events can be of any type. As an extension, events can be cancelled if they satisfy a certain predicate. Note that the inactive events are not removed, rather they are marked as cancelled and will not be available to be popped. 4 | #' 5 | #' @param lower boolean to determine whether to give priority to lower values (default=TRUE) 6 | #' or higher values 7 | #' 8 | #' @return a list with 9 | #' \describe{ 10 | #' \item{push}{function with arguments priority (numeric) and event (SEXP). Pushes an event with a given priority} 11 | #' \item{pop}{function to return a list with a priority (numeric) and an event (SEXP). This pops the first active event.} 12 | #' \item{cancel}{function that takes a predicate (or R function) for a given event and returns a logical that indicates whether to cancel that event or not. This may cancel some events that will no longer be popped.} 13 | #' \item{empty}{function that returns whether the priority queue is empty (or has no active events).} 14 | #' \item{clear}{function to clear the priority queue.} 15 | #' \item{ptr}{XPtr value} 16 | #' } 17 | #' 18 | #' @export 19 | #' 20 | #' @examples 21 | #' pq = pqueue() 22 | #' pq$push(3,"Clear drains") 23 | #' pq$push(4, "Feed cat") 24 | #' pq$push(5, "Make tea") 25 | #' pq$push(1, "Solve RC tasks") 26 | #' pq$push(2, "Tax return") 27 | #' while(!pq$empty()) 28 | #' print(pq$pop()) 29 | #' 30 | #' @rdname Classes 31 | pqueue <- function(lower = TRUE) { 32 | stopifnot(is.logical(lower), length(lower)==1) 33 | ptr <- .Call(pqueue__new, as.logical(lower)) 34 | push <- function(priority, event) { 35 | stopifnot(is.numeric(priority), length(priority)==1) 36 | .Call(pqueue__push, ptr, as.double(priority), event) 37 | invisible() 38 | } 39 | pop <- function() .Call(pqueue__pop, ptr) 40 | cancel <- function(predicate) { 41 | stopifnot(is.function(predicate)) 42 | .Call(pqueue__cancel, ptr, predicate) 43 | invisible() 44 | } 45 | empty <- function() { 46 | .Call(pqueue__empty, ptr) 47 | } 48 | clear <- function() { 49 | .Call(pqueue__clear, ptr) 50 | invisible() 51 | } 52 | structure(list(push=push, pop=pop, cancel=cancel, empty=empty, clear=clear, ptr=ptr), 53 | class="pqueue") 54 | } 55 | 56 | #' Reference class implementation of a priority queue 57 | #' 58 | #' Based on C++ code. See also the S3 implementation \code{pqueue}. 59 | #' 60 | #' 61 | #' @examples 62 | #' pq = new("PQueueRef") 63 | #' pq$push(3,"Clear drains") 64 | #' pq$push(4, "Feed cat") 65 | #' pq$push(5, "Make tea") 66 | #' pq$push(1, "Solve RC tasks") 67 | #' pq$push(2, "Tax return") 68 | #' while(!pq$empty()) 69 | #' print(pq$pop()) 70 | #' 71 | #' @import methods 72 | #' @exportClass PQueueRef 73 | #' @field ptr External pointer to the C++ class 74 | #' @rdname Classes 75 | PQueueRef <- 76 | setRefClass("PQueueRef", 77 | fields = list(ptr = "externalptr"), 78 | methods = list( 79 | help = function() { 80 | 'Reference class implementation of an event queue' 81 | }, 82 | initialize = function(lower = TRUE) { 83 | 'Method to initialize the object. lower argument indicates whether lowest priority or highest priority' 84 | stopifnot(is.logical(lower), length(lower)==1) 85 | ptr <<- .Call(pqueue__new, as.logical(lower)) 86 | }, 87 | push = function(priority, event) { 88 | 'Method to push an event with a given priority' 89 | stopifnot(is.numeric(priority), length(priority)==1) 90 | .Call(pqueue__push, ptr, as.double(priority), event) 91 | invisible() 92 | }, 93 | pop = function() { 94 | 'Method to remove the head of the event queue and return its value' 95 | .Call(pqueue__pop, ptr) 96 | }, 97 | cancel = function(predicate) { 98 | 'Method to cancel events that satisfy some predicate' 99 | stopifnot(is.function(predicate)) 100 | .Call(pqueue__cancel, ptr, predicate) 101 | invisible() 102 | }, 103 | empty = function() { 104 | 'Method to check whether there are no events in the queue' 105 | .Call(pqueue__empty, ptr) 106 | }, 107 | clear = function() { 108 | 'Method to clear the event queue' 109 | .Call(pqueue__clear, ptr) 110 | invisible() 111 | })) 112 | 113 | #' C++ function 114 | #' @rdname Internal 115 | #' @name pqueue__new 116 | #' @export 117 | NULL 118 | 119 | #' C++ function 120 | #' @rdname Internal 121 | #' @name pqueue__push 122 | #' @export 123 | NULL 124 | 125 | #' C++ function 126 | #' @rdname Internal 127 | #' @name pqueue__pop 128 | #' @export 129 | NULL 130 | 131 | #' C++ function 132 | #' @rdname Internal 133 | #' @name pqueue__cancel 134 | #' @export 135 | NULL 136 | 137 | #' C++ function 138 | #' @rdname Internal 139 | #' @name pqueue__empty 140 | #' @export 141 | NULL 142 | 143 | #' C++ function 144 | #' @rdname Internal 145 | #' @name pqueue__clear 146 | #' @export 147 | NULL 148 | -------------------------------------------------------------------------------- /R/simulate.R: -------------------------------------------------------------------------------- 1 | #' Simulate event times from a survreg object 2 | #' @param object survreg object 3 | #' @param nsim number of simulations per row in newdata 4 | #' @param seed random number seed 5 | #' @param newdata data-frame for defining the covariates for the simulations. Required. 6 | #' @param t0 delayed entry time. Defaults to NULL (which assumes that t0=0) 7 | #' @param ... other arguments (not currently used) 8 | #' @return vector of event times with nsim repeats per row in newdata 9 | #' @importFrom stats simulate predict runif 10 | #' @importFrom survival survreg.distributions 11 | #' @rdname simulate 12 | #' @export 13 | #' @examples 14 | #' library(survival) 15 | #' fit <- survreg(Surv(time, status) ~ ph.ecog + age + sex + strata(sex), 16 | #' data = lung) 17 | #' nd = transform(expand.grid(ph.ecog=0:1, sex=1:2), age=60) 18 | #' simulate(fit, seed=1002, newdata=nd) 19 | #' simulate(fit, seed=1002, newdata=nd, t0=500) 20 | simulate.survreg = function(object, nsim=1, seed=NULL, newdata, t0=NULL, ...) { 21 | stopifnot(inherits(object, "survreg"), 22 | is.list(newdata)) 23 | if (!is.null(seed)) set.seed(seed) 24 | lp = predict(object, newdata=newdata, type="lp") 25 | lp = lp[rep(1:length(lp), each=nsim)] 26 | n = length(lp) 27 | if (!is.null(strata <- attr(object$terms, "specials")$strata)) { 28 | scale = object$scale[eval(attr(object$terms,"variables")[[strata+1]], newdata)] 29 | scale = rep(scale, each=nsim) 30 | } 31 | else scale = rep(object$scale,n) 32 | if (is.character(object$dist)) 33 | dd <- survival::survreg.distributions[[object$dist]] 34 | else dd <- object$dist 35 | if (is.null(dd$itrans)) { 36 | trans <- function(x) x 37 | itrans <- function(x) x 38 | } 39 | else { 40 | trans <- dd$trans 41 | itrans <- dd$itrans 42 | } 43 | if (!is.null(dd$dist)) 44 | dd <- survival::survreg.distributions[[dd$dist]] 45 | if (!is.null(t0)) { 46 | stopifnot(length(t0) %in% c(1, length(newdata[[1]]))) 47 | if (length(t0)==1) t0=rep(t0,n) 48 | else t0 = rep(t0,each=nsim) 49 | F0 = dd$density((trans(t0)-lp)/scale,object$parm)[,1] 50 | } else F0 = rep(0,n) 51 | itrans(lp+scale*dd$quantile(1-(runif(n, F0, 1)-F0), object$parm)) 52 | } 53 | -------------------------------------------------------------------------------- /R/zzz.R: -------------------------------------------------------------------------------- 1 | 2 | #' Internal function 3 | #' @param lib library string 4 | #' @param pkg package string 5 | #' @rdname Utilities 6 | .onLoad <- function (lib, pkg) { 7 | # if (!exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) 8 | # invisible(rnorm(1)) # kludge to initialise the random seed 9 | microsimulation.init() 10 | } 11 | 12 | #' Internal function 13 | #' @param libpath library path string 14 | #' @rdname Utilities 15 | .onUnload <- function (libpath) { 16 | microsimulation.exit() 17 | library.dynam.unload("microsimulation", libpath) 18 | } 19 | -------------------------------------------------------------------------------- /clean.sh: -------------------------------------------------------------------------------- 1 | rm config.status 2 | rm -rf autom4te.cache 3 | rm config.log -------------------------------------------------------------------------------- /data/fhcrcData.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mclements/microsimulation/767d0fec31e448ca3625b8ca9d998e1b1c5714c7/data/fhcrcData.rda -------------------------------------------------------------------------------- /inst/develop_to_master.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # http://stackoverflow.com/questions/2763006/change-the-current-branch-to-master-in-git 3 | 4 | git checkout develop 5 | git merge --strategy=ours master # keep the content of this branch, but record a merge 6 | git checkout master 7 | git merge develop # fast-forward master up to the merge 8 | -------------------------------------------------------------------------------- /inst/doc/illness_death.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mclements/microsimulation/767d0fec31e448ca3625b8ca9d998e1b1c5714c7/inst/doc/illness_death.png -------------------------------------------------------------------------------- /inst/doc/index.html: -------------------------------------------------------------------------------- 1 | 2 | 4 | 5 | 6 | 7 | 8 | 9 | Additional documentation 10 | 11 | 12 | 183 | 229 | 230 | 231 |
232 |

Additional documentation

233 |

234 | For extensive Doxygen documentation, see html/index.html. 235 |

236 | 237 |

238 | For some further examples, see examples.html. 239 |

240 |
241 | 242 | 243 | -------------------------------------------------------------------------------- /inst/doc/index.org: -------------------------------------------------------------------------------- 1 | #+title: Additional documentation 2 | 3 | #+options: html-postamble:nil 4 | 5 | For extensive Doxygen documentation, see [[file:html/index.html][html/index.html]]. 6 | 7 | For some further examples, see [[file:examples.html][examples.html]]. 8 | -------------------------------------------------------------------------------- /inst/doc/rates.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mclements/microsimulation/767d0fec31e448ca3625b8ca9d998e1b1c5714c7/inst/doc/rates.png -------------------------------------------------------------------------------- /inst/doc/reporting.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mclements/microsimulation/767d0fec31e448ca3625b8ca9d998e1b1c5714c7/inst/doc/reporting.png -------------------------------------------------------------------------------- /inst/doc/tick_tock.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mclements/microsimulation/767d0fec31e448ca3625b8ca9d998e1b1c5714c7/inst/doc/tick_tock.png -------------------------------------------------------------------------------- /inst/include/RngStream.h: -------------------------------------------------------------------------------- 1 | /** 2 | * @file RngStream.h for multiple streams of Random Numbers 3 | * @author Pierre L'Ecuyer, University of Montreal 4 | * Original date: 14 August 2001 5 | * Modified by Mark Clements 2014-03-22 for the microsimulation package. 6 | * 7 | * @section LICENSE 8 | * 9 | * This program is free software; you can redistribute it and/or 10 | * modify it under the terms of the GNU General Public License as 11 | * published by the Free Software Foundation; either version 2 of 12 | * the License, or (at your option) any later version. 13 | * 14 | * This program is distributed in the hope that it will be useful, but 15 | * WITHOUT ANY WARRANTY; without even the implied warranty of 16 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 17 | * General Public License for more details at 18 | * http://www.gnu.org/copyleft/gpl.html 19 | */ 20 | 21 | 22 | #ifndef RNGSTREAM_H 23 | #define RNGSTREAM_H 24 | 25 | #include 26 | #include 27 | 28 | namespace ssim { 29 | 30 | class RngStream 31 | { 32 | public: 33 | 34 | RngStream (const char *name = ""); 35 | 36 | 37 | static bool SetPackageSeed (const double seed[6]); 38 | 39 | 40 | void ResetStartStream (); 41 | 42 | 43 | void ResetStartSubstream (); 44 | 45 | 46 | void ResetNextSubstream (); 47 | 48 | 49 | void SetAntithetic (bool a); 50 | 51 | 52 | void IncreasedPrecis (bool incp); 53 | 54 | 55 | bool SetSeed (const double seed[6]); 56 | 57 | 58 | void GenAdvanceState (int32_t e, int32_t c, 59 | const double A1[3][3], const double A2[3][3], 60 | const double InvA1[3][3], const double InvA2[3][3]); 61 | 62 | 63 | void AdvanceState (int32_t e, int32_t c); 64 | 65 | 66 | void AdvanceSubstream (int32_t e, int32_t c); 67 | 68 | 69 | void AdvanceStream (int32_t e, int32_t c); 70 | 71 | 72 | void CalcMatrix (int32_t e, int32_t c, double C1[3][3], double C2[3][3]); 73 | 74 | 75 | void GetState (double seed[6]) const; 76 | 77 | 78 | /* void WriteState () const; */ 79 | 80 | 81 | /* void WriteStateFull () const; */ 82 | 83 | 84 | double RandU01 (); 85 | 86 | 87 | int RandInt (int i, int j); 88 | 89 | 90 | 91 | private: 92 | 93 | double Cg[6], Bg[6], Ig[6]; 94 | 95 | 96 | bool anti, incPrec; 97 | 98 | 99 | std::string name; 100 | 101 | 102 | static double nextSeed[6]; 103 | 104 | 105 | double U01 (); 106 | 107 | 108 | double U01d (); 109 | 110 | 111 | }; 112 | 113 | } // ssim namespace 114 | 115 | #endif 116 | 117 | 118 | -------------------------------------------------------------------------------- /inst/include/c_optim.h: -------------------------------------------------------------------------------- 1 | #ifndef C_OPTIM_H 2 | #define C_OPTIM_H 3 | 4 | #include 5 | #include /* DBL_EPSILON */ 6 | 7 | namespace ssim { 8 | 9 | template 10 | std::tuple // (root,tol,iterations) 11 | R_zeroin2_functor_ptr( /* An estimate of the root */ 12 | double ax, /* Left border | of the range */ 13 | double bx, /* Right border| the root is seeked*/ 14 | Functor *f, 15 | double Tol, /* Acceptable tolerance */ 16 | int Maxit) /* Max # of iterations */ 17 | { 18 | using Result = std::tuple; 19 | double a,b,c, fa, fb, fc; /* Abscissae, descr. see above, f(c) */ 20 | double tol; 21 | int maxit; 22 | a = ax; b = bx; fa = (*f)(a); fb = (*f)(b); 23 | c = a; fc = fa; 24 | maxit = Maxit + 1; tol = Tol; 25 | /* First test if we have found a root at an endpoint */ 26 | if(fa == 0.0) { 27 | Tol = 0.0; 28 | Maxit = 0; 29 | return Result(a,Tol,Maxit); 30 | } 31 | if(fb == 0.0) { 32 | Tol = 0.0; 33 | Maxit = 0; 34 | return Result(b,Tol,Maxit); 35 | } 36 | while(maxit--) /* Main iteration loop */ 37 | { 38 | double prev_step = b-a; /* Distance from the last but one 39 | to the last approximation */ 40 | double tol_act; /* Actual tolerance */ 41 | double p; /* Interpolation step is calcu- */ 42 | double q; /* lated in the form p/q; divi- 43 | * sion operations is delayed 44 | * until the last moment */ 45 | double new_step; /* Step at this iteration */ 46 | if( fabs(fc) < fabs(fb) ) 47 | { /* Swap data for b to be the */ 48 | a = b; b = c; c = a; /* best approximation */ 49 | fa=fb; fb=fc; fc=fa; 50 | } 51 | tol_act = 2*DBL_EPSILON*fabs(b) + tol/2; 52 | new_step = (c-b)/2; 53 | if( fabs(new_step) <= tol_act || fb == (double)0 ) 54 | { 55 | Maxit -= maxit; 56 | Tol = fabs(c-b); 57 | return Result(b,Maxit,Tol); /* Acceptable approx. is found */ 58 | } 59 | /* Decide if the interpolation can be tried */ 60 | if( fabs(prev_step) >= tol_act /* If prev_step was large enough*/ 61 | && fabs(fa) > fabs(fb) ) { /* and was in true direction, 62 | * Interpolation may be tried */ 63 | double t1,cb,t2; 64 | cb = c-b; 65 | if( a==c ) { /* If we have only two distinct */ 66 | /* points linear interpolation */ 67 | t1 = fb/fa; /* can only be applied */ 68 | p = cb*t1; 69 | q = 1.0 - t1; 70 | } 71 | else { /* Quadric inverse interpolation*/ 72 | q = fa/fc; t1 = fb/fc; t2 = fb/fa; 73 | p = t2 * ( cb*q*(q-t1) - (b-a)*(t1-1.0) ); 74 | q = (q-1.0) * (t1-1.0) * (t2-1.0); 75 | } 76 | if( p>(double)0 ) /* p was calculated with the */ 77 | q = -q; /* opposite sign; make p positive */ 78 | else /* and assign possible minus to */ 79 | p = -p; /* q */ 80 | if( p < (0.75*cb*q-fabs(tol_act*q)/2) /* If b+p/q falls in [b,c]*/ 81 | && p < fabs(prev_step*q/2) ) /* and isn't too large */ 82 | new_step = p/q; /* it is accepted 83 | * If p/q is too large then the 84 | * bisection procedure can 85 | * reduce [b,c] range to more 86 | * extent */ 87 | } 88 | if( fabs(new_step) < tol_act) { /* Adjust the step to be not less*/ 89 | if( new_step > (double)0 ) /* than tolerance */ 90 | new_step = tol_act; 91 | else 92 | new_step = -tol_act; 93 | } 94 | a = b; fa = fb; /* Save the previous approx. */ 95 | b += new_step; fb = (*f)(b); /* Do step to a new approxim. */ 96 | if( (fb > 0 && fc > 0) || (fb < 0 && fc < 0) ) { 97 | /* Adjust c for it to have a sign opposite to that of b */ 98 | c = a; fc = fa; 99 | } 100 | } 101 | /* failed! */ 102 | Tol = fabs(c-b); 103 | Maxit = -1; 104 | return Result(b,Tol,Maxit); 105 | } 106 | 107 | 108 | } // anonymous ssim 109 | 110 | #endif /* c_optim_h */ 111 | -------------------------------------------------------------------------------- /inst/include/gsm.h: -------------------------------------------------------------------------------- 1 | #ifndef MICROSIMULATION_GSM_H 2 | #define MICROSIMULATION_GSM_H 3 | 4 | #include 5 | #include 6 | 7 | namespace ssim { 8 | 9 | enum link_types {PH}; 10 | 11 | class gsm_term { 12 | public: 13 | ns ns1; 14 | arma::vec gamma, x; 15 | }; 16 | 17 | class gsm { 18 | public: 19 | link_types link_type; 20 | double tmin, tmax, target, target0, t0; 21 | arma::vec etap, etap0; 22 | std::vector terms; 23 | int index; 24 | bool log_time; 25 | double link(double S); 26 | double linkinv(double eta); 27 | gsm(); // default constructor 28 | gsm(SEXP args); 29 | gsm(Rcpp::List list); 30 | double eta(double y); 31 | double eta0(double y); 32 | double operator()(double y); 33 | double rand(double tentry=0.0, int index = 0, double scale=10.0); 34 | double randU(double u, double tentry=0.0, int index = 0, double scale=10.0); 35 | double randU0(double u, int index = 0, double scale=10.0); 36 | }; 37 | 38 | } 39 | 40 | #endif /* gsm.h */ 41 | -------------------------------------------------------------------------------- /inst/include/heap.h: -------------------------------------------------------------------------------- 1 | // -*-C++-*- 2 | // 3 | // This file is part of SSim, a simple discrete-event simulator. 4 | // See http://www.inf.usi.ch/carzaniga/ssim/ 5 | // 6 | // Copyright (C) 2004-2005 University of Colorado 7 | // Copyright (C) 2012 Antonio Carzaniga 8 | // 9 | // Authors: Antonio Carzaniga 10 | // See AUTHORS for full details. 11 | // 12 | // SSim is free software: you can redistribute it and/or modify it under 13 | // the terms of the GNU General Public License as published by the Free 14 | // Software Foundation, either version 3 of the License, or (at your 15 | // option) any later version. 16 | // 17 | // SSim is distributed in the hope that it will be useful, 18 | // but WITHOUT ANY WARRANTY; without even the implied warranty of 19 | // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 20 | // GNU General Public License for more details. 21 | // 22 | // You should have received a copy of the GNU General Public License 23 | // along with SSim. If not, see . 24 | // 25 | #ifndef _heap_h 26 | #define _heap_h 27 | 28 | #include 29 | 30 | namespace ssim { 31 | 32 | // 33 | // This is an implementation of a binary heap taken from R. Sedgewick, 34 | // "Algorithms in C," 3rd Ed., Vol. 1, pp. 368--375. A few 35 | // modifications to Sedgewick's implementation are noted below. 36 | // Notice that this implementation is completely independent from the 37 | // rest of SSim, and in fact can be used as is elsewhere. 38 | // 39 | template 40 | class heap { 41 | public: 42 | typedef typename std::vector::size_type size_type; 43 | typedef typename std::vector::iterator iterator; 44 | typedef typename std::vector::const_iterator const_iterator; 45 | 46 | private: 47 | std::vector a; 48 | static void swap(T & first, T & second) throw() { 49 | T tmp = first; 50 | first = second; 51 | second = tmp; 52 | } 53 | // contrary to Sedgewick's implementation, which counts elements 54 | // starting from 1, we start from 0. So, in order to avoid 55 | // confusion and mistakes, we abstract all the position stuff with 56 | // the following member functions. The compiler should optimize 57 | // everything out anyway. 58 | // 59 | static const size_type FIRST = 0; 60 | size_type last() const throw() { return a.size() - 1; } 61 | static size_type left(size_type pos) throw() { return pos*2 + 1; } 62 | static size_type right(size_type pos) throw() { return (pos + 1)*2; } 63 | static size_type parent(size_type pos) throw() { return (pos - 1)/2; } 64 | 65 | public: 66 | bool empty() throw() { return a.empty(); } 67 | iterator begin() throw() { return a.begin(); } 68 | iterator end() throw() { return a.end(); } 69 | const_iterator begin() const throw() { return a.begin(); } 70 | const_iterator end() const throw() { return a.end(); } 71 | void clear() throw() { a.clear(); } 72 | iterator erase(iterator first, iterator last) throw() {return a.erase(first, last); } 73 | 74 | void insert(const T & x) throw() { 75 | a.push_back(x); 76 | size_type k = last(); 77 | size_type k_parent; 78 | while(k > FIRST) { 79 | k_parent = parent(k); 80 | if (a[k] < a[k_parent]) { 81 | swap(a[k], a[k_parent]); 82 | k = k_parent; 83 | } else { 84 | return; 85 | } 86 | } 87 | } 88 | 89 | T pop_first() throw() { 90 | // ASSERT( FIRST <= last() ). I.e., ! empty() 91 | T res = a[FIRST]; 92 | if (FIRST == last()) { 93 | a.pop_back(); 94 | return res; 95 | } 96 | a[FIRST] = a[last()]; 97 | a.pop_back(); 98 | size_type k = FIRST; 99 | size_type k_next; 100 | for(;;) { 101 | k_next = left(k); 102 | if (k_next > last()) { 103 | break; 104 | } 105 | if (right(k) <= last() && a[right(k)] < a[k_next]) { 106 | k_next = right(k); 107 | } 108 | if (a[k_next] < a[k]) { 109 | swap(a[k], a[k_next]); 110 | k = k_next; 111 | } else { 112 | break; 113 | } 114 | } 115 | return res; 116 | } 117 | }; 118 | 119 | } // end namespace ssim 120 | 121 | #endif /* _ssim_h */ 122 | 123 | -------------------------------------------------------------------------------- /inst/include/rcpp_table.h: -------------------------------------------------------------------------------- 1 | #ifndef RCPP_TABLE_H 2 | #define RCPP_TABLE_H 3 | 4 | #include 5 | 6 | #include 7 | #include 8 | #include 9 | 10 | using namespace std; 11 | using namespace Rcpp; 12 | using std::get; 13 | 14 | // TODO: re-write the DataFrameView class and adapt the Table class for it. 15 | 16 | class Interpolate { 17 | public: 18 | vector x, y, slope; 19 | Interpolate() { 20 | } 21 | Interpolate(vector inx, vector iny) : 22 | x(inx), y(iny) { 23 | // calculate the slope between points 24 | for (size_t i=0; i=*(--x.end())) return *(--y.end()); 32 | else { 33 | i = lower_bound(x.begin(), x.end(), xfind) - x.begin(); 34 | return y[i]+slope[i]*(xfind-x[i]); 35 | } 36 | } 37 | double operator()(double xfind) { 38 | if (xfind<=x[0]) return y[0]; 39 | int i = lower_bound(x.begin(), x.end(), xfind) - x.begin(); 40 | return y[--i]; 41 | } 42 | }; 43 | 44 | /** 45 | Class for numerical interpolation for x and y. 46 | Includes methods to read in x and y from a data-frame or from pairs of (x,y). 47 | Includes methods for linear approximation (approx, x->y) and inversion of increasing (invert) 48 | and decreasing (invert_decreasing) values (y->x). 49 | Includes an operator for a stepwise, left continuous function x->y. 50 | **/ 51 | 52 | class NumericInterpolate { 53 | public: 54 | NumericVector x, y, slope; 55 | int n; 56 | NumericInterpolate() : x(0), y(0), slope(0), n(0) { 57 | } 58 | NumericInterpolate(DataFrame df, int i0=0, int i1=1) { 59 | // calculate the slope between points 60 | x = df(i0); 61 | y = df(i1); 62 | n = x.size(); 63 | prepare(); 64 | } 65 | void prepare() { 66 | for (int i=0; i xy) { 71 | x.push_back(xy.first); 72 | y.push_back(xy.second); 73 | n++; 74 | } 75 | double approx(double xfind) { 76 | int i; 77 | if (xfind<=x[0]) return y[0]; 78 | else if (xfind>=x[n-1]) return y[n-1]+slope[n-2]*(xfind-x[n-1]); // linear 79 | else { 80 | i = lower_bound(x.begin(), x.end(), xfind) - 1 - x.begin(); 81 | return y[i]+slope[i]*(xfind-x[i]); 82 | } 83 | } 84 | double operator()(double xfind) { 85 | if (xfind<=x[0]) return y[0]; 86 | int i = lower_bound(x.begin(), x.end(), xfind) - x.begin(); 87 | return y[--i]; 88 | } 89 | double invert(double yfind) { // assumes that the function is increasing 90 | int i; 91 | if (yfind<=y[0]) return x[0]; 92 | else if (yfind>=y[n-1]) return x[n-1]+(yfind-y[n-1])/slope[n-2]; 93 | else { 94 | i = lower_bound(y.begin(), y.end(), yfind) - 1 - y.begin(); 95 | return x[i]+(yfind-y[i])/slope[i]; 96 | } 97 | } 98 | double invert(double yfind, double xentry) { // assumes that the function is increasing 99 | double yentry = approx(xentry); 100 | return invert(yfind - yentry); 101 | } 102 | double invert_decreasing(double yfind) { // assumes that the function is decreasing 103 | int i; 104 | if (yfind>=y[0]) return x[0]; 105 | else if (yfind()) - 1 - y.begin(); 108 | return x[i]+(yfind-y[i])/slope[i]; 109 | } 110 | } 111 | }; 112 | 113 | 114 | template 115 | T set_lower_bound(set > aset, T value) { 116 | return value<*aset.rbegin() ? *aset.rbegin() : *aset.lower_bound(value); 117 | } 118 | 119 | template 120 | class DataFrameSelect { 121 | public: 122 | Vector::rtype> data; 123 | DataFrameSelect(const DataFrame & df, int i = 0) { 124 | data = df(i); // copy 125 | } 126 | DataFrameSelect(const DataFrame & df, string name) { 127 | data = df[name]; 128 | } 129 | T operator[](int i) { 130 | return(data[i]); 131 | } 132 | int size() { 133 | return data.size(); 134 | } 135 | }; 136 | 137 | /** @brief A table class for lookups. For the case of a single key, 138 | this is a small extension to std::map, including the ability to 139 | read columns from a DataFrame. Looking up a key which is less than the 140 | lowest key value will use the lowest key. 141 | 142 | **/ 143 | struct null_type {}; 144 | 145 | template 147 | class Table { 148 | public: 149 | Table() {} 150 | typedef std::tuple key_type; 151 | typedef Outcome mapped_type; 152 | typedef std::tuple< 153 | set >, 154 | set >, 155 | set >, 156 | set >, 157 | set > 158 | > Axis; 159 | void insert(I0 key0, I1 key1, I2 key2, I3 key3, I4 key4, Outcome outcome) { 160 | key_type key = key_type(key0,key1,key2,key3,key4); 161 | get<0>(axis).insert(key0); 162 | get<1>(axis).insert(key1); 163 | get<2>(axis).insert(key2); 164 | get<3>(axis).insert(key3); 165 | get<4>(axis).insert(key4); 166 | data[key] = outcome; 167 | } 168 | virtual Outcome operator()(I0 i0, I1 i1, I2 i2, I3 i3, I4 i4) { 169 | return data[key_type(set_lower_bound(get<0>(axis), i0), 170 | set_lower_bound(get<1>(axis), i1), 171 | set_lower_bound(get<2>(axis), i2), 172 | set_lower_bound(get<3>(axis), i3), 173 | set_lower_bound(get<4>(axis), i4))]; 174 | } 175 | Table(const DataFrame & df, string s0, string s1, string s2, string s3, string s4, string s5) { 176 | DataFrameSelect df0(df,s0); 177 | DataFrameSelect df1(df,s1); 178 | DataFrameSelect df2(df,s2); 179 | DataFrameSelect df3(df,s3); 180 | DataFrameSelect df4(df,s4); 181 | DataFrameSelect df5(df,s5); 182 | for (int i=0; i data; 189 | }; 190 | 191 | template 192 | class Table { 193 | public: 194 | typedef std::tuple key_type; 195 | typedef Outcome mapped_type; 196 | typedef std::tuple< 197 | set >, 198 | set >, 199 | set >, 200 | set > 201 | > Axis; 202 | Table() {} 203 | void insert(I0 key0, I1 key1, I2 key2, I3 key3, mapped_type outcome) { 204 | key_type key = key_type(key0,key1,key2,key3); 205 | get<0>(axis).insert(key0); 206 | get<1>(axis).insert(key1); 207 | get<2>(axis).insert(key2); 208 | get<3>(axis).insert(key3); 209 | data[key] = outcome; 210 | } 211 | virtual Outcome operator()(I0 i0, I1 i1, I2 i2, I3 i3) { 212 | return data[key_type(set_lower_bound(get<0>(axis), i0), 213 | set_lower_bound(get<1>(axis), i1), 214 | set_lower_bound(get<2>(axis), i2), 215 | set_lower_bound(get<3>(axis), i3))]; 216 | } 217 | Table(const DataFrame & df, string s0, string s1, string s2, string s3, string s4) { 218 | DataFrameSelect df0(df,s0); 219 | DataFrameSelect df1(df,s1); 220 | DataFrameSelect df2(df,s2); 221 | DataFrameSelect df3(df,s3); 222 | DataFrameSelect df4(df,s4); 223 | for (int i=0; i data; 230 | }; 231 | 232 | template 233 | class Table { 234 | public: 235 | typedef std::tuple key_type; 236 | typedef Outcome mapped_type; 237 | typedef std::tuple< 238 | set >, 239 | set >, 240 | set > 241 | > Axis; 242 | Table() {} 243 | void insert(I0 key0, I1 key1, I2 key2, mapped_type outcome) { 244 | key_type key = key_type(key0,key1,key2); 245 | get<0>(axis).insert(key0); 246 | get<1>(axis).insert(key1); 247 | get<2>(axis).insert(key2); 248 | data[key] = outcome; 249 | } 250 | virtual Outcome operator()(I0 i0, I1 i1, I2 i2) { 251 | return data[key_type(set_lower_bound(get<0>(axis), i0), 252 | set_lower_bound(get<1>(axis), i1), 253 | set_lower_bound(get<2>(axis), i2))]; 254 | } 255 | Table(const DataFrame & df, string s0, string s1, string s2, string s3) { 256 | DataFrameSelect df0(df,s0); 257 | DataFrameSelect df1(df,s1); 258 | DataFrameSelect df2(df,s2); 259 | DataFrameSelect df3(df,s3); 260 | for (int i=0; i data; 267 | }; 268 | 269 | template 270 | class Table { 271 | public: 272 | typedef std::tuple key_type; 273 | typedef Outcome mapped_type; 274 | typedef std::tuple< 275 | set >, 276 | set > 277 | > Axis; 278 | Table() {} 279 | void insert(I0 key0, I1 key1, mapped_type outcome) { 280 | key_type key = key_type(key0,key1); 281 | get<0>(axis).insert(key0); 282 | get<1>(axis).insert(key1); 283 | data[key] = outcome; 284 | } 285 | virtual Outcome operator()(I0 i0, I1 i1) { 286 | return data[key_type(set_lower_bound(get<0>(axis), i0), 287 | set_lower_bound(get<1>(axis), i1))]; 288 | } 289 | Table(const DataFrame & df, string s0, string s1, string s2) { 290 | DataFrameSelect df0(df,s0); 291 | DataFrameSelect df1(df,s1); 292 | DataFrameSelect df2(df,s2); 293 | for (int i=0; i data; 300 | }; 301 | 302 | template 303 | class Table { 304 | public: 305 | typedef set > Axis; 306 | Table() {} 307 | void insert(const key_type& key, const mapped_type& outcome) { 308 | axis.insert(key); 309 | data[key] = outcome; 310 | } 311 | virtual mapped_type operator()(key_type key) { 312 | return data[set_lower_bound(axis,key)]; 313 | } 314 | Table(const DataFrame & df, string s0, string s1) { 315 | DataFrameSelect df0(df,s0); 316 | DataFrameSelect df1(df,s1); 317 | for (int i=0; i data; 324 | }; 325 | 326 | #endif /* RCPP_TABLE_H */ 327 | -------------------------------------------------------------------------------- /inst/include/splines.h: -------------------------------------------------------------------------------- 1 | #ifndef SPLINES_H 2 | #define SPLINES_H 3 | 4 | #include 5 | 6 | namespace ssim { 7 | 8 | /* arma::mat qr_q(const arma::mat& X, double tol = 1E-12); */ 9 | 10 | class SplineBasis { 11 | public: 12 | int order, /* order of the spline */ 13 | ordm1, /* order - 1 (3 for cubic splines) */ 14 | nknots, /* number of knots */ 15 | curs, /* current position in knots vector */ 16 | boundary, /* must have knots[(curs) <= x < knots(curs+1) */ 17 | ncoef; /* number of coefficients */ 18 | /* except for the boundary case */ 19 | arma::vec ldel; /* differences from knots on the left */ 20 | arma::vec rdel; /* differences from knots on the right */ 21 | arma::vec knots; /* knot vector */ 22 | arma::vec coeff; /* coefficients */ 23 | arma::vec a; /* scratch array */ 24 | SplineBasis(int order = 4); 25 | SplineBasis(arma::vec knots, int order = 4); 26 | int set_cursor(double x); 27 | void diff_table(double x, int ndiff); 28 | double slow_evaluate(double x, int nder); 29 | /* fast evaluation of basis functions */ 30 | arma::vec basis_funcs(double x); 31 | arma::vec eval(double x, int ders=0); 32 | arma::mat basis(arma::vec x, int ders=0); 33 | }; 34 | 35 | class bs : public SplineBasis { 36 | public: 37 | arma::vec boundary_knots, interior_knots; 38 | int intercept, df; 39 | bs(); // default constructor 40 | bs(arma::vec boundary_knots, arma::vec interior_knots, int intercept = 0); 41 | arma::vec eval(double x, int ders=0); 42 | arma::mat basis(arma::vec x, int ders=0); 43 | }; 44 | 45 | class ns : public bs { 46 | public: 47 | arma::vec tl0, tl1, tr0, tr1; 48 | arma::mat q_matrix; 49 | int cure; 50 | ns(); // default constructor 51 | // ns(vec boundary_knots, vec interior_knots, int intercept=0) : 52 | // bs(boundary_knots, interior_knots, intercept) { 53 | // // calculate the Q matrix 54 | // mat const_basis = bs::basis(boundary_knots, 2); 55 | // mat qd = qr_q(const_basis.t()); 56 | // mat qsub(qd.n_rows, qd.n_cols-2); 57 | // for (size_t i=0; i 10 | // See AUTHORS for full details. 11 | // 12 | // SSim is free software: you can redistribute it and/or modify it under 13 | // the terms of the GNU General Public License as published by the Free 14 | // Software Foundation, either version 3 of the License, or (at your 15 | // option) any later version. 16 | // 17 | // SSim is distributed in the hope that it will be useful, 18 | // but WITHOUT ANY WARRANTY; without even the implied warranty of 19 | // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 20 | // GNU General Public License for more details. 21 | // 22 | // You should have received a copy of the GNU General Public License 23 | // along with SSim. If not, see . 24 | // 25 | #include 26 | 27 | #include 28 | #include 29 | #include 30 | 31 | namespace ssim { 32 | 33 | // these are the "private" static variables and types of the Sim class 34 | // 35 | static Time stop_time = INIT_TIME; 36 | static Time current_time = INIT_TIME; 37 | 38 | static ProcessId current_process = NULL_PROCESSID; 39 | 40 | static bool running = false; 41 | 42 | static SimErrorHandler * error_handler = 0; 43 | 44 | enum ActionType { 45 | A_Event, 46 | A_Init, 47 | A_Stop, 48 | A_Ignore 49 | }; 50 | 51 | struct Action { 52 | Time time; 53 | ActionType type; 54 | ProcessId pid; 55 | const Event * event; 56 | 57 | Action(Time t, ActionType at, ProcessId p, const Event * e = 0) throw() 58 | : time(t), type(at), pid(p), event(e) {}; 59 | 60 | bool operator < (const Action & a) const throw() { 61 | return time < a.time; 62 | } 63 | }; 64 | 65 | typedef heap a_table_t; 66 | 67 | static a_table_t actions; 68 | 69 | struct PDescr { 70 | Process * process; 71 | bool terminated; 72 | Time available_at; 73 | 74 | PDescr(Process * p) 75 | : process(p), terminated(false), available_at(INIT_TIME) {} 76 | }; 77 | 78 | typedef std::vector PsTable; 79 | static PsTable processes; 80 | 81 | void Rprint_actions() { 82 | Rprintf("\n["); 83 | for (a_table_t::iterator it = actions.begin(); it != actions.end(); it++) 84 | Rprintf("(time=%f,%s), ",it->time, it->event->str().c_str()); 85 | Rprintf("]\n"); 86 | } 87 | 88 | 89 | 90 | class SimImpl { 91 | public: 92 | static void schedule(Time t, ActionType i, ProcessId p, 93 | const Event * e = 0) throw() { 94 | if (e != 0) { 95 | ++(e->refcount); 96 | } 97 | actions.insert(Action(current_time + t, i, p, e )); 98 | } 99 | static void schedule_now(ActionType i, ProcessId p, 100 | const Event * e = 0) throw() { 101 | if (e != 0) { 102 | ++(e->refcount); 103 | } 104 | actions.insert(Action(current_time, i, p, e )); 105 | } 106 | }; 107 | 108 | ProcessId Sim::create_process(Process * p) throw() { 109 | processes.push_back(PDescr(p)); 110 | ProcessId newpid = processes.size() - 1; 111 | SimImpl::schedule_now(A_Init, newpid); 112 | return newpid; 113 | } 114 | 115 | void Sim::clear() throw() { 116 | running = false; 117 | current_time = INIT_TIME; 118 | current_process = NULL_PROCESSID; 119 | processes.clear(); 120 | if (error_handler) error_handler->clear(); 121 | for(a_table_t::iterator a = actions.begin(); a != actions.end(); ++a) { 122 | const Event * e = (*a).event; 123 | if (e != 0 && --(e->refcount) == 0) 124 | delete(e); 125 | } 126 | actions.clear(); 127 | } 128 | 129 | typedef a_table_t::iterator ForwardIterator; 130 | 131 | void Sim::ignore_event(EventPredicate pred) throw() { 132 | for (ForwardIterator it = actions.begin(); it != actions.end(); it++) { 133 | if ((*it).type == A_Event) { 134 | const Event * e = (*it).event; 135 | if (e != 0) { 136 | if(pred(e)) { 137 | (*it).type = A_Ignore; 138 | } 139 | } 140 | } 141 | } 142 | } 143 | 144 | 145 | // 146 | // this is the simulator main loop. 147 | // 148 | void Sim::run_simulation() { 149 | // 150 | // prevents anyone from re-entering the main loop. Note that this 151 | // isn't meant to be thread-safe, it works if some process calls 152 | // Sim::run_simulation() within their process_event() function. 153 | // 154 | static bool lock = false; 155 | if (lock) return; 156 | lock = true; 157 | running = true; 158 | 159 | // 160 | // while there is at least a scheduled action 161 | // 162 | while (running && !actions.empty()) { 163 | // 164 | // I'm purposely excluding any kind of checks in this version 165 | // of the simulator. 166 | // 167 | // I should say something like this: 168 | // assert(current_time <= (*a).first); 169 | // 170 | Action action = actions.pop_first(); 171 | if (action.type == A_Ignore) { 172 | if (action.event != 0) 173 | if (--(action.event->refcount) == 0) 174 | delete(action.event); 175 | } 176 | else { 177 | current_time = action.time; 178 | if (stop_time != INIT_TIME && current_time > stop_time) 179 | break; 180 | current_process = action.pid; 181 | // 182 | // right now I don't check if current_process is indeed a 183 | // valid process. Keep in mind that this is the heart of the 184 | // simulator main loop, therefore efficiency is crucial. 185 | // Perhaps I should check. This is somehow a design choice. 186 | // 187 | PDescr & pd = processes[current_process]; 188 | 189 | if (pd.terminated) { 190 | if (error_handler) 191 | error_handler->handle_terminated(current_process, 192 | action.event); 193 | } else if (current_time < pd.available_at) { 194 | if (error_handler) 195 | error_handler->handle_busy(current_process, action.event); 196 | } else { 197 | switch (action.type) { 198 | case A_Event: 199 | pd.process->process_event(action.event); 200 | break; 201 | case A_Init: 202 | pd.process->initialize(); 203 | break; 204 | case A_Stop: 205 | pd.process->stop(); 206 | // 207 | // here we must use processes[current_process] instead 208 | // of pd since pd.process->stop() might have added or 209 | // removed processes, and therefore resized the 210 | // processes vector, rendering pd invalid 211 | // 212 | processes[current_process].terminated = true; 213 | break; 214 | default: 215 | // 216 | // add paranoia checks/logging here? 217 | // 218 | break; 219 | } 220 | // here we must use processes[current_process] instead of 221 | // pd. Same reason as above. the "processes" vector might 222 | // have been modified and, as a consequence, resized. So, 223 | // pd may no longer be considered a valid reference. 224 | // 225 | processes[current_process].available_at = current_time; 226 | } 227 | 228 | if (action.event != 0) 229 | if (--(action.event->refcount) == 0) 230 | delete(action.event); 231 | } 232 | } 233 | lock = false; 234 | running = false; 235 | } 236 | 237 | void Sim::set_stop_time(Time t) throw() { 238 | stop_time = t; 239 | } 240 | 241 | void Sim::stop_process() throw() { 242 | SimImpl::schedule_now(A_Stop, current_process); 243 | } 244 | 245 | int Sim::stop_process(ProcessId pid) throw() { 246 | if (processes[pid].terminated) return -1; 247 | SimImpl::schedule_now(A_Stop, pid); 248 | return 0; 249 | } 250 | 251 | void Sim::stop_simulation() throw() { 252 | running = false; 253 | } 254 | 255 | void Sim::advance_delay(Time delay) throw() { 256 | if (!running) return; 257 | current_time += delay; 258 | } 259 | 260 | ProcessId Sim::this_process() throw() { 261 | return current_process; 262 | } 263 | 264 | Time Sim::clock() throw() { 265 | return current_time; 266 | } 267 | 268 | void Sim::self_signal_event(const Event * e) throw() { 269 | SimImpl::schedule_now(A_Event, current_process, e); 270 | } 271 | 272 | void Sim::self_signal_event(const Event * e, Time d) throw() { 273 | SimImpl::schedule(d, A_Event, current_process, e); 274 | } 275 | 276 | void Sim::signal_event(ProcessId pid, const Event * e) throw() { 277 | SimImpl::schedule_now(A_Event, pid, e); 278 | } 279 | 280 | void Sim::signal_event(ProcessId pid, const Event * e, Time d) throw() { 281 | SimImpl::schedule(d, A_Event, pid, e); 282 | } 283 | 284 | void Sim::set_error_handler(SimErrorHandler * eh) throw() { 285 | error_handler = eh; 286 | } 287 | 288 | ProcessId ProcessWithPId::activate() throw() { 289 | if (process_id == NULL_PROCESSID) { 290 | return process_id = Sim::create_process(this); 291 | } else { 292 | return NULL_PROCESSID; 293 | } 294 | } 295 | 296 | ProcessWithPId::ProcessWithPId() throw(): process_id(NULL_PROCESSID) {} 297 | 298 | ProcessId ProcessWithPId::pid() const throw() { 299 | return process_id; 300 | } 301 | 302 | } // namespace ssim 303 | -------------------------------------------------------------------------------- /inst/lib/keeplib.txt: -------------------------------------------------------------------------------- 1 | Keep this folder 2 | -------------------------------------------------------------------------------- /man/Classes.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/pqueue.R, R/rcpp_hello_world.R 3 | \docType{class} 4 | \name{pqueue} 5 | \alias{pqueue} 6 | \alias{PQueueRef-class} 7 | \alias{PQueueRef} 8 | \alias{EventQueue-class} 9 | \alias{EventQueue} 10 | \alias{BaseDiscreteEventSimulation-class} 11 | \alias{BaseDiscreteEventSimulation} 12 | \title{S3 priority queue implementation using C++} 13 | \usage{ 14 | pqueue(lower = TRUE) 15 | } 16 | \arguments{ 17 | \item{lower}{boolean to determine whether to give priority to lower values (default=TRUE) 18 | or higher values} 19 | } 20 | \value{ 21 | a list with 22 | \describe{ 23 | \item{push}{function with arguments priority (numeric) and event (SEXP). Pushes an event with a given priority} 24 | \item{pop}{function to return a list with a priority (numeric) and an event (SEXP). This pops the first active event.} 25 | \item{cancel}{function that takes a predicate (or R function) for a given event and returns a logical that indicates whether to cancel that event or not. This may cancel some events that will no longer be popped.} 26 | \item{empty}{function that returns whether the priority queue is empty (or has no active events).} 27 | \item{clear}{function to clear the priority queue.} 28 | \item{ptr}{XPtr value} 29 | } 30 | } 31 | \description{ 32 | This provides a priority queue that is sorted by the priority and entry order. The priority is assumed to be numeric. The events can be of any type. As an extension, events can be cancelled if they satisfy a certain predicate. Note that the inactive events are not removed, rather they are marked as cancelled and will not be available to be popped. 33 | 34 | Based on C++ code. See also the S3 implementation \code{pqueue}. 35 | 36 | This event queue is simple and useful for pedagogic purposes. 37 | 38 | Inherit from this class to represent a discrete event simulation. The 39 | API is similar to that for Omnet++, where an \code{init} method sets up 40 | the initial events using the \code{scheduleAt(time,event)} method, the 41 | messages are handled using the \code{handleMessage(event)} method, the 42 | simulation is run using the \code{run} method, and the \code{final} 43 | method is called at the end of the simulation. 44 | } 45 | \details{ 46 | The algorithm for pushing values into the queue is computationally 47 | very simple: simply rank the times using \code{order()} and re-order 48 | times and events. This approach is probably of acceptable performance 49 | for smaller queue. A more computationally efficient approach for 50 | pushing into larger queues would be to use a binary search (e.g. using 51 | \code{findInterval()}). 52 | 53 | For faster alternatives, see \code{pqueue} and \code{PQueueRef}. 54 | } 55 | \section{Fields}{ 56 | 57 | \describe{ 58 | \item{\code{ptr}}{External pointer to the C++ class} 59 | 60 | \item{\code{times}}{vector of times} 61 | 62 | \item{\code{events}}{list of events} 63 | 64 | \item{\code{times}}{vector of times} 65 | 66 | \item{\code{events}}{list of events} 67 | }} 68 | 69 | \section{Methods}{ 70 | 71 | \describe{ 72 | \item{\code{cancel(predicate)}}{Method to cancel events that satisfy some predicate} 73 | 74 | \item{\code{clear()}}{Method to clear the event queue} 75 | 76 | \item{\code{empty()}}{Method to check whether there are no events in the queue} 77 | 78 | \item{\code{initialize(lower = TRUE)}}{Method to initialize the object. lower argument indicates whether lowest priority or highest priority} 79 | 80 | \item{\code{pop()}}{Method to remove the head of the event queue and return its value} 81 | 82 | \item{\code{push(priority, event)}}{Method to push an event with a given priority} 83 | 84 | \item{\code{cancel(predicate, ...)}}{Method to remove events that satisfy some predicate} 85 | 86 | \item{\code{clear()}}{Method to clear the event queue} 87 | 88 | \item{\code{empty()}}{Method to check whether there are no events in the queue} 89 | 90 | \item{\code{pop()}}{Method to remove the head of the event queue and return its value} 91 | 92 | \item{\code{push(time, event)}}{Method to insert the event at the given time} 93 | 94 | \item{\code{final()}}{Method for finalising the simulation} 95 | 96 | \item{\code{handleMessage(event)}}{Virtual method to handle the messages as they arrive} 97 | 98 | \item{\code{init()}}{Virtual method to initialise the event queue and attributes} 99 | 100 | \item{\code{reset(startTime = 0)}}{Method to reset the event queue} 101 | 102 | \item{\code{run(startTime = 0)}}{Method to run the simulation} 103 | 104 | \item{\code{scheduleAt(time, event)}}{Method that adds attributes for the event time and the sendingTime, and then insert the event into the event queue} 105 | }} 106 | 107 | \examples{ 108 | pq = pqueue() 109 | pq$push(3,"Clear drains") 110 | pq$push(4, "Feed cat") 111 | pq$push(5, "Make tea") 112 | pq$push(1, "Solve RC tasks") 113 | pq$push(2, "Tax return") 114 | while(!pq$empty()) 115 | print(pq$pop()) 116 | 117 | pq = new("PQueueRef") 118 | pq$push(3,"Clear drains") 119 | pq$push(4, "Feed cat") 120 | pq$push(5, "Make tea") 121 | pq$push(1, "Solve RC tasks") 122 | pq$push(2, "Tax return") 123 | while(!pq$empty()) 124 | print(pq$pop()) 125 | 126 | pq = new("EventQueue") 127 | pq$push(3,"Clear drains") 128 | pq$push(4, "Feed cat") 129 | pq$push(5, "Make tea") 130 | pq$push(1, "Solve RC tasks") 131 | pq$push(2, "Tax return") 132 | while(!pq$empty()) 133 | print(pq$pop()) 134 | 135 | DES = setRefClass("DES", 136 | contains = "BaseDiscreteEventSimulation", 137 | methods=list( 138 | init=function() { 139 | scheduleAt(3,"Clear drains") 140 | scheduleAt(4, "Feed cat") 141 | scheduleAt(5, "Make tea") 142 | scheduleAt(1, "Solve RC tasks") 143 | scheduleAt(2, "Tax return") 144 | }, 145 | handleMessage=function(event) print(event))) 146 | 147 | des = new("DES") 148 | des$run() 149 | \dontrun{ 150 | testRsimulation1 <- function() { 151 | ## A simple example 152 | Simulation <- 153 | setRefClass("Simulation", 154 | contains = "BaseDiscreteEventSimulation") 155 | Simulation$methods( 156 | init = function() { 157 | scheduleAt(rweibull(1,8,85), "Death due to other causes") 158 | scheduleAt(rweibull(1,3,90), "Cancer diagnosis") 159 | }, 160 | handleMessage = function(event) { 161 | if (event \%in\% c("Death due to other causes", "Cancer death")) { 162 | clear() 163 | print(event) 164 | } 165 | else if (event == "Cancer diagnosis") { 166 | if (runif(1) < 0.5) 167 | scheduleAt(now() + rweibull(1,2,10), "Cancer death") 168 | print(event) 169 | } 170 | }) 171 | Simulation$new()$run() 172 | } 173 | 174 | ## An extension with individual life histories 175 | testRsimulation2 <- function(n=100) { 176 | Simulation <- 177 | setRefClass("Simulation", 178 | contains = "BaseDiscreteEventSimulation", 179 | fields = list(state = "character", report = "data.frame")) 180 | Simulation$methods( 181 | init = function() { 182 | report <<- data.frame() 183 | state <<- "Healthy" 184 | scheduleAt(rweibull(1,8,85), "Death due to other causes") 185 | scheduleAt(rweibull(1,3,90), "Cancer diagnosis") 186 | }, 187 | handleMessage = function(event) { 188 | report <<- rbind(report, data.frame(state = state, 189 | begin = attr(event,"sendingTime"), 190 | end = currentTime, 191 | event = event, 192 | stringsAsFactors = FALSE)) 193 | if (event \%in\% c("Death due to other causes", "Cancer death")) { 194 | clear() 195 | } 196 | else if (event == "Cancer diagnosis") { 197 | state <<- "Cancer" 198 | if (runif(1) < 0.5) 199 | scheduleAt(now() + rweibull(1,2,10), "Cancer death") 200 | } 201 | }, 202 | final = function() report) 203 | sim <- Simulation$new() 204 | do.call("rbind", lapply(1:n, function(id) data.frame(id=id,sim$run()))) 205 | } 206 | 207 | ## reversible illness-death model 208 | testRsimulation3 <- function(n=100) { 209 | Simulation <- 210 | setRefClass("Simulation", 211 | contains = "BaseDiscreteEventSimulation", 212 | fields = list(state = "character", everCancer = "logical", 213 | report = "data.frame")) 214 | Simulation$methods( 215 | init = function() { 216 | report <<- data.frame() 217 | state <<- "Healthy" 218 | everCancer <<- FALSE 219 | scheduleAt(rweibull(1,8,85), "Death due to other causes") 220 | scheduleAt(rweibull(1,3,90), "Cancer diagnosis") 221 | }, 222 | handleMessage = function(event) { 223 | report <<- rbind(report, data.frame(state = state, 224 | everCancer = everCancer, 225 | begin = attr(event,"sendingTime"), 226 | end = currentTime, 227 | event = event, 228 | stringsAsFactors = FALSE)) 229 | if (event \%in\% c("Death due to other causes", "Cancer death")) { 230 | clear() 231 | } 232 | else if (event == "Cancer diagnosis") { 233 | state <<- "Cancer" 234 | everCancer <<- TRUE 235 | if (runif(1) < 0.5) 236 | scheduleAt(now() + rweibull(1,2,10), "Cancer death") 237 | scheduleAt(now() + 10, "Recovery") 238 | } 239 | else if (event == "Recovery") { 240 | state <<- "Healthy" 241 | scheduleAt(now() + rexp(1,10), "Cancer diagnosis") 242 | } 243 | }, 244 | final = function() report) 245 | sim <- Simulation$new() 246 | do.call("rbind", lapply(1:n, function(id) data.frame(id=id,sim$run()))) 247 | } 248 | 249 | ## cancer screening 250 | testRsimulation4 <- function(n=1) { 251 | Simulation <- 252 | setRefClass("Simulation", 253 | contains = "BaseDiscreteEventSimulation", 254 | fields = list(state = "character", report = "data.frame")) 255 | Simulation$methods( 256 | init = function() { 257 | report <<- data.frame() 258 | state <<- "Healthy" 259 | scheduleAt(rweibull(1,8,85), "Death due to other causes") 260 | scheduleAt(rweibull(1,3,90), "Cancer onset") 261 | scheduleAt(50,"Screening") 262 | }, 263 | handleMessage = function(event) { 264 | report <<- rbind(report, data.frame(state = state, 265 | begin = attr(event,"sendingTime"), 266 | end = currentTime, 267 | event = event, 268 | stringsAsFactors = FALSE)) 269 | if (event \%in\% c("Death due to other causes", "Cancer death")) { 270 | clear() 271 | } 272 | else if (event == "Cancer onset") { 273 | state <<- event 274 | dx <- now() + rweibull(1,2,10) 275 | scheduleAt(dx, "Clinical cancer diagnosis") 276 | scheduleAt(dx + rweibull(1,1,10), "Cancer death") 277 | scheduleAt(now() + rweibull(1,1,10), "Metastatic cancer") 278 | } 279 | else if (event == "Metastatic cancer") { 280 | state <<- event 281 | cancel(function(event) event \%in\% 282 | c("Clinical cancer diagnosis","Cancer death")) # competing events 283 | scheduleAt(now() + rweibull(1,2,5), "Cancer death") 284 | } 285 | else if (event == "Clinical cancer diagnosis") { 286 | state <<- event 287 | cancel(function(event) event == "Metastatic cancer") 288 | } 289 | else if (event == "Screening") { 290 | switch(state, 291 | "Cancer onset" = { 292 | state <<- "Screen-detected cancer diagnosis" 293 | cancel(function(event) event \%in\% 294 | c("Clinical cancer diagnosis","Metastatic cancer")) 295 | }, 296 | "Metastatic cancer" = {}, # ignore 297 | "Clincal cancer diagnosis" = {}, # ignore 298 | "Healthy" = { 299 | if (now()<=68) scheduleAt(now()+2, "Screening") 300 | }) 301 | } 302 | else stop(event) 303 | }, 304 | final = function() report) 305 | sim <- Simulation$new() 306 | do.call("rbind", lapply(1:n, function(id) data.frame(id=id,sim$run()))) 307 | } 308 | 309 | ## ticking bomb - toy example 310 | testRsimulation5 <- function(n=1) { 311 | Simulation <- 312 | setRefClass("Simulation", 313 | contains = "BaseDiscreteEventSimulation", 314 | fields = list(report = "data.frame")) 315 | Simulation$methods( 316 | init = function() { 317 | report <<- data.frame() 318 | scheduleAt(rexp(1,1), "tick") 319 | if (runif(1)<0.1) 320 | scheduleAt(rexp(1,1), "explosion") 321 | }, 322 | handleMessage = function(event) { 323 | report <<- rbind(report, data.frame(begin = attr(event,"sendingTime"), 324 | end = currentTime, 325 | event = event, 326 | stringsAsFactors = FALSE)) 327 | if (event == "explosion") 328 | clear() 329 | else { 330 | clear() # queue 331 | if (event == "tick") scheduleAt(currentTime+rexp(1,1), "tock") 332 | else scheduleAt(currentTime+rexp(1,1), "tick") 333 | if (runif(1)<0.1) 334 | scheduleAt(currentTime+rexp(1,1), "explosion") 335 | } 336 | }, 337 | final = function() report) 338 | sim <- Simulation$new() 339 | do.call("rbind", lapply(1:n, function(id) data.frame(id=id,sim$run()))) 340 | } 341 | } 342 | 343 | } 344 | -------------------------------------------------------------------------------- /man/Data.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/rcpp_hello_world.R 3 | \docType{data} 4 | \name{fhcrcData} 5 | \alias{fhcrcData} 6 | \title{Old data used in the prostata model} 7 | \format{ 8 | An object of class \code{list} of length 10. 9 | } 10 | \usage{ 11 | fhcrcData 12 | } 13 | \description{ 14 | Old data used in the prostata model 15 | } 16 | \keyword{datasets} 17 | -------------------------------------------------------------------------------- /man/Examples.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/calibSim.R, R/rcpp_hello_world.R 3 | \name{callCalibrationPerson} 4 | \alias{callCalibrationPerson} 5 | \alias{callPersonSimulation} 6 | \alias{callSimplePerson} 7 | \alias{callSimplePerson2} 8 | \alias{callIllnessDeath} 9 | \title{call CalibrationPerson example} 10 | \usage{ 11 | callCalibrationPerson( 12 | seed = 12345, 13 | n = 500, 14 | runpar = c(4, 0.5, 0.05, 10, 3, 0.5), 15 | mc.cores = 1 16 | ) 17 | 18 | callPersonSimulation(n = 20, seed = rep(12345, 6)) 19 | 20 | callSimplePerson(n = 10) 21 | 22 | callSimplePerson2(n = 10) 23 | 24 | callIllnessDeath(n = 10L, cure = 0.1, zsd = 0) 25 | } 26 | \arguments{ 27 | \item{seed}{random number seed} 28 | 29 | \item{n}{number of simulations (default=10)} 30 | 31 | \item{runpar}{parameters} 32 | 33 | \item{mc.cores}{number of cores} 34 | 35 | \item{cure}{probability of cure} 36 | 37 | \item{zsd}{frailty standard deviation} 38 | } 39 | \value{ 40 | data-frame 41 | 42 | data-frame 43 | 44 | data-frame 45 | 46 | data-frame 47 | 48 | data-frame 49 | } 50 | \description{ 51 | Example that uses the RngStream random number generator 52 | 53 | Example that uses the Mersenne-Twister random number generator 54 | 55 | Example that uses the Mersenne-Twister random number generator 56 | 57 | Example that uses the Mersenne-Twister random number generator 58 | } 59 | -------------------------------------------------------------------------------- /man/Internal.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/pqueue.R, R/rcpp_hello_world.R 3 | \name{pqueue__new} 4 | \alias{pqueue__new} 5 | \alias{pqueue__push} 6 | \alias{pqueue__pop} 7 | \alias{pqueue__cancel} 8 | \alias{pqueue__empty} 9 | \alias{pqueue__clear} 10 | \alias{callCalibrationSimulation} 11 | \alias{r_create_current_stream} 12 | \alias{r_remove_current_stream} 13 | \alias{r_set_user_random_seed} 14 | \alias{r_rng_advance_substream} 15 | \alias{r_next_rng_substream} 16 | \alias{r_get_user_random_seed} 17 | \title{C++ function} 18 | \value{ 19 | data-frame 20 | 21 | No return value, called for side effects 22 | 23 | No return value, called for side effects 24 | 25 | No return value, called for side effects 26 | 27 | No return value, called for side effects 28 | 29 | No return value, called for side effects 30 | 31 | No return value, called for side effects 32 | } 33 | \description{ 34 | C++ function 35 | 36 | C++ function 37 | 38 | C++ function 39 | 40 | C++ function 41 | 42 | C++ function 43 | 44 | C++ function 45 | 46 | C++ function 47 | 48 | C++ function 49 | 50 | C++ function 51 | 52 | C++ function 53 | 54 | C++ function 55 | 56 | C++ function 57 | 58 | C++ function 59 | } 60 | -------------------------------------------------------------------------------- /man/RNGStream.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/rcpp_hello_world.R 3 | \name{RNGStream} 4 | \alias{RNGStream} 5 | \alias{RNGStream-class} 6 | \alias{with.RNGStream} 7 | \title{S3 class to work with RngStream objects} 8 | \usage{ 9 | RNGStream(nextStream = TRUE, iseed = NULL) 10 | 11 | \method{with}{RNGStream}(data, expr, ...) 12 | } 13 | \arguments{ 14 | \item{nextStream}{whether to move to the next stream (default=TRUE)} 15 | 16 | \item{iseed}{set seed after changing RNG (otherwise keep the current seed)} 17 | 18 | \item{data}{object of type RNGStream} 19 | 20 | \item{expr}{expression using the RNGStream} 21 | 22 | \item{...}{other arguments passed to eval()} 23 | } 24 | \value{ 25 | list of class \code{RNGStream} with components: 26 | \describe{ 27 | \item{resetRNGkind}{function to reset to the previous RNG and seed} 28 | \item{seed}{function to return the current seed} 29 | \item{open}{function to use the current seed} 30 | \item{close}{function to make the current seed equal to .Random.seed} 31 | \item{resetStream}{function to move back to start of stream} 32 | \item{resetSubStream}{function to move back to start of sub-stream} 33 | \item{nextSubStream}{function to move to next sub-stream} 34 | \item{nextStream}{function to move to next stream} 35 | } 36 | 37 | the value from the expression 38 | } 39 | \description{ 40 | S3 class to work with RngStream objects 41 | 42 | Use RNGStream as an old class 43 | 44 | With method for RNGStream S3 class 45 | } 46 | \examples{ 47 | ## set up one stream 48 | s1 <- RNGStream() 49 | s1$open() 50 | rnorm(1) 51 | s1$nextSubStream() 52 | rnorm(1) 53 | ## reset the stream 54 | s1$resetStream() 55 | rnorm(2) 56 | s1$nextSubStream() 57 | rnorm(2) 58 | 59 | ## now do with two streams 60 | s1$resetStream() 61 | s2 <- RNGStream() 62 | with(s1,rnorm(1)) 63 | with(s2,rnorm(1)) 64 | s1$nextSubStream() 65 | with(s1,rnorm(1)) 66 | ## now reset the streams and take two samples each time 67 | s1$resetStream() 68 | s2$resetStream() 69 | with(s1,rnorm(2)) 70 | with(s2,rnorm(2)) 71 | s1$nextSubStream() 72 | with(s1,rnorm(2)) 73 | } 74 | -------------------------------------------------------------------------------- /man/SummaryReport.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/SummaryReport.R 3 | \name{summary.SummaryReport} 4 | \alias{summary.SummaryReport} 5 | \alias{print.summary.SummaryReport} 6 | \alias{print.SummaryReport} 7 | \alias{rbind.SummaryReport} 8 | \alias{ascii.SummaryReport} 9 | \alias{ICER.SummaryReport} 10 | \alias{ascii.ICER.SummaryReport} 11 | \title{summary method for a SummaryReport object} 12 | \usage{ 13 | \method{summary}{SummaryReport}(object, ...) 14 | 15 | \method{print}{summary.SummaryReport}(x, ...) 16 | 17 | \method{print}{SummaryReport}(x, ...) 18 | 19 | \method{rbind}{SummaryReport}(...) 20 | 21 | \method{ascii}{SummaryReport}( 22 | x, 23 | include.rownames = FALSE, 24 | include.colnames = TRUE, 25 | header = TRUE, 26 | digits = c(0, 3, 2, 2, 4, 4), 27 | ... 28 | ) 29 | 30 | \method{ICER}{SummaryReport}(object1, object2, ...) 31 | 32 | \method{ascii}{ICER.SummaryReport}( 33 | x, 34 | include.rownames = TRUE, 35 | include.colnames = TRUE, 36 | header = TRUE, 37 | digits = c(1, 1, 3, 3, 1, 1, 3, 3, 1), 38 | rownames = c("Reference", "Treatment"), 39 | colnames = c("Costs", "(se)", "QALYs", "(se)", "Costs", "(se)", "QALYs", "(se)", 40 | "ICER"), 41 | tgroup = c("Total", "Incremental"), 42 | n.tgroup = c(4, 5), 43 | ... 44 | ) 45 | } 46 | \arguments{ 47 | \item{object}{SummaryReport object} 48 | 49 | \item{...}{other arguments to pass to ascii} 50 | 51 | \item{x}{an ICER.SummaryReport object} 52 | 53 | \item{include.rownames}{logical for whether to include rownames (default=FALSE)} 54 | 55 | \item{include.colnames}{logical for whether to include colnames (default=TRUE)} 56 | 57 | \item{header}{logical for whether to include the header (default=TRUE)} 58 | 59 | \item{digits}{vector of the number of digits to use for each column} 60 | 61 | \item{object1}{SummaryReport object (reference)} 62 | 63 | \item{object2}{SummaryReport object} 64 | 65 | \item{rownames}{rownames for output} 66 | 67 | \item{colnames}{colnames for output} 68 | 69 | \item{tgroup}{tgroup arg passed to ascii} 70 | 71 | \item{n.tgroup}{arg passed to ascii} 72 | } 73 | \value{ 74 | a list of class summary.SummaryReport with components: 75 | \describe{ 76 | \item{n}{Number of simulations} 77 | \item{indivip}{boolean with whether individual values were retained} 78 | \item{utilityDiscountRate}{discount rate for utilities/QALYs} 79 | \item{costDiscountRate}{discount rate for costs} 80 | \item{QALE}{Quality-adjusted life expectancy (discounted)} 81 | \item{LE}{Life expectancy (not discounted)} 82 | \item{ECosts}{Life-time expected costs (discounted)} 83 | \item{se.QALE}{standard error for QALE} 84 | \item{se.Ecosts}{standard error Ecosts} 85 | } 86 | 87 | a SummaryReport object 88 | 89 | ascii object 90 | 91 | a list of type ICER.SummaryReport with components: 92 | \describe{ 93 | \item{n}{number of simulations} 94 | \item{utilityDiscountRate}{Discount rate for the utilities/QALE} 95 | \item{costDiscountRate}{Discount rate for the costs} 96 | \item{s1}{summary for object1} 97 | \item{s2}{summary for object2} 98 | \item{dQALE}{QALE for object2 minus QALE for object1} 99 | \item{dCosts}{Costs for object2 minus costs for object1} 100 | \item{ICER}{change of costs divided by change in QALEs} 101 | \item{se.dQALE}{standard error for dQALE} 102 | \item{se.dCosts}{standard error for dCosts} 103 | } 104 | 105 | ascii object 106 | } 107 | \description{ 108 | At present, this passes the object to summary and then prints 109 | } 110 | -------------------------------------------------------------------------------- /man/Utilities.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/plugin.R, R/rcpp_hello_world.R, R/zzz.R 3 | \name{.microsimulationLdFlags} 4 | \alias{.microsimulationLdFlags} 5 | \alias{inlineCxxPlugin} 6 | \alias{LdFlags} 7 | \alias{microsimulation.init} 8 | \alias{microsimulation.exit} 9 | \alias{unsigned} 10 | \alias{signed} 11 | \alias{rnormPos} 12 | \alias{set.user.Random.seed} 13 | \alias{advance.substream} 14 | \alias{next.user.Random.substream} 15 | \alias{user.Random.seed} 16 | \alias{enum} 17 | \alias{enum<-} 18 | \alias{RNGstate} 19 | \alias{frontier} 20 | \alias{lines_frontier} 21 | \alias{discountedPoint} 22 | \alias{ICER} 23 | \alias{.onLoad} 24 | \alias{.onUnload} 25 | \title{Internal function} 26 | \usage{ 27 | .microsimulationLdFlags() 28 | 29 | inlineCxxPlugin(...) 30 | 31 | LdFlags() 32 | 33 | microsimulation.init(PACKAGE = "microsimulation") 34 | 35 | microsimulation.exit(PACKAGE = "microsimulation") 36 | 37 | unsigned(seed) 38 | 39 | signed(seed) 40 | 41 | rnormPos(n, mean = 0, sd = 1, lbound = 0) 42 | 43 | set.user.Random.seed(seed, PACKAGE = "microsimulation") 44 | 45 | advance.substream(seed, n, PACKAGE = "microsimulation") 46 | 47 | next.user.Random.substream(PACKAGE = "microsimulation") 48 | 49 | user.Random.seed(PACKAGE = "microsimulation") 50 | 51 | enum(obj, labels, start = 0) 52 | 53 | enum(obj) <- value 54 | 55 | RNGstate() 56 | 57 | frontier(x, y, concave = TRUE, convex = NULL) 58 | 59 | lines_frontier(x, y, pch = 19, type = "b", ...) 60 | 61 | discountedPoint(y, time, dr) 62 | 63 | ICER(object1, object2, ...) 64 | 65 | .onLoad(lib, pkg) 66 | 67 | .onUnload(libpath) 68 | } 69 | \arguments{ 70 | \item{...}{other arguments} 71 | 72 | \item{PACKAGE}{package for the seed} 73 | 74 | \item{seed}{random number seed} 75 | 76 | \item{n}{number of sub-streams to advance} 77 | 78 | \item{mean}{numeric for the mean of the (untruncated) normal distribution (default=0)} 79 | 80 | \item{sd}{numeric for the sd of the (untruncated) normal distribution (default=1)} 81 | 82 | \item{lbound}{numeric for the lower bound (default=0)} 83 | 84 | \item{obj}{integer or logical for factor levels} 85 | 86 | \item{labels}{labels for the factor levels} 87 | 88 | \item{start}{first value of the levels} 89 | 90 | \item{value}{labels for the factor levels} 91 | 92 | \item{x}{vector of x coordinates} 93 | 94 | \item{y}{the undiscounted value} 95 | 96 | \item{concave}{logical for whether to calculate a concave frontier (default=TRUE)} 97 | 98 | \item{convex}{logical for whether to calculate a convex frontier (default=NULL)} 99 | 100 | \item{pch}{type of pch for the plotted symbols (default=19)} 101 | 102 | \item{type}{join type (default="b")} 103 | 104 | \item{time}{the time of the event} 105 | 106 | \item{dr}{discount rate, expressed as a percentage} 107 | 108 | \item{object1}{first object} 109 | 110 | \item{object2}{second object} 111 | 112 | \item{lib}{library string} 113 | 114 | \item{pkg}{package string} 115 | 116 | \item{libpath}{library path string} 117 | } 118 | \value{ 119 | No return value, called for side effects 120 | 121 | No return value, called for side effects 122 | 123 | No return value, called for side effects 124 | 125 | unsigned seed 126 | 127 | signed seed 128 | 129 | numeric vector 130 | 131 | invisibly returns the new seed 132 | 133 | the advanced seed 134 | 135 | invisibly returns TRUE -- called for side effect 136 | 137 | random seed 138 | 139 | the new factor 140 | 141 | update the factor 142 | 143 | a list with oldseed (the old value of .Random.seed), and reset(), which resets .Random.seed 144 | 145 | a list with components x and y for the frontier 146 | 147 | No return value, called for side effects 148 | 149 | numeric vector 150 | } 151 | \description{ 152 | Is this function needed? We could define the current stream in open code. 153 | 154 | Again, is this needed? 155 | } 156 | -------------------------------------------------------------------------------- /man/discountedInterval.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/rcpp_hello_world.R 3 | \name{discountedInterval} 4 | \alias{discountedInterval} 5 | \title{Integrate a discounted value} 6 | \usage{ 7 | discountedInterval(y, start, finish, dr) 8 | } 9 | \arguments{ 10 | \item{y}{the undiscounted value} 11 | 12 | \item{start}{the start time} 13 | 14 | \item{finish}{the finish time} 15 | 16 | \item{dr}{discount rate, expressed as a percentage} 17 | } 18 | \value{ 19 | numeric discounted value 20 | } 21 | \description{ 22 | Integrate a discounted value 23 | } 24 | -------------------------------------------------------------------------------- /man/microsimulation-package.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/rcpp_hello_world.R 3 | \docType{package} 4 | \name{microsimulation-package} 5 | \alias{microsimulation-package} 6 | \alias{microsimulation} 7 | \title{microsimulation} 8 | \description{ 9 | Discrete event simulations in both R and C++ with Tools for Cost-Effectiveness Analysis. 10 | } 11 | \section{Introduction}{ 12 | 13 | 14 | Discrete event simulations in both R and C++ with Tools for Cost-Effectiveness Analysis. 15 | } 16 | 17 | \references{ 18 | \url{https://github.com/mclements/microsimulation} 19 | } 20 | \seealso{ 21 | \code{\link[Rcpp]{sourceCpp}} 22 | } 23 | \author{ 24 | Mark Clements \email{mark.clements@ki.se} 25 | } 26 | -------------------------------------------------------------------------------- /man/simulate.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/simulate.R 3 | \name{simulate.survreg} 4 | \alias{simulate.survreg} 5 | \title{Simulate event times from a survreg object} 6 | \usage{ 7 | \method{simulate}{survreg}(object, nsim = 1, seed = NULL, newdata, t0 = NULL, ...) 8 | } 9 | \arguments{ 10 | \item{object}{survreg object} 11 | 12 | \item{nsim}{number of simulations per row in newdata} 13 | 14 | \item{seed}{random number seed} 15 | 16 | \item{newdata}{data-frame for defining the covariates for the simulations. Required.} 17 | 18 | \item{t0}{delayed entry time. Defaults to NULL (which assumes that t0=0)} 19 | 20 | \item{...}{other arguments (not currently used)} 21 | } 22 | \value{ 23 | vector of event times with nsim repeats per row in newdata 24 | } 25 | \description{ 26 | Simulate event times from a survreg object 27 | } 28 | \examples{ 29 | library(survival) 30 | fit <- survreg(Surv(time, status) ~ ph.ecog + age + sex + strata(sex), 31 | data = lung) 32 | nd = transform(expand.grid(ph.ecog=0:1, sex=1:2), age=60) 33 | simulate(fit, seed=1002, newdata=nd) 34 | simulate(fit, seed=1002, newdata=nd, t0=500) 35 | } 36 | -------------------------------------------------------------------------------- /microsimulation.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | BuildType: Package 16 | PackageUseDevtools: Yes 17 | PackageInstallArgs: --no-multiarch --with-keep.source --preclean 18 | -------------------------------------------------------------------------------- /src/Makevars: -------------------------------------------------------------------------------- 1 | PKG_LIBS = `$(R_HOME)/bin/Rscript -e "Rcpp:::LdFlags()"` $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) 2 | PKG_CXXFLAGS = -I. -I../inst/include 3 | PKG_CFLAGS = -I. 4 | 5 | OBJECTS = microsimulation.o person-r.o calibperson-r.o simple-example.o simple-example2.o illness-death.o ssim.o RngStream.o pqueue.o init.o splines.o gsm.o 6 | 7 | all: $(SHLIB) staticLibrary 8 | 9 | staticLibrary: $(SHLIB) 10 | $(AR) cr ../inst/lib/libmicrosimulation.a $(OBJECTS) 11 | $(RANLIB) ../inst/lib/libmicrosimulation.a 12 | -------------------------------------------------------------------------------- /src/Makevars.win: -------------------------------------------------------------------------------- 1 | PKG_LIBS = $(shell "${R_HOME}/bin${R_ARCH_BIN}/Rscript.exe" -e "Rcpp:::LdFlags()") $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) 2 | PKG_CXXFLAGS = -I. -I../inst/include 3 | PKG_CFLAGS = -I. 4 | 5 | OBJECTS = microsimulation.o person-r.o calibperson-r.o simple-example.o simple-example2.o illness-death.o ssim.o RngStream.o pqueue.o init.o splines.o gsm.o 6 | 7 | all: $(SHLIB) staticLibrary 8 | 9 | staticLibrary: $(SHLIB) 10 | $(AR) cr ../inst/lib/libmicrosimulation.a $(OBJECTS) 11 | $(RANLIB) ../inst/lib/libmicrosimulation.a 12 | -------------------------------------------------------------------------------- /src/archive/person-r-20121231.cc: -------------------------------------------------------------------------------- 1 | /** 2 | * @file 3 | * @author Mark Clements 4 | * @version 1.0 5 | * 6 | * @section LICENSE 7 | * 8 | * This program is free software; you can redistribute it and/or 9 | * modify it under the terms of the GNU General Public License as 10 | * published by the Free Software Foundation; either version 2 of 11 | * the License, or (at your option) any later version. 12 | * 13 | * This program is distributed in the hope that it will be useful, but 14 | * WITHOUT ANY WARRANTY; without even the implied warranty of 15 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 16 | * General Public License for more details at 17 | * http://www.gnu.org/copyleft/gpl.html 18 | * 19 | * @section DESCRIPTION 20 | 21 | Microsimulation of prostate cancer. 22 | 23 | TODO 24 | * other causes of death - incorporate rates 25 | * other transitions 26 | * age-specific reporting of state probabilities 27 | */ 28 | 29 | #include "event-r.h" 30 | #include 31 | 32 | //double inf = 1.0 / 0.0; 33 | 34 | using namespace std; 35 | 36 | //! enum for type of Gleason score 37 | enum gleason_t {nogleason,gleasonLt7,gleason7,gleasonGt7}; 38 | 39 | //! enum of type of disease stage 40 | enum stage_t {Healthy,Localised,DxLocalised,LocallyAdvanced,DxLocallyAdvanced, 41 | Metastatic,DxMetastatic,Death}; 42 | 43 | //! Class to simulate a person 44 | class Person : public cProcess 45 | { 46 | public: 47 | gleason_t gleason; 48 | stage_t stage; 49 | bool dx; 50 | // static members (for statistics) 51 | static int popSize, ///< size of the population 52 | nCancer, ///< number of cancers 53 | nLocalisedCancer, ///< number of localised cancers diagnosed 54 | nLocallyAdvancedCancer, ///< number of locally advanced cancers diagnosed 55 | nMetastaticCancer; ///< number of metastatic cancers diagnosed 56 | static Means personTime; 57 | static void resetPopulation (); 58 | // 59 | Person() : dx(false), gleason(nogleason), stage(Healthy) {}; 60 | void init(); 61 | virtual void handleMessage(const cMessage* msg); 62 | virtual Time age() { return now(); } 63 | }; 64 | 65 | void Person::resetPopulation() { 66 | personTime = Means(); 67 | popSize = nCancer = nLocalisedCancer = nLocallyAdvancedCancer = nMetastaticCancer = 0; 68 | } 69 | 70 | Means Person::personTime = Means(); 71 | int Person::popSize = 0; 72 | int Person::nCancer = 0; 73 | int Person::nLocalisedCancer = 0; 74 | int Person::nLocallyAdvancedCancer = 0; 75 | int Person::nMetastaticCancer = 0; 76 | 77 | /** Hazard ratio for diagnosis 78 | @param stage Disease stage 79 | */ 80 | double dxHR(stage_t stage) { 81 | // raise error if healthy? 82 | return stage==Healthy ? -1 : 83 | (stage==Localised ? 1.1308 : 84 | (stage==LocallyAdvanced ? 0.5900 :1.3147)); 85 | } 86 | 87 | /** Hazard ratio for progression 88 | @param gleason Gleason category 89 | */ 90 | double progressionHR(gleason_t gleason) { 91 | return gleason==gleasonLt7 ? 1 : 92 | (gleason==gleason7 ? 1.3874 : 1.4027 * 1.3874); 93 | } 94 | 95 | /** 96 | Initialise a simulation run for an individual 97 | */ 98 | void Person::init() { 99 | if (R::runif(0.0,1.0)<0.2241) 100 | scheduleAt(R::rweibull(exp(2.3525),64.0218),"Localised"); 101 | scheduleAt(R::rexp(80.0),"Death"); 102 | } 103 | 104 | /** 105 | Handle receiving self-messages 106 | */ 107 | void Person::handleMessage(const cMessage* msg) { 108 | 109 | double dwellTime, pDx; 110 | 111 | if (msg->name == "Death") { 112 | personTime += msg->timestamp; 113 | popSize += 1; 114 | Sim::stop_simulation(); 115 | } 116 | 117 | else if (msg->name == "PCDeath") { 118 | // record that this was a PC death prior to diagnosis 119 | personTime += msg->timestamp; 120 | popSize += 1; 121 | Sim::stop_simulation(); 122 | } 123 | 124 | else if (msg->name == "Localised") { 125 | stage = Localised; 126 | gleason = (R::runif(0.0,1.0)<0.6812) ? gleasonLt7 : 127 | ((R::runif(0.0,1.0)<0.5016) ? gleason7 : gleasonGt7); 128 | Time dwellTime = now()+ 129 | rweibullHR(exp(1.0353),19.8617,progressionHR(gleason)* 130 | dxHR(stage)); 131 | // now separate out for different transitions 132 | pDx = 1.1308/(2.1308); 133 | if (R::runif(0.0,1.0)name == "LocallyAdvanced") { 142 | stage=LocallyAdvanced; 143 | nLocallyAdvancedCancer += 1; 144 | Time dwellTime = now()+ 145 | rweibullHR(exp(1.4404),16.3863,progressionHR(gleason)* 146 | dxHR(stage)); 147 | // now separate out for different transitions 148 | pDx = 0.5900/(1.0+0.5900); 149 | if (R::runif(0.0,1.0)name == "Metastatic") { 158 | stage=Metastatic; 159 | Time dwellTime = now()+ 160 | rweibullHR(exp(1.4404),1.4242,progressionHR(gleason)* 161 | dxHR(stage)); 162 | // now separate out for different transitions 163 | pDx = 1.3147/(1.0+1.3147); 164 | if (R::runif(0.0,1.0)name == "DxLocalised") { 173 | dx=true; 174 | nLocalisedCancer += 1; 175 | // relative survival 176 | } 177 | 178 | else if (msg->name == "DxLocallyAdvanced") { 179 | dx=true; 180 | nLocallyAdvancedCancer += 1; 181 | // relative survival 182 | } 183 | 184 | else if (msg->name == "DxMetastatic") { 185 | dx=true; 186 | nMetastaticCancer += 1; 187 | // relative survival 188 | }; 189 | 190 | }; 191 | 192 | extern "C" { 193 | 194 | void callPersonSimulation(int* inseed, double* parms, int *nin, double *out, int *nout) { 195 | // input parameters from R (TODO) 196 | Person person; 197 | unsigned long seed[6]; 198 | for (int i=0; i<6; i++) { 199 | seed[i]=(unsigned long)inseed[i]; 200 | } 201 | //GetRNGstate(); // for non-user-defined uniform random number generators 202 | RngStream_SetPackageSeed(seed); 203 | Rng * rng = new Rng(); 204 | rng->set(); 205 | Person::resetPopulation(); 206 | for (int i = 0; i < *nin; i++) { 207 | rng->nextSubstream(); 208 | person = Person(); 209 | Sim::create_process(&person); 210 | Sim::run_simulation(); 211 | Sim::clear(); 212 | } 213 | // output arguments to R 214 | out[0] = Person::personTime.mean(); 215 | out[1] = Person::personTime.sd(); 216 | // tidy up -- what needs to be deleted? 217 | delete rng; 218 | //PutRNGstate(); // for non-user-defined uniform random number generators 219 | } 220 | 221 | 222 | void testRng(int* inseed, double *out) { 223 | unsigned long seed[6]; 224 | for (int i=0; i<6; i++) { 225 | seed[i]=(unsigned long)inseed[i]; 226 | } 227 | //GetRNGstate(); 228 | RngStream_SetPackageSeed(seed); 229 | Rng * rng = new Rng(); 230 | rng->set(); 231 | // output arguments to R 232 | out[0] = R::rnorm(0.0, 1.0); 233 | out[1] = R::rnorm(0.0, 1.0); 234 | // tidy up -- what needs to be deleted? 235 | delete rng; 236 | //PutRNGstate(); // for non-user-defined uniform random number generators 237 | } 238 | 239 | } // extern "C" 240 | -------------------------------------------------------------------------------- /src/calibperson-r.cc: -------------------------------------------------------------------------------- 1 | /** 2 | * @file 3 | * @author Mark Clements 4 | * @version 1.0 5 | * 6 | * @section LICENSE 7 | * 8 | * This program is free software; you can redistribute it and/or 9 | * modify it under the terms of the GNU General Public License as 10 | * published by the Free Software Foundation; either version 2 of 11 | * the License, or (at your option) any later version. 12 | * 13 | * This program is distributed in the hope that it will be useful, but 14 | * WITHOUT ANY WARRANTY; without even the implied warranty of 15 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 16 | * General Public License for more details at 17 | * http://www.gnu.org/copyleft/gpl.html 18 | * 19 | * @section DESCRIPTION 20 | 21 | Hypothetical microsimulation model. Edited by Alexandra Jauhiainen 130205. 22 | 23 | TODO 24 | * other causes of death - incorporate rates 25 | * other transitions 26 | * age-specific reporting of state probabilities 27 | */ 28 | 29 | /**#include "event-r.h" 30 | #include 31 | #include */ 32 | #include "microsimulation.h" 33 | #include 34 | 35 | namespace { 36 | 37 | using namespace ssim; 38 | using namespace std; 39 | 40 | //! enum of type of disease stage 41 | enum stage_t {DiseaseFree,Precursor,PreClinical,Clinical,Death}; 42 | 43 | //! enum of type of event type 44 | enum event_t {toPrecursor, toPreClinical, toClinical, toDeath, Count}; 45 | 46 | //! names of the stages 47 | string stage_names[5] = {"DiseaseFree","Precursor","PreClinical","Clinical","Death"}; 48 | 49 | //! declare the random number generator 50 | Rng * rng; 51 | 52 | //! Class to simulate a person 53 | class CalibPerson : public cProcess 54 | { 55 | public: 56 | stage_t stage; 57 | bool diseasepot; 58 | double Lam1,sigm1,p2,lam2,mu3,tau3; 59 | double clinTime; 60 | int id; 61 | 62 | // static member(s) 63 | static std::map > report; 64 | 65 | static void resetPopulation (); 66 | 67 | CalibPerson() {} // default constructor 68 | 69 | CalibPerson(double *par, int i=0) { 70 | Lam1=par[0]; 71 | sigm1=par[1]; 72 | p2=par[2]; 73 | lam2=par[3]; 74 | mu3=par[4]; 75 | tau3=par[5]; 76 | id=i; 77 | stage=DiseaseFree; 78 | }; 79 | 80 | void init(); 81 | virtual void handleMessage(const cMessage* msg); 82 | virtual Time age() { return now(); } 83 | }; 84 | 85 | void CalibPerson::resetPopulation() { 86 | report.clear(); 87 | } 88 | 89 | // initialise static member(s) 90 | std::map > CalibPerson::report; 91 | 92 | /** 93 | Initialise a simulation run for an individual 94 | */ 95 | void CalibPerson::init() { 96 | if (R::runif(0,1)kind == toDeath) { 122 | stage=Death; 123 | clinTime=std::min(clinTime,now()); 124 | 125 | for(unsigned int i=0; i<4 ; i++){ 126 | if(i < report["TimeAtRisk"].size()){ 127 | report["TimeAtRisk"][i] += std::min(ctime[i],clinTime); 128 | } 129 | else { 130 | report["TimeAtRisk"].push_back(std::min(ctime[i],clinTime)); 131 | } 132 | 133 | if(clinTime < ctime[i]){ 134 | break; 135 | } 136 | 137 | } 138 | 139 | Sim::stop_simulation(); 140 | } 141 | 142 | else if (msg->kind == toPrecursor) { 143 | stage = Precursor; 144 | if (diseasepot){ 145 | simtime_t dwellTime = now()+ R::rexp(lam2); 146 | scheduleAt(dwellTime, toPreClinical); 147 | } 148 | } 149 | 150 | else if (msg->kind == toPreClinical) { 151 | stage=PreClinical; 152 | simtime_t dwellTime = now()+ exp(R::rnorm(mu3,tau3*mu3)); 153 | scheduleAt(dwellTime, toClinical); 154 | } 155 | 156 | else if (msg->kind == toClinical) { 157 | stage=Clinical; 158 | clinTime = now(); 159 | string stagestr = stage_names[stage]; 160 | } 161 | 162 | else if (msg->kind == Count){ 163 | cind = min(9,int(now()/10 - 1)); 164 | string stagestr = stage_names[stage]; 165 | 166 | if(report.find(stagestr) == report.end()){ //key not found 167 | report[stagestr].assign(10,0); 168 | } 169 | report[stagestr][cind]+=1; 170 | } 171 | } 172 | 173 | 174 | extern "C" { 175 | 176 | RcppExport SEXP callCalibrationSimulation(SEXP parms) { 177 | Rcpp::List parmsl(parms); 178 | int nin = Rcpp::as(parmsl["n"]); 179 | std::vector par = Rcpp::as >(parmsl["runpar"]); 180 | 181 | CalibPerson::resetPopulation(); 182 | rng = new Rng(); 183 | rng->set(); 184 | 185 | CalibPerson::report.insert(make_pair("TimeAtRisk", std::vector())); 186 | 187 | CalibPerson person; 188 | for (int i = 0; i < nin; i++) { 189 | person = CalibPerson(&par[0],0); 190 | rng->nextSubstream(); 191 | Sim::create_process(&person); 192 | Sim::run_simulation(); 193 | Sim::clear(); 194 | } 195 | 196 | delete rng; 197 | 198 | return Rcpp::wrap(CalibPerson::report); 199 | 200 | } 201 | 202 | } 203 | 204 | } 205 | -------------------------------------------------------------------------------- /src/doc/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | doxygen Doxyfile 3 | -------------------------------------------------------------------------------- /src/doc/footer.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 12 | 13 | 14 |
15 | $generatedby   16 | doxygen 17 | $doxygenversion 18 |
19 | 20 | 21 | 22 | -------------------------------------------------------------------------------- /src/doc/header.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | $projectname: $title 9 | $title 10 | 11 | 12 | 13 | $treeview 14 | $search 15 | $mathjax 16 | 17 | $extrastylesheet 18 | 19 | 20 |
21 | 22 | 23 |
24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 37 | 38 | 39 | 40 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 |
32 |
$projectname 33 |  $projectnumber 34 |
35 |
$projectbrief
36 | 		41 |
$projectbrief
42 | 		$searchbox
53 |
54 | 55 | 56 | -------------------------------------------------------------------------------- /src/doc/maindoc.h: -------------------------------------------------------------------------------- 1 | // -*-C++-*- 2 | // 3 | // This file is part of Microsimulation package for R. 4 | // See http://github.com/mclements/microsimulation 5 | // 6 | // Authors: Mark Clements 7 | // See DESCRIPTION for full details. 8 | // 9 | // Microsimulation is free software: you can redistribute it and/or modify it under 10 | // the terms of the GNU General Public License as published by the Free 11 | // Software Foundation, either version 3 of the License, or (at your 12 | // option) any later version. 13 | // 14 | // Microsimulation is distributed in the hope that it will be useful, 15 | // but WITHOUT ANY WARRANTY; without even the implied warranty of 16 | // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 | // GNU General Public License for more details. 18 | // 19 | // You should have received a copy of the GNU General Public License 20 | // along with Microsimulation. If not, see . 21 | // 22 | /** \mainpage Microsimulation C++ API Documentation 23 | 24 | This documentation describes the C++ application programming interface 25 | to Microsimulation, a 26 | very simple discrete-event sequential simulation library for R and C++. The C++ simulations build upon the to Ssim simulation library. 27 | The 28 | simulator implemented by ssim executes process 29 | objects. Process objects can be programmed either as 30 | reactive or sequential processes. A reactive 31 | process is programmed by a "callback" function that defines the 32 | discrete execution steps of that process, performed in response to an 33 | event. A sequential process is programmed as a traditional 34 | sequential thread that can explicitly receive events. 35 | 36 |

The events received by a process represent interactions with other 37 | processes, activities scheduled by the process itself, or timeouts. 38 | The simulation proceeds by scheduling the responses of each process to 39 | the event signalled to that process. During these execution steps, a 40 | process may signal events to itself and to other processes, 41 | immediately or with a delay, thereby scheduling other execution steps. 42 | The simulation terminates when no more actions are scheduled. 43 | 44 |

The ssim library consists of essentially two classes defined 45 | within the \link ssim ssim\endlink namespace: \link ssim::Sim 46 | Sim\endlink, which defines the interface to the simulator and \link 47 | ssim::Process Process\endlink, which defines the interface and base 48 | class for a reactive process. 49 | User processes can be programmed by extending Process. 50 | 51 |

\link ssim::Sim Sim\endlink offers the basic primitives for 52 | signaling \link ssim::Event events\endlink, and for creating, 53 | starting, and stopping processes. \link ssim::Process Process\endlink 54 | declares the execution steps scheduled when a process is \link 55 | ssim::Process::initialize() started\endlink, \link 56 | ssim::Process::process_event() signaled\endlink, and \link 57 | ssim::Process::stop() stopped\endlink. Notice that \link ssim::Sim 58 | Sim\endlink defines a single, static simulation module, rather than a 59 | class for simulation objects. (See \link ssim::Sim Sim\endlink for 60 | more detailed comments.) 61 | 62 |

The execution of the simulation is based on a virtual 63 | clock that represents the time in the simulated world. The 64 | virtual clock is simply a counter, therefore the time unit is 65 | determined by the semantics of the simulated processes. The initial 66 | value of the virtual clock is 0. The passage of (virtual) time in the 67 | simulated world is explicitly controlled by each process, essentially 68 | in three ways: 69 | 70 |

    71 | 72 |
  • by "sleeping". That is, by scheduling a "timeout" event for 73 | itself after a given interval. The library does not provide an 74 | explicit timeout event class, but rather it leaves that to the 75 | application. The easiest way to implement a timeout is to signal a 76 | NULL event; 77 | 78 |
  • by signaling events to other processes with a given delay (see 79 | \link ssim::Sim::signal_event(ProcessId,const Event*,Time) 80 | signal_event()\endlink); 81 | 82 |
  • by explicitly declaring the duration of an action or an execution 83 | step using the \link ssim::Sim::advance_delay(Time) 84 | Sim::advance_delay(Time delay)\endlink method. 85 | 86 |
87 | 88 |

The documentation of \link ssim::Sim::advance_delay(Time) 89 | advance_delay\endlink provides an in-depth discussion of the semantics 90 | of the simulation in relation to virtual time. 91 | 92 |

In addition to the basic Process class, the library provides a 93 | utility class \link ssim::ProcessWithPId ProcessWithPId\endlink, that 94 | automates some common procedures for process implementations. 95 | 96 | */ 97 | 98 | -------------------------------------------------------------------------------- /src/gsm.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | 6 | namespace ssim { 7 | 8 | double gsm::link(double S) { 9 | return link_type==PH ? std::log(-std::log(S)) : -100.0; 10 | } 11 | double gsm::linkinv(double eta) { 12 | return link_type==PH ? std::exp(-std::exp(eta)) : 1.0e-10; 13 | } 14 | gsm::gsm() {} 15 | double gsm::eta(double y) { 16 | double eta = etap(index); 17 | for (size_t i=0; iindex = index; 43 | this->target = (tentry==0.0 ? link(u) : link(u*linkinv(eta(ymin)))); 44 | this->target0 = 0.0; // not used 45 | double root = std::get<0>(R_zeroin2_functor_ptr(ymin, ymax, this, 1.0e-8, 100)); 46 | return log_time ? std::exp(root) : root; 47 | } 48 | double gsm::randU0(double u, int index, double scale) { 49 | using std::log; 50 | double ymin = log_time ? log(tmin/scale) : tmin/scale; 51 | double ymax = log_time ? log(tmax*scale) : tmax*scale; 52 | this->index = index; 53 | this->target = link(u); // solution for timetarget0 = link(u*linkinv(eta0(log_time ? log(t0) : t0)) / 55 | linkinv(eta(log_time ? log(t0) : t0))); // solution for time>=t0 56 | double root = std::get<0>(R_zeroin2_functor_ptr(ymin, ymax, this, 1.0e-8, 100)); 57 | return log_time ? std::exp(root) : root; 58 | } 59 | 60 | gsm::gsm(Rcpp::List list) { 61 | try { 62 | using namespace Rcpp; 63 | std::string link_name = as(list("link_name")); 64 | tmin = as(list("tmin")); 65 | tmax = as(list("tmax")); 66 | double inflate = as(list("inflate")); 67 | tmin = tmin/inflate; tmax = tmax*inflate; 68 | etap = as(list("etap")); 69 | etap0 = as(list("etap0")); 70 | List lterms = as(list("terms")); 71 | for (int i=0; i(lterms(i)); 73 | gsm_term term; 74 | term.gamma = as(lterm("gamma")); 75 | arma::vec knots = as(lterm("knots")); 76 | arma::vec Boundary_knots = as(lterm("Boundary_knots")); 77 | int intercept = as(lterm("intercept")); 78 | arma::mat q_const = as(lterm("q_const")); 79 | int cure = as(lterm("cure")); 80 | term.ns1 = ns(Boundary_knots, knots, q_const, intercept, cure); 81 | term.x = as(lterm("x")); 82 | terms.push_back(term); 83 | } 84 | log_time = as(list("log_time")); 85 | target = 0.0; 86 | target0 = 0.0; 87 | index = 0; 88 | t0 = as(list("t0")); 89 | if (link_name == "PH") link_type = PH; 90 | } catch(std::exception &ex) { 91 | forward_exception_to_r(ex); 92 | } catch(...) { 93 | ::Rf_error("c++ exception (unknown reason)"); 94 | } 95 | } 96 | 97 | gsm::gsm(SEXP args) : gsm(Rcpp::as(args)) { } 98 | 99 | RcppExport SEXP test_read_gsm(SEXP gsm_args, SEXP start_args) { 100 | Rcpp::RNGScope rngScope; 101 | double start = Rcpp::as(start_args); 102 | gsm gsm1(gsm_args); 103 | return Rcpp::wrap(gsm1.rand(start)); 104 | } 105 | 106 | } // namespace ssim 107 | -------------------------------------------------------------------------------- /src/illness-death.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | namespace illnessDeath { 5 | 6 | using namespace std; 7 | using namespace ssim; 8 | 9 | enum state_t {Healthy,Cancer}; 10 | 11 | enum event_t {toOtherDeath, toCancer, toCancerDeath}; 12 | 13 | EventReport report; 14 | double cure, zsd; // parameters - could be static class variables 15 | 16 | 17 | double b_weibull(double mean, double a, double rr = 1.0) { 18 | return mean/R::gammafn(1.0+1.0/a)*pow(rr,-1.0/a); 19 | } 20 | 21 | class SimplePerson : public cProcess 22 | { 23 | public: 24 | state_t state; 25 | int id; 26 | double z; 27 | SimplePerson(const int i = 0) : id(i) {}; 28 | void init(); 29 | virtual void handleMessage(const cMessage* msg); 30 | }; 31 | 32 | /** 33 | Initialise a simulation run for an individual 34 | */ 35 | void SimplePerson::init() { 36 | state = Healthy; 37 | z = exp(R::rnorm(0.0,zsd)); 38 | scheduleAt(R::rweibull(4.0,b_weibull(80.0,4.0)), toOtherDeath); 39 | if (R::runif(0.0,1.0)>cure) 40 | scheduleAt(R::rweibull(3.0,b_weibull(80.0,3.0,z)), toCancer); 41 | } 42 | 43 | /** 44 | Handle receiving self-messages 45 | */ 46 | void SimplePerson::handleMessage(const cMessage* msg) { 47 | 48 | report.add(state, msg->kind, previousEventTime, now()); 49 | 50 | switch(msg->kind) { 51 | 52 | case toOtherDeath: 53 | case toCancerDeath: 54 | // reporting already completed: stop the simulation 55 | Sim::stop_process(); 56 | break; 57 | 58 | case toCancer: 59 | state = Cancer; 60 | RemoveKind(toOtherDeath); 61 | if (R::runif(0.0,1.0) < 0.5) // cure fraction 62 | scheduleAt(now() + R::rweibull(1.0,10.0), toCancerDeath); 63 | break; 64 | 65 | default: 66 | REprintf("No valid kind of event\n"); 67 | break; 68 | 69 | } // switch 70 | 71 | } // handleMessage() 72 | 73 | RcppExport SEXP callIllnessDeath(SEXP parms) { 74 | SimplePerson person; 75 | Rcpp::RNGScope scope; 76 | Rcpp::List parmsl(parms); 77 | int n = Rcpp::as(parmsl["n"]); 78 | cure = Rcpp::as(parmsl["cure"]); 79 | zsd = Rcpp::as(parmsl["zsd"]); 80 | 81 | vector ages(101); 82 | std::iota(ages.begin(), ages.end(), 0.0); 83 | ages.push_back(1.0e+6); 84 | report.clear(); 85 | report.setPartition(ages); 86 | 87 | for (int i = 0; i < n; i++) { 88 | person = SimplePerson(i); 89 | Sim::create_process(&person); 90 | Sim::run_simulation(); 91 | Sim::clear(); 92 | } 93 | return report.wrap(); 94 | } 95 | 96 | } // namespace illnessDeath 97 | -------------------------------------------------------------------------------- /src/init.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include // for NULL 4 | #include 5 | 6 | /* FIXME: 7 | Check these declarations against the C/Fortran source code. 8 | */ 9 | 10 | /* .C calls */ 11 | extern void r_get_user_random_seed(void *); 12 | extern void r_next_rng_substream(void); 13 | extern void r_rng_advance_substream(void *, void *); 14 | extern void r_set_user_random_seed(void *); 15 | extern void r_create_current_stream(void); 16 | extern void r_remove_current_stream(void); 17 | 18 | /* .Call calls */ 19 | extern SEXP callCalibrationSimulation(SEXP); 20 | extern SEXP callIllnessDeath(SEXP); 21 | extern SEXP callPersonSimulation(SEXP, SEXP); 22 | extern SEXP callSimplePerson(SEXP); 23 | extern SEXP callSimplePerson2(SEXP); 24 | extern SEXP pqueue__cancel(SEXP, SEXP); 25 | extern SEXP pqueue__clear(SEXP); 26 | extern SEXP pqueue__empty(SEXP); 27 | extern SEXP pqueue__new(SEXP); 28 | extern SEXP pqueue__pop(SEXP); 29 | extern SEXP pqueue__push(SEXP, SEXP, SEXP); 30 | extern SEXP test_read_gsm(SEXP,SEXP); 31 | 32 | static const R_CMethodDef CEntries[] = { 33 | {"r_get_user_random_seed", (DL_FUNC) &r_get_user_random_seed, 1}, 34 | {"r_next_rng_substream", (DL_FUNC) &r_next_rng_substream, 0}, 35 | {"r_rng_advance_substream", (DL_FUNC) &r_rng_advance_substream, 2}, 36 | {"r_set_user_random_seed", (DL_FUNC) &r_set_user_random_seed, 1}, 37 | {"r_create_current_stream", (DL_FUNC) &r_create_current_stream, 0}, 38 | {"r_remove_current_stream", (DL_FUNC) &r_remove_current_stream, 0}, 39 | {"test_read_gsm", (DL_FUNC) &test_read_gsm, 2}, 40 | {NULL, NULL, 0} 41 | }; 42 | 43 | static const R_CallMethodDef CallEntries[] = { 44 | {"callCalibrationSimulation", (DL_FUNC) &callCalibrationSimulation, 1}, 45 | {".callIllnessDeath", (DL_FUNC) &callIllnessDeath, 1}, 46 | {".callPersonSimulation", (DL_FUNC) &callPersonSimulation, 2}, 47 | {".callSimplePerson", (DL_FUNC) &callSimplePerson, 1}, 48 | {".callSimplePerson2", (DL_FUNC) &callSimplePerson2, 1}, 49 | {"pqueue__cancel", (DL_FUNC) &pqueue__cancel, 2}, 50 | {"pqueue__clear", (DL_FUNC) &pqueue__clear, 1}, 51 | {"pqueue__empty", (DL_FUNC) &pqueue__empty, 1}, 52 | {"pqueue__new", (DL_FUNC) &pqueue__new, 1}, 53 | {"pqueue__pop", (DL_FUNC) &pqueue__pop, 1}, 54 | {"pqueue__push", (DL_FUNC) &pqueue__push, 3}, 55 | {NULL, NULL, 0} 56 | }; 57 | 58 | void R_init_microsimulation(DllInfo *dll) 59 | { 60 | R_registerRoutines(dll, CEntries, CallEntries, NULL, NULL); 61 | R_useDynamicSymbols(dll, TRUE); 62 | } 63 | -------------------------------------------------------------------------------- /src/microsimulation.cc: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | namespace ssim { 4 | 5 | double rweibullHR(double shape, double scale, double hr){ 6 | return R::rweibull(shape, scale*pow(hr,1.0/shape)); 7 | } 8 | 9 | Time now() { 10 | return Sim::clock(); 11 | } 12 | 13 | Time simTime() { 14 | return Sim::clock(); 15 | } 16 | 17 | 18 | static Rng * default_stream, * current_stream; 19 | static double rn = 0.0; 20 | 21 | Rng::~Rng() { 22 | if (current_stream->id == this->id) 23 | current_stream = default_stream; 24 | } 25 | 26 | void Rng::set() { 27 | current_stream = this; 28 | } 29 | 30 | extern "C" { 31 | 32 | void r_create_current_stream() 33 | { 34 | default_stream = new Rng(); 35 | current_stream = default_stream; 36 | } 37 | 38 | void r_remove_current_stream() 39 | { 40 | delete default_stream; 41 | } 42 | 43 | void r_set_user_random_seed(double * inseed) { 44 | double seed[6]; 45 | for(int i=0; i<6; i++) { 46 | seed[i] = inseed[i]; 47 | } 48 | Rng::SetPackageSeed(seed); 49 | default_stream->SetSeed(seed); 50 | } 51 | 52 | void r_get_user_random_seed(double * outseed) { 53 | double seed[6]; 54 | default_stream->GetState(seed); 55 | for(int i=0; i<6; i++) { 56 | outseed[i] = (double)seed[i]; 57 | } 58 | } 59 | 60 | void r_next_rng_substream() { 61 | default_stream->ResetNextSubstream(); 62 | } 63 | 64 | void r_rng_advance_substream(double * inoutseed, int * n) { 65 | RngStream r; 66 | double seed[6]; 67 | for (int i=0; i<6; i++) 68 | seed[i]=inoutseed[i]; 69 | r.SetSeed(seed); 70 | r.AdvanceSubstream(0, *n); 71 | r.GetState(seed); 72 | for (int i=0; i<6; i++) 73 | inoutseed[i]= seed[i]; 74 | } 75 | 76 | double *user_unif_rand () 77 | { 78 | if (!current_stream) { 79 | REprintf("user_unif_rand(): No stream created yet!"); 80 | return NULL; 81 | } 82 | rn = current_stream->RandU01(); 83 | return &rn; 84 | } 85 | 86 | void test_rstream2(double * x) { 87 | Rng * s1 = new Rng(); 88 | Rng * s2 = new Rng(); 89 | x[0]=WithRNG(s1,R::rexp(1.0)); 90 | x[1]=WithRNG(s2,R::rexp(1.0)); 91 | s1->ResetNextSubstream(); 92 | x[2]=R::rexp(1.0); 93 | delete s1; 94 | delete s2; 95 | } 96 | 97 | } // extern "C" 98 | 99 | } // namespace ssim 100 | 101 | namespace R { 102 | double rnormPos(double mean, double sd) { 103 | double x; 104 | while ((x=R::rnorm(mean,sd))<0.0) { } 105 | return x; 106 | } 107 | 108 | double rllogis(double shape, double scale) { 109 | double u = R::runif(0.0,1.0); 110 | return scale*exp(-log(1.0/u-1.0)/shape); 111 | } 112 | 113 | double rllogis_trunc(double shape, double scale, double left) { 114 | double S0 = 1.0/(1.0+exp(log(left/scale)*shape)); 115 | double u = R::runif(0.0,1.0); 116 | return scale*exp(log(1.0/(u*S0)-1.0)/shape); 117 | } 118 | 119 | double rgompertz(double shape, double rate) { 120 | double u = 1.0 - R::runif(0.0, 1.0); 121 | return (shape < 0.0 && u 4 | * @version 1.0 5 | * 6 | * @section LICENSE 7 | * 8 | * This program is free software; you can redistribute it and/or 9 | * modify it under the terms of the GNU General Public License as 10 | * published by the Free Software Foundation; either version 2 of 11 | * the License, or (at your option) any later version. 12 | * 13 | * This program is distributed in the hope that it will be useful, but 14 | * WITHOUT ANY WARRANTY; without even the implied warranty of 15 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 16 | * General Public License for more details at 17 | * http://www.gnu.org/copyleft/gpl.html 18 | * 19 | * @section DESCRIPTION 20 | 21 | Microsimulation of prostate cancer using the FHCRC model. 22 | 23 | TODO 24 | * other causes of death - incorporate rates 25 | * other transitions 26 | * age-specific reporting of state probabilities 27 | */ 28 | 29 | #include 30 | 31 | namespace { 32 | 33 | using namespace std; 34 | using namespace ssim; 35 | 36 | //! enum for type of Gleason score 37 | enum gleason_t {nogleason,gleasonLt7,gleason7,gleasonGt7}; 38 | 39 | //! enum of type of disease stage 40 | enum stage_t {Healthy,Localised,DxLocalised,LocallyAdvanced,DxLocallyAdvanced, 41 | Metastatic,DxMetastatic,Death}; 42 | 43 | //! enum of type of event type 44 | enum event_t {toDeath, toPCDeath, toLocalised, toDxLocalised, 45 | toDxLocallyAdvanced, 46 | toLocallyAdvanced, toMetastatic, toDxMetastatic}; 47 | 48 | //! Class to simulate a person 49 | class Person : public cProcess 50 | { 51 | public: 52 | gleason_t gleason; 53 | stage_t stage; 54 | bool dx; 55 | int id; 56 | 57 | // static member(s) 58 | static std::map > report; 59 | static std::map rng; 60 | 61 | static void resetPopulation (); 62 | // 63 | Person(int i = 0) : gleason(nogleason), stage(Healthy), dx(false), id(i) {}; 64 | void init(); 65 | virtual void handleMessage(const cMessage* msg); 66 | virtual Time age() { return now(); } 67 | }; 68 | 69 | void Person::resetPopulation() { 70 | report.clear(); 71 | } 72 | 73 | // initialise static member(s) 74 | std::map > Person::report; 75 | std::map Person::rng; 76 | 77 | /** Hazard ratio for diagnosis 78 | @param stage Disease stage 79 | */ 80 | double dxHR(stage_t stage) { 81 | // raise error if healthy? 82 | return stage==Healthy ? -1 : 83 | (stage==Localised ? 1.1308 : 84 | (stage==LocallyAdvanced ? 0.5900 :1.3147)); 85 | } 86 | 87 | /** Hazard ratio for progression 88 | @param gleason Gleason category 89 | */ 90 | double progressionHR(gleason_t gleason) { 91 | return gleason==gleasonLt7 ? 1 : 92 | (gleason==gleason7 ? 1.3874 : 1.4027 * 1.3874); 93 | } 94 | 95 | /** 96 | Initialise a simulation run for an individual 97 | */ 98 | void Person::init() { 99 | rng["NH"]->set(); 100 | if (R::runif(0.0,1.0)<0.2241) 101 | scheduleAt(R::rweibull(exp(2.3525),64.0218),toLocalised); 102 | scheduleAt(R::rexp(80.0),toDeath); 103 | } 104 | 105 | /** 106 | Handle receiving self-messages 107 | */ 108 | void Person::handleMessage(const cMessage* msg) { 109 | 110 | double pDx; 111 | 112 | report["id"].push_back(id); 113 | report["startTime"].push_back(previousEventTime); 114 | report["endTime"].push_back(now()); 115 | report["state"].push_back(stage); 116 | report["event"].push_back(msg->kind); 117 | 118 | rng["NH"]->set(); 119 | 120 | if (msg->kind == toDeath) { 121 | Sim::stop_simulation(); 122 | } 123 | 124 | else if (msg->kind == toPCDeath) { 125 | Sim::stop_simulation(); 126 | } 127 | 128 | else if (msg->kind == toLocalised) { 129 | stage = Localised; 130 | gleason = (R::runif(0.0,1.0)<0.6812) ? gleasonLt7 : 131 | ((R::runif(0.0,1.0)<0.5016) ? gleason7 : gleasonGt7); 132 | Time dwellTime = now()+ 133 | rweibullHR(exp(1.0353),19.8617,progressionHR(gleason)* 134 | dxHR(stage)); 135 | // now separate out for different transitions 136 | pDx = 1.1308/(2.1308); 137 | if (R::runif(0.0,1.0)kind == toLocallyAdvanced) { 146 | stage=LocallyAdvanced; 147 | Time dwellTime = now()+ 148 | rweibullHR(exp(1.4404),16.3863,progressionHR(gleason)* 149 | dxHR(stage)); 150 | // now separate out for different transitions 151 | pDx = 0.5900/(1.0+0.5900); 152 | if (R::runif(0.0,1.0)kind == toMetastatic) { 161 | stage=Metastatic; 162 | Time dwellTime = now()+ 163 | rweibullHR(exp(1.4404),1.4242,progressionHR(gleason)* 164 | dxHR(stage)); 165 | // now separate out for different transitions 166 | pDx = 1.3147/(1.0+1.3147); 167 | if (R::runif(0.0,1.0)kind == toDxLocalised) { 176 | dx=true; 177 | // relative survival 178 | } 179 | 180 | else if (msg->kind == toDxLocallyAdvanced) { 181 | dx=true; 182 | // relative survival 183 | } 184 | 185 | else if (msg->kind == toDxMetastatic) { 186 | dx=true; 187 | // relative survival 188 | }; 189 | 190 | } 191 | 192 | 193 | extern "C" { 194 | 195 | RcppExport SEXP callPersonSimulation(SEXP inseed, SEXP parms) { 196 | Rcpp::List parmsl(parms); 197 | Rcpp::IntegerVector inseed2(inseed); 198 | int nin = Rcpp::as(parmsl["n"]); 199 | double seed[6]; 200 | for (int i=0; i<6; i++) { 201 | seed[i]=inseed2[i]; 202 | } 203 | //r_create_current_stream(); 204 | RngStream::SetPackageSeed(seed); 205 | Person::resetPopulation(); 206 | Person::rng["NH"] = new Rng(); 207 | Person::rng["S"] = new Rng(); 208 | Person::rng["NH"]->set(); 209 | Person person; 210 | for (int i = 0; i < nin; i++) { 211 | //Person::rng.foreach(nextSubStream); 212 | Person::rng["NH"]->nextSubstream(); 213 | Person::rng["S"]->nextSubstream(); 214 | person = Person(i); 215 | Sim::create_process(&person); 216 | Sim::run_simulation(); 217 | Sim::clear(); 218 | } 219 | // tidy up -- what needs to be deleted? 220 | delete Person::rng["NH"]; 221 | delete Person::rng["S"]; 222 | // Person::rng.clear(); 223 | // output arguments to R 224 | return Rcpp::wrap(Person::report); 225 | 226 | } // callPersonSimulation() 227 | 228 | } // extern "C" 229 | 230 | } // namespace person_r 231 | 232 | namespace { 233 | 234 | class VerySimple : public cProcess { 235 | public: 236 | void init() { 237 | scheduleAt(10.0, "a message"); 238 | scheduleAt(11.0, "another message"); 239 | }; 240 | virtual void handleMessage(const cMessage* msg) {}; 241 | }; 242 | 243 | extern "C" { 244 | 245 | RcppExport SEXP callSpeedTest() { 246 | VerySimple simple; 247 | for (int i = 0; i < 1000000; i++) { 248 | simple = VerySimple(); 249 | Sim::create_process(&simple); 250 | Sim::run_simulation(); 251 | Sim::clear(); 252 | } 253 | return Rcpp::wrap(1); 254 | 255 | } // callSpeedTest() 256 | 257 | } // extern "C" 258 | 259 | } // anonymous namespace 260 | 261 | 262 | 263 | -------------------------------------------------------------------------------- /src/pqueue.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | namespace ssim { 3 | 4 | using namespace Rcpp; 5 | 6 | struct pqueueElement { 7 | double priority; 8 | long _order; 9 | bool active; 10 | SEXP event; 11 | pqueueElement(double priority, long order, bool active, SEXP event) 12 | : priority(priority), _order(order), active(active), event(event) { } 13 | virtual ~pqueueElement() = default; 14 | }; 15 | 16 | struct pqueueElementComparator { 17 | bool smaller; 18 | pqueueElementComparator(bool smaller = true) : smaller(smaller) {} 19 | bool operator()(pqueueElement const& msg1, pqueueElement const& msg2) const { 20 | return (smaller ? msg1.priority > msg2.priority : msg1.priority < msg2.priority) || 21 | (msg1.priority == msg2.priority && msg1._order > msg2._order); 22 | } 23 | }; 24 | 25 | class pqueue { 26 | private: 27 | std::vector _elements; 28 | pqueueElementComparator _compare; 29 | long _entryOrder; 30 | bool _anyCancelled; 31 | using size_type = std::vector::size_type; 32 | public: 33 | explicit pqueue(bool smaller = true) { 34 | _compare = pqueueElementComparator(smaller); 35 | _entryOrder = 0; 36 | _anyCancelled = false; 37 | } 38 | /** 39 | Push an elements to the priority queue 40 | */ 41 | void pushElement(pqueueElement element) 42 | { 43 | _elements.push_back(std::move(element)); 44 | std::push_heap(_elements.begin(), _elements.end(), _compare); 45 | } 46 | void push(double priority, SEXP event) 47 | { 48 | pqueueElement element(priority, _entryOrder, true, event); 49 | pushElement(std::move(element)); 50 | // _elements.push_back(std::move(element)); 51 | // std::push_heap(_elements.begin(), _elements.end(), _compare); 52 | _entryOrder++; 53 | } 54 | /** 55 | Pop an elements from the priority queue (that is, get the next element) 56 | Ignores whether an element is active or not. 57 | */ 58 | pqueueElement popElement() 59 | { 60 | try { 61 | if (empty()) { 62 | throw std::length_error("Empty priority queue"); 63 | } 64 | while(!_elements.empty()) { 65 | std::pop_heap(_elements.begin(), _elements.end(), _compare); 66 | pqueueElement result = std::move(_elements.back()); 67 | _elements.pop_back(); 68 | if (result.active) 69 | return result; // change: std::move *not* used here 70 | } 71 | } catch(std::exception &ex) { 72 | forward_exception_to_r(ex); 73 | } catch(...) { 74 | ::Rf_error("c++ exception (unknown reason)"); 75 | } 76 | return _elements[0]; // never called (prevents -Wreturn-type warning) 77 | } 78 | /** 79 | Pop an active event from the priority queue. 80 | */ 81 | List pop() { 82 | pqueueElement element = popElement(); 83 | return List::create(_["priority"]=element.priority, _["event"]=element.event); 84 | } 85 | /** 86 | Check whether the priority queue is either empty or has only inactive events 87 | */ 88 | bool empty() { 89 | if (_elements.empty()) return true; // empty queue 90 | else if (!_anyCancelled) return false; // queue not empty and no cancelled events 91 | else { // loop through to see if any of the elements are active 92 | for(size_type i=0; i<_elements.size(); i++) 93 | if(_elements[i].active) return false; // at least one active events 94 | return true; // no active events 95 | } 96 | } 97 | /** 98 | Clear the priority queue 99 | */ 100 | void clear () { 101 | _elements.clear(); // assumes that elements are safe pointers 102 | } 103 | /** 104 | Cancel any events that satisfy a predicate (which is an R function). 105 | */ 106 | void cancel(Rcpp::Function predicate) { 107 | if (!empty()) 108 | for(size_type i=0; i<_elements.size(); i++) { 109 | if (as(predicate(_elements[i].event))) 110 | _elements[i].active = false; 111 | } 112 | _anyCancelled = true; 113 | } 114 | /** 115 | General method to apply a function f() to each element 116 | Use remake=true if f() may change the order in the priority queue. 117 | */ 118 | template 119 | void for_each(F f, bool remake = false) { 120 | std::for_each(_elements.begin(), _elements.end(), f); 121 | if (remake) 122 | std::make_heap(_elements.begin(), _elements.end(), _compare); 123 | } 124 | virtual ~pqueue() = default; 125 | }; 126 | 127 | RcppExport 128 | SEXP pqueue__new(SEXP _lower) { 129 | bool lower = as(_lower); 130 | Rcpp::XPtr ptr(new pqueue(lower)); 131 | return wrap(ptr); 132 | } 133 | RcppExport 134 | SEXP pqueue__push(SEXP _ptr, SEXP _priority, SEXP event) { 135 | XPtr ptr = as >(_ptr); 136 | double priority = as(_priority); 137 | ptr->push(priority, event); 138 | return R_NilValue; 139 | } 140 | RcppExport 141 | SEXP pqueue__pop(SEXP _ptr) { 142 | XPtr ptr = as >(_ptr); 143 | return wrap(ptr->pop()); 144 | } 145 | RcppExport 146 | SEXP pqueue__cancel(SEXP _ptr, SEXP _predicate) { 147 | XPtr ptr = as >(_ptr); 148 | Function predicate = as(_predicate); 149 | ptr->cancel(predicate); 150 | return R_NilValue; 151 | } 152 | RcppExport 153 | SEXP pqueue__empty(SEXP _ptr) { 154 | XPtr ptr = as >(_ptr); 155 | return wrap(ptr->empty()); 156 | } 157 | RcppExport 158 | SEXP pqueue__clear(SEXP _ptr) { 159 | XPtr ptr = as >(_ptr); 160 | ptr->clear(); 161 | return R_NilValue; 162 | } 163 | 164 | } // namespace ssim 165 | -------------------------------------------------------------------------------- /src/rngstream-boost.hpp: -------------------------------------------------------------------------------- 1 | /* boost random/rngstream-boost.hpp header file 2 | * 3 | * Copyright Mark Clements 2014 4 | * Distributed under the Boost Software License, Version 1.0. (See 5 | * accompanying file LICENSE_1_0.txt or copy at 6 | * http://www.boost.org/LICENSE_1_0.txt) 7 | * 8 | * See http://www.boost.org for most recent version including documentation. 9 | * 10 | * 11 | * Revision history 12 | */ 13 | 14 | /***********************************************************************\ 15 | * 16 | * File: RngStream.cpp for multiple streams of Random Numbers 17 | * Language: C++ (ISO 1998) 18 | * Copyright: Pierre L'Ecuyer, University of Montreal 19 | * Notice: This code can be used freely for personal, academic, 20 | * or non-commercial purposes. For commercial purposes, 21 | * please contact P. L'Ecuyer at: lecuyer@iro.umontreal.ca 22 | * Date: 14 August 2001 23 | * 24 | \***********************************************************************/ 25 | 26 | #ifndef BOOST_RANDOM_RNGSTREAM_BOOST_HPP 27 | #define BOOST_RANDOM_RNGSTREAM_BOOST_HPP 28 | 29 | #include 30 | #include 31 | #include 32 | #include 33 | #include 34 | #include 35 | #include 36 | #include 37 | #include 38 | #include 39 | #include 40 | #include 41 | #include 42 | //#include 43 | #include 44 | #include 45 | #include 46 | 47 | #include 48 | 49 | #include 50 | #include 51 | 52 | namespace boost { 53 | namespace random { 54 | 55 | using ssim::RngStream; 56 | 57 | class rngstream : public RngStream 58 | { 59 | public: 60 | typedef double result_type; 61 | 62 | //BOOST_STATIC_CONSTANT(bool, has_fixed_range = false); 63 | /** 64 | * Returns the smallest value that the generator can produce 65 | */ 66 | static double min BOOST_PREVENT_MACRO_SUBSTITUTION () { return 0.0; } 67 | /** 68 | * Returns the largest value that the generator can produce 69 | */ 70 | static double max BOOST_PREVENT_MACRO_SUBSTITUTION () 71 | { return 1.0; } // or 2^24? 72 | 73 | /** Seeds the generator with the default seed. */ 74 | rngstream() : RngStream("") { } 75 | 76 | // compiler-generated copy ctor and assignment operator are fine 77 | 78 | /** Seeds the generator with the default seed. */ 79 | void seed() { 80 | unsigned long seed[6]; 81 | for (int i = 0; i<6; i++) 82 | seed[i] = 12345ul; 83 | SetSeed(seed); 84 | } 85 | 86 | /** Returns the next value of the generator. */ 87 | double operator()() { return RandU01(); } 88 | 89 | /** Fills a range with random values */ 90 | template 91 | void generate(Iter first, Iter last) 92 | { 93 | for(; first != last; ++first) { 94 | *first = (*this)(); 95 | } 96 | } 97 | 98 | #ifndef BOOST_RANDOM_NO_STREAM_OPERATORS 99 | /** Writes a @c rngstream to a @c std::ostream. */ 100 | template 101 | friend std::basic_ostream& 102 | operator<<(std::basic_ostream& os, const rngstream& r) 103 | { 104 | unsigned long seed[6]; 105 | r.GetState (seed); 106 | for (int i = 0; i<5; i++) 107 | os << seed[i] << ' '; 108 | os << seed[5]; 109 | return os; 110 | } 111 | 112 | /** Reads a @c rngstream from a @c std::istream. */ 113 | template 114 | friend std::basic_istream& 115 | operator>>(std::basic_istream& is, rngstream& r) 116 | { 117 | unsigned long seed[6]; 118 | for (int i = 0; i<6; i++) 119 | is >> seed[i]; 120 | r.SetSeed(seed); 121 | return is; 122 | } 123 | #endif 124 | 125 | /** 126 | * Returns true if the two generators will produce identical 127 | * sequences of values. 128 | */ 129 | friend bool operator==(const rngstream& x, const rngstream& y) 130 | { 131 | unsigned long seedx[6], seedy[6]; 132 | x.GetState (seedx); 133 | y.GetState (seedy); 134 | for (int i = 0; i<6; i++) 135 | if (seedx[i] != seedy[i]) 136 | return false; 137 | return true; 138 | } 139 | /** 140 | * Returns true if the two generators will produce different 141 | * sequences of values. 142 | */ 143 | friend bool operator!=(const rngstream& x, const rngstream& y) 144 | { return !(x == y); } 145 | }; 146 | 147 | } // namespace random 148 | 149 | using random::rngstream; 150 | 151 | } // namespace boost 152 | 153 | #include 154 | 155 | #endif // BOOST_RANDOM_RNGSTREAM_BOOST_HPP 156 | -------------------------------------------------------------------------------- /src/rngstream-example.cpp: -------------------------------------------------------------------------------- 1 | 2 | #include "rngstream-boost.hpp" 3 | #include 4 | #include 5 | 6 | int main() { 7 | boost::rngstream gen, gen2; 8 | boost::uniform_01<> dist; 9 | std::cout << gen2 << std::endl; 10 | std::cout << "Expected: 0.127011; observed: " << dist(gen) << std::endl; 11 | std::cout << "Expected: 0.759582; observed: " << dist(gen2) << std::endl; 12 | gen.ResetNextSubstream(); 13 | std::cout << "Expected: 0.079399; observed: " << dist(gen) << std::endl; 14 | std::cout << gen << std::endl; 15 | return 0; 16 | } 17 | // R -q -e "require(parallel); base=c(407L,rep(12345L,6)); .Random.seed=base; runif(2); .Random.seed=nextRNGStream(base); runif(2); .Random.seed=nextRNGSubStream(base); runif(2)" 18 | -------------------------------------------------------------------------------- /src/simple-example.cc: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | namespace { 4 | 5 | enum state_t {Healthy,Cancer,Death}; 6 | 7 | enum event_t {toOtherDeath, toCancer, toCancerDeath}; 8 | 9 | typedef std::map > Report; 10 | 11 | class SimplePerson : public ssim::cProcess 12 | { 13 | public: 14 | int id; 15 | state_t state; 16 | Report report; 17 | SimplePerson() : id(-1) {}; 18 | void init(); 19 | virtual void handleMessage(const ssim::cMessage* msg); 20 | void reporting(string name, double value); 21 | }; 22 | 23 | /** 24 | Initialise a simulation run for an individual 25 | */ 26 | void SimplePerson::init() { 27 | id++; 28 | state = Healthy; 29 | double tm = R::rweibull(8.0,85.0); 30 | scheduleAt(tm,toOtherDeath); 31 | scheduleAt(R::rweibull(3.0,90.0),toCancer); 32 | } 33 | 34 | void SimplePerson::reporting(std::string name, double value) { 35 | report[name].push_back(value); 36 | } 37 | 38 | /** 39 | Handle receiving self-messages 40 | */ 41 | void SimplePerson::handleMessage(const ssim::cMessage* msg) { 42 | 43 | reporting("id", double(id)); 44 | reporting("startTime", previousEventTime); 45 | reporting("endtime", ssim::now()); 46 | reporting("state", double(state)); 47 | reporting("event", double(msg->kind)); 48 | 49 | switch(msg->kind) { 50 | 51 | case toOtherDeath: 52 | case toCancerDeath: 53 | ssim::Sim::stop_process(); 54 | break; 55 | 56 | case toCancer: 57 | state = Cancer; 58 | if (R::runif(0.0,1.0) < 0.5) 59 | scheduleAt(ssim::now() + R::rweibull(2.0,10.0), toCancerDeath); 60 | break; 61 | 62 | default: 63 | REprintf("No valid kind of event\n"); 64 | break; 65 | 66 | } // switch 67 | 68 | if (id % 10000 == 0) Rcpp::checkUserInterrupt(); 69 | 70 | } // handleMessage() 71 | 72 | RcppExport SEXP callSimplePerson(SEXP parms) { 73 | SimplePerson person; 74 | Rcpp::RNGScope scope; 75 | Rcpp::List parmsl(parms); 76 | int n = Rcpp::as(parmsl["n"]); 77 | for (int i = 0; i < n; i++) { 78 | ssim::Sim::create_process(&person); 79 | ssim::Sim::run_simulation(); 80 | ssim::Sim::clear(); 81 | } 82 | return Rcpp::wrap(person.report); 83 | } 84 | 85 | } // anonymous namespace 86 | -------------------------------------------------------------------------------- /src/simple-example2.cc: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | namespace { 4 | 5 | using namespace std; 6 | using namespace ssim; 7 | 8 | enum state_t {Healthy,Cancer,Death}; 9 | 10 | enum event_t {toOtherDeath, toCancer, toCancerDeath}; 11 | 12 | class SimplePerson : public cProcess 13 | { 14 | public: 15 | state_t state; 16 | int id; 17 | SimplePerson(const int i = 0) : id(i) {}; 18 | void init(); 19 | virtual void handleMessage(const cMessage* msg); 20 | static EventReport report; 21 | }; 22 | 23 | EventReport SimplePerson::report; 24 | 25 | /** 26 | Initialise a simulation run for an individual 27 | */ 28 | void SimplePerson::init() { 29 | state = Healthy; 30 | scheduleAt(R::rweibull(8.0,85.0),toOtherDeath); 31 | scheduleAt(R::rweibull(3.0,90.0),toCancer); 32 | } 33 | 34 | /** 35 | Handle receiving self-messages 36 | */ 37 | void SimplePerson::handleMessage(const cMessage* msg) { 38 | 39 | SimplePerson::report.add(state,msg->kind,previousEventTime,now()); 40 | 41 | switch(msg->kind) { 42 | 43 | case toOtherDeath: 44 | case toCancerDeath: 45 | Sim::stop_process(); 46 | break; 47 | 48 | case toCancer: 49 | state = Cancer; 50 | if (R::runif(0.0,1.0) < 0.5) 51 | scheduleAt(now() + R::rweibull(2.0,10.0), toCancerDeath); 52 | break; 53 | 54 | default: 55 | REprintf("No valid kind of event\n"); 56 | break; 57 | 58 | } // switch 59 | 60 | } // handleMessage() 61 | 62 | RcppExport SEXP callSimplePerson2(SEXP parms) { 63 | SimplePerson person; 64 | Rcpp::RNGScope scope; 65 | Rcpp::List parmsl(parms); 66 | int n = Rcpp::as(parmsl["n"]); 67 | 68 | SimplePerson::report.clear(); 69 | vector ages; 70 | for (double age=0.0; age<=100.0; age++) { 71 | ages.push_back(age); 72 | } 73 | ages.push_back(1.0e+6); 74 | SimplePerson::report.setPartition(ages); 75 | 76 | for (int i = 0; i < n; i++) { 77 | person = SimplePerson(i); 78 | Sim::create_process(&person); 79 | Sim::run_simulation(); 80 | Sim::clear(); 81 | } 82 | return SimplePerson::report.wrap(); 83 | } 84 | 85 | } // namespace simpleExample2 86 | -------------------------------------------------------------------------------- /src/splines.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | namespace ssim { 4 | 5 | // mat qr_q(const mat& X, double tol) { 6 | // Rcpp::NumericMatrix nmX = Rcpp::as(Rcpp::wrap(X)); 7 | // Rcpp::NumericMatrix nmQ = qr_q(nmX, tol); 8 | // return Rcpp::as(Rcpp::wrap(nmQ)); 9 | // } 10 | 11 | SplineBasis::SplineBasis(int order) : order(order) { 12 | ordm1 = order - 1; 13 | rdel = arma::vec(ordm1); 14 | ldel = arma::vec(ordm1); 15 | a = arma::vec(order); 16 | } 17 | SplineBasis::SplineBasis(arma::vec knots, int order) : order(order), knots(knots) { 18 | ordm1 = order - 1; 19 | nknots = knots.size(); 20 | ncoef = nknots - order; 21 | rdel = arma::vec(ordm1); 22 | ldel = arma::vec(ordm1); 23 | a = arma::vec(order); 24 | } 25 | int SplineBasis::set_cursor(double x) 26 | { 27 | int i; 28 | /* don't assume x's are sorted */ 29 | curs = -1; /* Wall */ 30 | boundary = 0; 31 | for (i = 0; i < nknots; i++) { 32 | if (knots(i) >= x) curs = i; 33 | if (knots(i) > x) break; 34 | } 35 | if (curs > nknots - order) { 36 | int lastLegit = nknots - order; 37 | if (x == knots(lastLegit)) { 38 | boundary = 1; curs = lastLegit; 39 | } 40 | } 41 | return curs; 42 | } 43 | void 44 | SplineBasis::diff_table(double x, int ndiff) 45 | { 46 | int i; 47 | for (i = 0; i < ndiff; i++) { 48 | rdel(i) = knots(curs + i) - x; 49 | ldel(i) = x - knots(curs - (i + 1)); 50 | } 51 | } 52 | double SplineBasis::slow_evaluate(double x, int nder) 53 | { 54 | int ti = curs, 55 | lpt, apt, rpt, inner, 56 | outer = ordm1; 57 | if (boundary && nder == ordm1) { /* value is arbitrary */ 58 | return double(0); 59 | } 60 | while(nder--) { // FIXME: divides by zero 61 | for(inner = outer, apt = 0, lpt = ti - outer; inner--; apt++, lpt++) 62 | a(apt) = double(outer) * (a(apt + 1) - a(apt))/(knots(lpt + outer) - knots(lpt)); 63 | outer--; 64 | } 65 | diff_table(x, outer); 66 | while(outer--) 67 | for(apt = 0, lpt = outer, rpt = 0, inner = outer + 1; 68 | inner--; lpt--, rpt++, apt++) 69 | // FIXME: divides by zero 70 | a(apt) = (a(apt + 1) * ldel(lpt) + a(apt) * rdel(rpt))/(rdel(rpt) + ldel(lpt)); 71 | return a(0); 72 | } 73 | /* fast evaluation of basis functions */ 74 | arma::vec SplineBasis::basis_funcs(double x) 75 | { 76 | arma::vec b(order); 77 | diff_table(x, ordm1); 78 | b(0) = double(1); 79 | for (size_t j = 1; j <= (size_t)ordm1; j++) { 80 | double saved = double(0); 81 | for (size_t r = 0; r < j; r++) { // do not divide by zero 82 | double den = rdel(r) + ldel(j - 1 - r); 83 | if(den != double(0)) { 84 | double term = b(r)/den; 85 | b(r) = saved + rdel(r) * term; 86 | saved = ldel(j - 1 - r) * term; 87 | } else { 88 | if(r != double(0) || rdel(r) != double(0)) 89 | b(r) = saved; 90 | saved = double(0); 91 | } 92 | } 93 | b(j) = saved; 94 | } 95 | return b; 96 | } 97 | arma:: vec SplineBasis::eval(double x, int ders) { 98 | arma::vec val(ncoef); 99 | val = arma::zeros(ncoef); 100 | set_cursor(x); 101 | int io = curs - order; 102 | if (io < 0 || io > nknots) { 103 | for (size_t j = 0; j < (size_t)order; j++) { 104 | val(j+io) = double(0); // R_NaN; 105 | } 106 | } else if (ders > 0) { /* slow method for derivatives */ 107 | for(size_t i = 0; i < (size_t)order; i++) { 108 | for(size_t j = 0; j < (size_t)order; j++) a(j) = double(0); 109 | a(i) = double(1); 110 | val(i+io) = slow_evaluate(x, ders); 111 | } 112 | } else { /* fast method for value */ 113 | arma::vec valtmp = basis_funcs(x); 114 | for (size_t i=0; inknots = interior_knots.size()+8; 135 | this->ncoef = this->nknots - this->order; 136 | this->knots = arma::vec(this->nknots); 137 | for(size_t i=0; i<4;i++) { 138 | this->knots(i)=boundary_knots(0); 139 | this->knots(this->nknots-i-1)=boundary_knots(1); 140 | } 141 | if (interior_knots.size() > 0) 142 | for(size_t i=0; iknots(i+4)=interior_knots(i); 144 | } 145 | arma::vec bs::eval(double x, int ders) { 146 | arma::vec v; 147 | if (xboundary_knots(1)) { 156 | double k_pivot = double(0.75)*boundary_knots(1)+double(0.25)*interior_knots(interior_knots.size()-1); 157 | double delta = x - k_pivot; 158 | v = bs::eval(k_pivot,0) + 159 | bs::eval(k_pivot,1)*delta + 160 | bs::eval(k_pivot,2)*delta*delta/2. + 161 | bs::eval(k_pivot,3)*delta*delta*delta/6.; 162 | } 163 | else { 164 | v = SplineBasis::eval(x, ders).subvec(1-intercept,df-intercept); 165 | } 166 | return v; 167 | } 168 | arma::mat bs::basis(arma::vec x, int ders) { 169 | arma::mat m(x.size(), df); 170 | for (size_t i=0; iboundary_knots(0)) { 206 | if (der==0) 207 | return tl0 + (x - this->boundary_knots(0))*tl1; 208 | else if (der==1) 209 | return tl1; 210 | else return tl1*double(0); 211 | } else if (x > this->boundary_knots(1)) { 212 | if (der==0) 213 | return tr0 + (x - this->boundary_knots(1))*tr1; 214 | else if (der==1) 215 | return tr1; 216 | else return tr1*double(0); 217 | } 218 | else return q_matrix * bs::eval(x,der); 219 | } 220 | arma::mat ns::basis(arma::vec x, int ders) { 221 | arma::mat m(x.size(), this->df-2-cure); 222 | for (size_t i=0; i 10 | // See AUTHORS for full details. 11 | // 12 | // SSim is free software: you can redistribute it and/or modify it under 13 | // the terms of the GNU General Public License as published by the Free 14 | // Software Foundation, either version 3 of the License, or (at your 15 | // option) any later version. 16 | // 17 | // SSim is distributed in the hope that it will be useful, 18 | // but WITHOUT ANY WARRANTY; without even the implied warranty of 19 | // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 20 | // GNU General Public License for more details. 21 | // 22 | // You should have received a copy of the GNU General Public License 23 | // along with SSim. If not, see . 24 | // 25 | #include 26 | 27 | #include 28 | #include 29 | #include 30 | 31 | namespace ssim { 32 | 33 | // these are the "private" static variables and types of the Sim class 34 | // 35 | static Time stop_time = INIT_TIME; 36 | static Time current_time = INIT_TIME; 37 | 38 | static ProcessId current_process = NULL_PROCESSID; 39 | 40 | static bool running = false; 41 | 42 | static SimErrorHandler * error_handler = 0; 43 | 44 | enum ActionType { 45 | A_Event, 46 | A_Init, 47 | A_Stop, 48 | A_Ignore 49 | }; 50 | 51 | struct Action { 52 | Time time; 53 | ActionType type; 54 | ProcessId pid; 55 | const Event * event; 56 | 57 | Action(Time t, ActionType at, ProcessId p, const Event * e = 0) throw() 58 | : time(t), type(at), pid(p), event(e) {}; 59 | 60 | bool operator < (const Action & a) const throw() { 61 | return time < a.time || (time == a.time && event->priority < a.event->priority); 62 | } 63 | }; 64 | 65 | typedef heap a_table_t; 66 | 67 | static a_table_t actions; 68 | 69 | struct PDescr { 70 | Process * process; 71 | bool terminated; 72 | Time available_at; 73 | 74 | PDescr(Process * p) 75 | : process(p), terminated(false), available_at(INIT_TIME) {} 76 | }; 77 | 78 | typedef std::vector PsTable; 79 | static PsTable processes; 80 | 81 | void Rprint_actions() { 82 | Rprintf("\n["); 83 | for (a_table_t::iterator it = actions.begin(); it != actions.end(); it++) 84 | Rprintf("(time=%f,%s), ",it->time, it->event->str().c_str()); 85 | Rprintf("]\n"); 86 | } 87 | 88 | 89 | 90 | class SimImpl { 91 | public: 92 | static void schedule(Time t, ActionType i, ProcessId p, 93 | const Event * e = 0) throw() { 94 | if (e != 0) { 95 | ++(e->refcount); 96 | } 97 | actions.insert(Action(current_time + t, i, p, e )); 98 | } 99 | static void schedule_now(ActionType i, ProcessId p, 100 | const Event * e = 0) throw() { 101 | if (e != 0) { 102 | ++(e->refcount); 103 | } 104 | actions.insert(Action(current_time, i, p, e )); 105 | } 106 | }; 107 | 108 | ProcessId Sim::create_process(Process * p) throw() { 109 | processes.push_back(PDescr(p)); 110 | ProcessId newpid = processes.size() - 1; 111 | SimImpl::schedule_now(A_Init, newpid); 112 | return newpid; 113 | } 114 | 115 | void Sim::clear() throw() { 116 | running = false; 117 | current_time = INIT_TIME; 118 | current_process = NULL_PROCESSID; 119 | processes.clear(); 120 | if (error_handler) error_handler->clear(); 121 | for(a_table_t::iterator a = actions.begin(); a != actions.end(); ++a) { 122 | const Event * e = (*a).event; 123 | if (e != 0 && --(e->refcount) == 0) 124 | delete(e); 125 | } 126 | actions.clear(); 127 | } 128 | 129 | typedef a_table_t::iterator ForwardIterator; 130 | 131 | void Sim::ignore_event(EventPredicate pred) throw() { 132 | for (ForwardIterator it = actions.begin(); it != actions.end(); it++) { 133 | if ((*it).type == A_Event) { 134 | const Event * e = (*it).event; 135 | if (e != 0) { 136 | if(pred(e)) { 137 | (*it).type = A_Ignore; 138 | } 139 | } 140 | } 141 | } 142 | } 143 | 144 | 145 | // 146 | // this is the simulator main loop. 147 | // 148 | void Sim::run_simulation() { 149 | // 150 | // prevents anyone from re-entering the main loop. Note that this 151 | // isn't meant to be thread-safe, it works if some process calls 152 | // Sim::run_simulation() within their process_event() function. 153 | // 154 | static bool lock = false; 155 | if (lock) return; 156 | lock = true; 157 | running = true; 158 | 159 | // 160 | // while there is at least a scheduled action 161 | // 162 | while (running && !actions.empty()) { 163 | // 164 | // I'm purposely excluding any kind of checks in this version 165 | // of the simulator. 166 | // 167 | // I should say something like this: 168 | // assert(current_time <= (*a).first); 169 | // 170 | Action action = actions.pop_first(); 171 | if (action.type == A_Ignore) { 172 | if (action.event != 0) 173 | if (--(action.event->refcount) == 0) 174 | delete(action.event); 175 | } 176 | else { 177 | current_time = action.time; 178 | if (stop_time != INIT_TIME && current_time > stop_time) 179 | break; 180 | current_process = action.pid; 181 | // 182 | // right now I don't check if current_process is indeed a 183 | // valid process. Keep in mind that this is the heart of the 184 | // simulator main loop, therefore efficiency is crucial. 185 | // Perhaps I should check. This is somehow a design choice. 186 | // 187 | PDescr & pd = processes[current_process]; 188 | 189 | if (pd.terminated) { 190 | if (error_handler) 191 | error_handler->handle_terminated(current_process, 192 | action.event); 193 | } else if (current_time < pd.available_at) { 194 | if (error_handler) 195 | error_handler->handle_busy(current_process, action.event); 196 | } else { 197 | switch (action.type) { 198 | case A_Event: 199 | pd.process->process_event(action.event); 200 | break; 201 | case A_Init: 202 | pd.process->initialize(); 203 | break; 204 | case A_Stop: 205 | pd.process->stop(); 206 | // 207 | // here we must use processes[current_process] instead 208 | // of pd since pd.process->stop() might have added or 209 | // removed processes, and therefore resized the 210 | // processes vector, rendering pd invalid 211 | // 212 | processes[current_process].terminated = true; 213 | break; 214 | default: 215 | // 216 | // add paranoia checks/logging here? 217 | // 218 | break; 219 | } 220 | // here we must use processes[current_process] instead of 221 | // pd. Same reason as above. the "processes" vector might 222 | // have been modified and, as a consequence, resized. So, 223 | // pd may no longer be considered a valid reference. 224 | // 225 | processes[current_process].available_at = current_time; 226 | } 227 | 228 | if (action.event != 0) 229 | if (--(action.event->refcount) == 0) 230 | delete(action.event); 231 | } 232 | } 233 | lock = false; 234 | running = false; 235 | } 236 | 237 | void Sim::set_stop_time(Time t) throw() { 238 | stop_time = t; 239 | } 240 | 241 | void Sim::stop_process() throw() { 242 | SimImpl::schedule_now(A_Stop, current_process); 243 | } 244 | 245 | int Sim::stop_process(ProcessId pid) throw() { 246 | if (processes[pid].terminated) return -1; 247 | SimImpl::schedule_now(A_Stop, pid); 248 | return 0; 249 | } 250 | 251 | void Sim::stop_simulation() throw() { 252 | running = false; 253 | } 254 | 255 | void Sim::advance_delay(Time delay) throw() { 256 | if (!running) return; 257 | current_time += delay; 258 | } 259 | 260 | ProcessId Sim::this_process() throw() { 261 | return current_process; 262 | } 263 | 264 | Time Sim::clock() throw() { 265 | return current_time; 266 | } 267 | 268 | void Sim::self_signal_event(const Event * e) throw() { 269 | SimImpl::schedule_now(A_Event, current_process, e); 270 | } 271 | 272 | void Sim::self_signal_event(const Event * e, Time d) throw() { 273 | SimImpl::schedule(d, A_Event, current_process, e); 274 | } 275 | 276 | void Sim::signal_event(ProcessId pid, const Event * e) throw() { 277 | SimImpl::schedule_now(A_Event, pid, e); 278 | } 279 | 280 | void Sim::signal_event(ProcessId pid, const Event * e, Time d) throw() { 281 | SimImpl::schedule(d, A_Event, pid, e); 282 | } 283 | 284 | void Sim::set_error_handler(SimErrorHandler * eh) throw() { 285 | error_handler = eh; 286 | } 287 | 288 | ProcessId ProcessWithPId::activate() throw() { 289 | if (process_id == NULL_PROCESSID) { 290 | return process_id = Sim::create_process(this); 291 | } else { 292 | return NULL_PROCESSID; 293 | } 294 | } 295 | 296 | ProcessWithPId::ProcessWithPId() throw(): process_id(NULL_PROCESSID) {} 297 | 298 | ProcessId ProcessWithPId::pid() const throw() { 299 | return process_id; 300 | } 301 | 302 | } // namespace ssim 303 | -------------------------------------------------------------------------------- /test/Rcpp-tests.R: -------------------------------------------------------------------------------- 1 | require(Rcpp) 2 | require(inline) 3 | require(R.utils) 4 | 5 | ########################### 6 | ## Test Table ## 7 | ########################### 8 | 9 | testTable2 <- function(...) R.utils::intToBin(testTable(...)) 10 | 11 | src <- ' 12 | #include 13 | #include "/home/marcle/src/R/microsimulation/src/rcpp_table.h" 14 | // [[Rcpp::export]] 15 | SEXP testTable(DataFrame d, double x) { 16 | Table lookup(d,"x","y"); 17 | return wrap(lookup(x)); 18 | } 19 | ' 20 | sourceCpp(code=src) 21 | lookup <- data.frame(x=0:1,y=0:1) 22 | testTable2(lookup,-1) 23 | testTable2(lookup,0) 24 | testTable2(lookup,0.1) 25 | testTable2(lookup,2) 26 | 27 | src <- ' 28 | #include 29 | #include "/home/marcle/src/R/microsimulation/src/rcpp_table.h" 30 | using namespace std; 31 | // [[Rcpp::export]] 32 | SEXP testTable(DataFrame d, double x, double y) { 33 | Table lookup(d,"x","y","z"); 34 | return wrap(lookup(x,y)); 35 | } 36 | ' 37 | sourceCpp(code=src) 38 | lookup <- transform(expand.grid(data.frame(x=0:1,y=0:1)),z=0:3) 39 | testTable2(lookup,-1,-1) 40 | testTable2(lookup,0,0) 41 | testTable2(lookup,1,0) 42 | testTable2(lookup,0,1) 43 | testTable2(lookup,2,2) 44 | 45 | src <- ' 46 | #include 47 | #include "/home/marcle/src/R/microsimulation/src/rcpp_table.h" 48 | #include 49 | typedef boost::tuple Tuple; 50 | // [[Rcpp::export]] 51 | SEXP testTable(DataFrame d, double x, double y, double z) { 52 | Table lookup(d,"x","y","z","val"); 53 | return wrap(lookup(x,y,z)); 54 | } 55 | ' 56 | sourceCpp(code=src) 57 | lookup <- transform(expand.grid(data.frame(x=0:1,y=0:1,z=0:1)),val=0:7) 58 | testTable2(lookup,-1,-1,-1) 59 | testTable2(lookup,0,0,0) 60 | testTable2(lookup,1,0,1) 61 | testTable2(lookup,0,1,2) 62 | testTable2(lookup,2,2,2) 63 | 64 | src <- ' 65 | #include 66 | #include "/home/marcle/src/R/microsimulation/src/rcpp_table.h" 67 | #include 68 | typedef boost::tuple Tuple; 69 | // [[Rcpp::export]] 70 | SEXP testTable(DataFrame d, double x, double y, double z, double a) { 71 | Table lookup(d,"x","y","z","a","val"); 72 | return wrap(lookup(x,y,z,a)); 73 | } 74 | ' 75 | sourceCpp(code=src) 76 | lookup <- data.frame(expand.grid(data.frame(x=0:1,y=0:1,z=0:1,a=0:1)),val=0:15) 77 | testTable2(lookup,-1,-1,-1,-1) 78 | testTable2(lookup,0,0,0,0) 79 | testTable2(lookup,1,0,1,1) 80 | testTable2(lookup,0,1,2,2) 81 | testTable2(lookup,2,2,2,3) 82 | 83 | src <- ' 84 | #include 85 | #include "/home/marcle/src/R/microsimulation/src/rcpp_table.h" 86 | #include 87 | typedef boost::tuple Tuple; 88 | // [[Rcpp::export]] 89 | SEXP testTable(DataFrame d, double x, double y, double z, double a, double b) { 90 | Table lookup(d,"x","y","z","a","b","val"); 91 | return wrap(lookup(x,y,z,a,b)); 92 | } 93 | ' 94 | sourceCpp(code=src) 95 | lookup <- data.frame(expand.grid(data.frame(x=0:1,y=0:1,z=0:1,a=0:1,b=0:1)),val=0:31) 96 | testTable2(lookup,-1,-1,-1,-1,-1) 97 | testTable2(lookup,0,0,0,0,0) 98 | testTable2(lookup,1,0,1,1,0) 99 | testTable2(lookup,0,1,2,2,2) 100 | testTable2(lookup,2,2,2,3,3) 101 | 102 | 103 | -------------------------------------------------------------------------------- /test/RngStream-revised.h: -------------------------------------------------------------------------------- 1 | 2 | 3 | #ifndef RNGSTREAM_H 4 | #define RNGSTREAM_H 5 | 6 | #include 7 | 8 | class RngStream 9 | { 10 | public: 11 | 12 | RngStream (const char *name = ""); 13 | 14 | 15 | static bool SetPackageSeed (const unsigned long seed[6]); 16 | 17 | 18 | void ResetStartStream (); 19 | 20 | 21 | void ResetStartSubstream (); 22 | 23 | 24 | void ResetNextSubstream (); 25 | 26 | 27 | void SetAntithetic (bool a); 28 | 29 | 30 | void IncreasedPrecis (bool incp); 31 | 32 | 33 | bool SetSeed (const unsigned long seed[6]); 34 | 35 | 36 | void AdvanceState (long e, long c); 37 | 38 | 39 | void GetState (unsigned long seed[6]) const; 40 | 41 | 42 | void WriteState () const; 43 | 44 | 45 | void WriteStateFull () const; 46 | 47 | 48 | double RandU01 (); 49 | 50 | 51 | unsigned long U (); 52 | 53 | 54 | int RandInt (int i, int j); 55 | 56 | 57 | 58 | private: 59 | 60 | double Cg[6], Bg[6], Ig[6]; 61 | 62 | 63 | bool anti, incPrec; 64 | 65 | 66 | std::string name; 67 | 68 | 69 | static double nextSeed[6]; 70 | 71 | 72 | double U01 (); 73 | 74 | 75 | double U01d (); 76 | 77 | 78 | }; 79 | 80 | #endif 81 | 82 | 83 | -------------------------------------------------------------------------------- /test/TODO.org: -------------------------------------------------------------------------------- 1 | #+TAGS: Mark Andreas 2 | #+TODO: Todo: Ongoing: | Done: 3 | * PSA validation 4 | ** Validation of microsimulation PSA-testing by age and psa 5 | + Compared with STHLM0, the microsimulation has too many low PSA (PSA<3) and too few high 6 | PSA (PSA>3); this is true for both testing proportions 7 | and test rates. 8 | + In summary, there is evidence that high PSA values are 9 | under-represented in the microsimulation. This is predicated on the 10 | STHLM0 data being correct; there is reasonable face validity with 11 | other data sources, although we note that direct comparisons are 12 | not straightforward. 13 | + Code at [[~/src/ki/STHLM0/PSArateByAge.R][~/src/ki/STHLM0/PSArateByAge.R]] 14 | + Result at 15 | [[~/src/ki/STHLM0/psaRatesByPSA.pdf]] 16 | 17 | ** PSA sub-model validation with external code 18 | + Re-running the PSA longitudinal sub-model separately, we found that 19 | a high proportion of men aged 70+ years had PSA 10+; in contrast, 20 | the simulation for "screenUptake" had few men with PSA 10+ for the 21 | older men. This did not restrict for previous prostate cancer diagnosis. 22 | + This could be partial explained by a loss of high PSA 23 | values due to earlier diagnosis. 24 | + Code at [[~/src/ki/microsimulation/test/test_microsimulation.R][~/src/ki/microsimulation/test/test_microsimulation.R]] 25 | ** Comparison with NHANES data 26 | + STHLM0 looked reasonable compared to the American data. A direct 27 | comparison was difficult, as the NHANES was a survey of healthy 28 | men, while the STHLM0 is based on men who were tested (or 29 | re-tested) for prostate cancer; men who had a low PSA test prior to 30 | 2003 may be under-represented by the men tested since 2003. This is 31 | an interesting estimation problem -- that is, how can we estimate 32 | cross-sectional estimates from testing data? 33 | + Code at [[~/src/ki/NHANES/PSA_distribution.R][~/src/ki/NHANES/PSA_distribution.R]] 34 | ** Comparing PSA testing proportions 35 | + NHANES compared with parameter (cancer onset) 36 | + First test, fixes 10 65) 107 | + Model of all PSA-testing based on PCa incidence in Stockholm. 108 | + Use STHLM0, 2003-now, to get PSA re-testing patterns per integer 109 | year and age (PSA-value?). Use start of uptake to year-be-year 110 | introduce possible retesting. 111 | + Question :: What do we do with the PSA-values for the missing data 112 | 1993-2003? Can we assume something reasonable or should/can we 113 | skip the PSA-dependence? 114 | + Reference :: 115 | + Jonsson 2011 116 | [[file:~/KI/Literature/jonsson_uptake_2011.pdf]] 117 | + Mariotto 2007 118 | [[file:~/KI/Literature/mariotto_reconstructing_2007.pdf]] 119 | *** Additional stories 120 | This could be additional angles in the paper or separate publications. 121 | 1) Reconstruct overall PSA-testing in Swedish counties using observed 122 | PCa prevalence. 123 | 2) Reconstruct overall PSA-testing in Great Britain using observed 124 | PCa prevalence. 125 | + Question :: Can we do predictions on uptake & re-testing using 126 | STHLM0 data on these other regions? 127 | ** Nordic Natural history "base of the pyramid" :Andreas: 128 | Calibrations and adaptions 129 | + PSA x Gleason? 130 | + Gleason incidence 131 | How does the distributions compare with e.g. the US 132 | + PSA proportions by age & gleason 133 | [[file:~/src/ki/STHLM0/gleasonFitting.R]] 134 | [[file:~/src/ki/STHLM0/gleasonFittedFinal.pdf]] 135 | + Survival calibration 136 | PCBase vs SEER (old gleason 6+7 and 8) prior to PSA 137 | [[file:~/src/ki/diagnoses/stage_shift_calibrated.pdf]] 138 | [[file:~/src/ki/diagnoses/PCbaseHR.R]] 139 | + Effectiveness only? 140 | - Tx by Gleason & age - Mark 141 | - PSA uptake 142 | - Pop 143 | - Mortality other causes 144 | - Re-testing 145 | + Issues :: incidence by gleason 146 | + Story :: Region specific incidence (e.g. US vs Sweden) 147 | - why is Nordic so different? 148 | - Is this due to good data? 149 | + Reference :: Mariotto 2007 150 | [[file:~/KI/Literature/mariotto_reconstructing_2007.pdf]] 151 | + Heat map 152 | + Compare with US parameters?? 153 | ** Organised vs opportunistic 154 | MISCAN ERSPC 155 | CEA 156 | ** S3M "Polish Vodka" 157 | + $H_0:S3M vs PSA 158 | + effectiveness 159 | + costs 160 | + with baseline scenario 161 | - Simplified "current" *Mark?* 162 | Baseline STHLM3 CEA ICERs! Uncertainties. Is it obvious that S3M 163 | is effective? 164 | + Is S3M "PSA-like" 165 | + Sensitivity analysis for S3M long-term effectiveness. 166 | + Comparison with evaluation of PHI & 4K? 167 | ** Misc 168 | STHLM3 lower PSA + S3M? 169 | + How was the threshold determined? 170 | -------------------------------------------------------------------------------- /test/cluster.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | #PBS -o CLUSTER 3 | #PBS -j oe 4 | #PBS -m abe 5 | #PBS -M mark.clements@ki.se 6 | module load Apps/R/3.0.2 7 | module load Rpkgs/DOSNOW 8 | module load Rpkgs/RMPI 9 | module add Rpkgs/RCPP/1.11.1 10 | cd $PBS_O_WORKDIR 11 | mpirun -n 1 R --slave -f cluster_mic.R 12 | -------------------------------------------------------------------------------- /test/cluster_mic.R: -------------------------------------------------------------------------------- 1 | library(Rmpi) 2 | library(snow) 3 | library(parallel) 4 | require(microsimulation) 5 | 6 | mc.cores <- max(1, mpi.universe.size() - 1) 7 | cl <- makeMPIcluster(mc.cores) 8 | cat(sprintf("Running with %d workers\n", length(cl))) 9 | clusterCall(cl, function() { library(microsimulation); NULL }) 10 | 11 | callFhcrc <- 12 | function (n = 10, screen = "noScreening", nLifeHistories = 10, 13 | screeningCompliance = 0.75, seed = 12345, studyParticipation = 50/260, 14 | psaThreshold = 3, mc.cores, cl) 15 | { 16 | state <- RNGstate() 17 | on.exit(state$reset()) 18 | RNGkind("user") 19 | set.user.Random.seed(seed) 20 | pop1 <- data.frame(cohort = 1980:1900, pop = c(rep(17239, 21 | 9), 16854, 16085, 15504, 15604, 16381, 16705, 16762, 22 | 16853, 15487, 14623, 14066, 13568, 13361, 13161, 13234, 23 | 13088, 12472, 12142, 12062, 12078, 11426, 12027, 11963, 24 | 12435, 12955, 13013, 13125, 13065, 12249, 11103, 9637, 25 | 9009, 8828, 8350, 7677, 7444, 7175, 6582, 6573, 6691, 26 | 6651, 6641, 6268, 6691, 6511, 6857, 7304, 7308, 7859, 27 | 7277, 8323, 8561, 7173, 6942, 7128, 6819, 5037, 6798, 28 | rep(6567, 14))) 29 | screenT <- c("noScreening", "randomScreen50to70", "twoYearlyScreen50to70", 30 | "fourYearlyScreen50to70", "screen50", "screen60", "screen70", 31 | "screenUptake", "stockholm3_goteborg", "stockholm3_risk_stratified") 32 | stateT <- c("Healthy", "Localised", "Metastatic") 33 | gradeT <- c("Gleason_le_6", "Gleason_7", "Gleason_ge_8") 34 | eventT <- c("toLocalised", "toMetastatic", "toClinicalDiagnosis", 35 | "toCancerDeath", "toOtherDeath", "toScreen", "toBiopsy", 36 | "toScreenDiagnosis", "toOrganised", "toTreatment", "toCM", 37 | "toRP", "toRT", "toADT") 38 | diagnosisT <- c("NotDiagnosed", "ClinicalDiagnosis", "ScreenDiagnosis") 39 | treatmentT <- c("CM", "RP", "RT") 40 | psaT <- c("PSA<3", "PSA>=3") 41 | stopifnot(screen %in% screenT) 42 | stopifnot(is.na(n) || is.integer(as.integer(n))) 43 | stopifnot(is.integer(as.integer(nLifeHistories))) 44 | stopifnot(is.double(as.double(screeningCompliance))) 45 | screenIndex <- which(screen == screenT) - 1 46 | if (is.na(n)) { 47 | cohort <- pop1$cohort[rep.int(1:nrow(pop1), times = pop1$pop)] 48 | n <- length(cohort) 49 | } 50 | else cohort <- sample(pop1$cohort, n, prob = pop1$pop/sum(pop1$pop), 51 | replace = TRUE) 52 | cohort <- sort(cohort) 53 | chunks <- tapply(cohort, sort((0:(n - 1))%%mc.cores), I) 54 | currentSeed <- user.Random.seed() 55 | powerFun <- function(obj, FUN, n, ...) { 56 | for (i in 1:n) obj <- FUN(obj, ...) 57 | obj 58 | } 59 | initialSeeds <- Reduce(function(seed, i) powerFun(seed, parallel::nextRNGStream, 60 | 10), 1:mc.cores, currentSeed, accumulate = TRUE)[-1] 61 | ns <- cumsum(sapply(chunks, length)) 62 | ns <- c(0, ns[-length(ns)]) 63 | fhcrcData$prtx$Age <- as.double(fhcrcData$prtx$Age) 64 | fhcrcData$prtx$DxY <- as.double(fhcrcData$prtx$DxY) 65 | fhcrcData$prtx$G <- fhcrcData$prtx$G - 1L 66 | fhcrcData$pradt$Grade <- fhcrcData$pradt$Grade - 1L 67 | fhcrcData$pradt$Age <- as.double(fhcrcData$pradt$Age) 68 | fhcrcData$pradt$DxY <- as.double(fhcrcData$pradt$DxY) 69 | fhcrcData$survival_local <- with(fhcrcData$survival_local, 70 | data.frame(Age = as.double(AgeLow), Grade = Grade, Time = as.double(Time), 71 | Survival = Survival)) 72 | fhcrcData$survival_dist <- with(fhcrcData$survival_dist, 73 | data.frame(Grade = Grade, Time = as.double(Time), Survival = Survival)) 74 | print(system.time(out <- clusterApply(cl, 1:mc.cores, function(i) { 75 | chunk <- chunks[[i]] 76 | set.user.Random.seed(initialSeeds[[i]]) 77 | .Call("callFhcrc", parms = list(n = as.integer(length(chunk)), 78 | firstId = ns[i], screen = as.integer(screenIndex), 79 | nLifeHistories = as.integer(nLifeHistories), screeningCompliance = as.double(screeningCompliance), 80 | studyParticipation = as.double(studyParticipation), 81 | psaThreshold = as.double(psaThreshold), cohort = as.double(chunk), 82 | tables = fhcrcData), PACKAGE = "microsimulation") 83 | }))) 84 | cbindList <- function(obj) if (is.list(obj)) 85 | do.call("cbind", lapply(obj, cbindList)) 86 | else data.frame(obj) 87 | reader <- function(obj) { 88 | obj <- cbindList(obj) 89 | out <- cbind(data.frame(state = enum(obj[[1]], stateT), 90 | grade = enum(obj[[2]], gradeT), dx = enum(obj[[3]], 91 | diagnosisT), psa = enum(obj[[4]], psaT), cohort = obj[[5]]), 92 | data.frame(obj[, -(1:5)])) 93 | out 94 | } 95 | summary <- lapply(seq_along(out[[1]]$summary), function(i) do.call("rbind", 96 | lapply(out, function(obj) reader(obj$summary[[i]])))) 97 | names(summary) <- names(out[[1]]$summary) 98 | states <- c("state", "grade", "dx", "psa", "cohort") 99 | names(summary$prev) <- c(states, "age", "count") 100 | names(summary$pt) <- c(states, "age", "pt") 101 | names(summary$events) <- c(states, "event", "age", "n") 102 | summary <- lapply(summary, function(obj) within(obj, year <- cohort + 103 | age)) 104 | map2df <- function(obj) as.data.frame(do.call("cbind", obj)) 105 | lifeHistories <- do.call("rbind", lapply(out, function(obj) map2df(obj$lifeHistories))) 106 | parameters <- map2df(out[[1]]$parameters) 107 | enum(summary$events$event) <- eventT 108 | enum(lifeHistories$state) <- stateT 109 | enum(lifeHistories$dx) <- diagnosisT 110 | enum(lifeHistories$event) <- eventT 111 | enum <- list(stateT = stateT, eventT = eventT, screenT = screenT, 112 | diagnosisT = diagnosisT, psaT = psaT) 113 | out <- list(n = n, screen = screen, enum = enum, lifeHistories = lifeHistories, 114 | parameters = parameters, summary = summary) 115 | class(out) <- "fhcrc" 116 | out 117 | } 118 | 119 | print(test <- callFhcrc(1e6, mc.cores=mc.cores, cl=cl)) 120 | 121 | stopCluster(cl) 122 | mpi.quit() 123 | -------------------------------------------------------------------------------- /test/rngstream-c++-example.cpp: -------------------------------------------------------------------------------- 1 | 2 | #include "rngstream-c++11.hpp" 3 | #include 4 | #include 5 | 6 | int main() { 7 | rngstream gen, gen2; 8 | std::uniform_real_distribution<> dist(0.0,1.0); 9 | std::cout << gen2 << std::endl; 10 | std::cout << "Expected: 0.127011; observed: " << dist(gen) << std::endl; 11 | std::cout << "Expected: 0.759582; observed: " << dist(gen2) << std::endl; 12 | gen.ResetNextSubstream(); 13 | std::cout << "Expected: 0.079399; observed: " << dist(gen) << std::endl; 14 | std::cout << gen << std::endl; 15 | return 0; 16 | } 17 | // R -q -e "require(parallel); base=c(407L,rep(12345L,6)); .Random.seed=base; runif(1); .Random.seed=nextRNGStream(base); runif(1); .Random.seed=nextRNGSubStream(base); runif(1)" 18 | -------------------------------------------------------------------------------- /test/rngstream-c++11.hpp: -------------------------------------------------------------------------------- 1 | #ifndef CPP_RANDOM_RNGSTREAM_HPP 2 | #define CPP_RANDOM_RNGSTREAM_HPP 3 | 4 | #include 5 | #include 6 | #include 7 | #include 8 | #include 9 | 10 | #include "RngStream-revised.h" 11 | #include "RngStream-revised.cpp" 12 | 13 | class rngstream : public RngStream 14 | { 15 | public: 16 | typedef unsigned long result_type; 17 | 18 | /** 19 | * Returns the smallest value that the generator can produce 20 | */ 21 | static constexpr result_type min () { return 0ul; } 22 | /** 23 | * Returns the largest value that the generator can produce 24 | */ 25 | static constexpr result_type max () 26 | { return 4294967088ul; } // m1+1 27 | 28 | /** Seeds the generator with the default seed. */ 29 | rngstream() : RngStream("") { } 30 | 31 | // compiler-generated copy ctor and assignment operator are fine 32 | 33 | /** Returns the next value of the generator. */ 34 | result_type operator()() { return U(); } 35 | 36 | /** Writes a @c rngstream to a @c std::ostream. */ 37 | template 38 | friend std::basic_ostream& 39 | operator<<(std::basic_ostream& os, const rngstream& r) 40 | { 41 | result_type seed[6]; 42 | r.GetState (seed); 43 | for (int i = 0; i<5; i++) 44 | os << seed[i] << ' '; 45 | os << seed[5]; 46 | return os; 47 | } 48 | 49 | /** Reads a @c rngstream from a @c std::istream. */ 50 | template 51 | friend std::basic_istream& 52 | operator>>(std::basic_istream& is, rngstream& r) 53 | { 54 | result_type seed[6]; 55 | for (int i = 0; i<6; i++) 56 | is >> seed[i]; 57 | r.SetSeed(seed); 58 | return is; 59 | } 60 | 61 | /** 62 | * Returns true if the two generators will produce identical 63 | * sequences of values. 64 | */ 65 | friend bool operator==(const rngstream& x, const rngstream& y) 66 | { 67 | result_type seedx[6], seedy[6]; 68 | x.GetState (seedx); 69 | y.GetState (seedy); 70 | for (int i = 0; i<6; i++) 71 | if (seedx[i] != seedy[i]) 72 | return false; 73 | return true; 74 | } 75 | /** 76 | * Returns true if the two generators will produce different 77 | * sequences of values. 78 | */ 79 | friend bool operator!=(const rngstream& x, const rngstream& y) 80 | { return !(x == y); } 81 | }; 82 | 83 | #endif // CPP_RANDOM_RNGSTREAM_HPP 84 | -------------------------------------------------------------------------------- /test/submit_cluster.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | qsub -q fas_high -l nodes=4:ppn=8,walltime=00:02:00 cluster.sh 3 | -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(microsimulation) 3 | 4 | test_check("microsimulation") 5 | 6 | ## Information on how to write test: 7 | ## http://r-pkgs.had.co.nz/tests.html 8 | 9 | 10 | ## What to test 11 | 12 | ## Whenever you are tempted to type something into a print 13 | ## statement or a debugger expression, write it as a test 14 | ## instead. — Martin Fowler 15 | 16 | ## There is a fine balance to writing tests. Each test that you write 17 | ## makes your code less likely to change inadvertently; but it also 18 | ## can make it harder to change your code on purpose. It’s hard to 19 | ## give good general advice about writing tests, but you might find 20 | ## these points helpful: 21 | 22 | ## * Focus on testing the external interface to your functions - if 23 | ## you test the internal interface, then it’s harder to change the 24 | ## implementation in the future because as well as modifying the 25 | ## code, you’ll also need to update all the tests. 26 | 27 | ## * Strive to test each behaviour in one and only one test. Then if 28 | ## that behaviour later changes you only need to update a single 29 | ## test. 30 | 31 | ## * Avoid testing simple code that you’re confident will 32 | ## work. Instead focus your time on code that you’re not sure 33 | ## about, is fragile, or has complicated interdependencies. That 34 | ## said, I often find I make the most mistakes when I falsely 35 | ## assume that the problem is simple and doesn’t need any tests. 36 | 37 | ## * Always write a test when you discover a bug. You may find it 38 | ## helpful to adopt the test-first philosphy. There you always 39 | ## start by writing the tests, and then write the code that makes 40 | ## them pass. This reflects an important problem solving strategy: 41 | ## start by establishing your success critieria, how you know if 42 | ## you’ve solved the problem. 43 | -------------------------------------------------------------------------------- /tests/testthat/test-callIllnessDeath.R: -------------------------------------------------------------------------------- 1 | library(microsimulation) 2 | context("callIllnessDeath") 3 | 4 | ## To run all the test either: 5 | ## R CMD check 6 | ## or (faster) 7 | ## test_dir("/home/andkar/src/ki/microsimulation/tests/.") 8 | 9 | test_returned_object_structure <- function(obj = obj) { 10 | test_that(paste("Check the structure of the Illness-Death object:", try(obj$screen)), { 11 | expect_is(obj, "list") 12 | expect_output(str(obj), "List of 4") 13 | expect_output(str(obj), "$ pt", fixed = TRUE) 14 | expect_output(str(obj), "$ ut", fixed = TRUE) 15 | expect_output(str(obj), "$ events", fixed = TRUE) 16 | expect_output(str(obj), "$ prev", fixed = TRUE) 17 | }) 18 | } 19 | 20 | test_speed <- function(time_str){ 21 | test_that("Check that the execution speed was not doubled", { 22 | ## As adviced we skip timing check on CRAN: 23 | ## http://r-pkgs.had.co.nz/tests.html 24 | ## To run locally: Sys.setenv(NOT_CRAN='true') 25 | skip_on_cran() 26 | 27 | ## Cut-of value arbitarily set. Note that this could fail on 28 | ## really slow systems. 29 | expect_true(time_str[2] < 0.1) 30 | }) 31 | } 32 | 33 | test_callIllnessDeath <- function(){ 34 | test_that("Check Illness-Death model:", { 35 | 36 | ## Make sure no errors are returned. N.b. double negation 37 | ## expect_failure() expect_error() <=> expect no error 38 | expect_failure(expect_error(time_str <- system.time( 39 | sim <- callIllnessDeath()))) 40 | 41 | ## Check return object 42 | test_returned_object_structure(sim) 43 | 44 | ## Nested check of execution time 45 | test_speed(time_str) 46 | }) 47 | } 48 | 49 | test_callIllnessDeath() 50 | -------------------------------------------------------------------------------- /tests/testthat/test-callPersonSimulation2.R: -------------------------------------------------------------------------------- 1 | library(microsimulation) 2 | context("callSimplePerson2") 3 | 4 | ## To run all the test either: 5 | ## R CMD check 6 | ## or (faster) 7 | ## test_dir("/home/andkar/src/ki/microsimulation/tests/.") 8 | 9 | test_returned_object_structure <- function(obj = obj) { 10 | test_that(paste("Check the structure of the Illness-Death object:", try(obj$screen)), { 11 | expect_is(obj, "list") 12 | expect_output(str(obj), "List of 4") 13 | expect_output(str(obj), "$ pt", fixed = TRUE) 14 | expect_output(str(obj), "$ ut", fixed = TRUE) 15 | expect_output(str(obj), "$ events", fixed = TRUE) 16 | expect_output(str(obj), "$ prev", fixed = TRUE) 17 | }) 18 | } 19 | 20 | test_speed <- function(time_str){ 21 | test_that("Check that the execution speed was not doubled", { 22 | ## As adviced we skip timing check on CRAN: 23 | ## http://r-pkgs.had.co.nz/tests.html 24 | ## To run locally: Sys.setenv(NOT_CRAN='true') 25 | skip_on_cran() 26 | 27 | ## Cut-of value arbitarily set. Note that this could fail on 28 | ## really slow systems. 29 | expect_true(time_str[2] < 0.1) 30 | }) 31 | } 32 | 33 | test_callSimplePerson2 <- function(){ 34 | test_that("Check Illness-Death model:", { 35 | 36 | ## Make sure no errors are returned. N.b. double negation 37 | ## expect_failure() expect_error() <=> expect no error 38 | expect_failure(expect_error(time_str <- system.time( 39 | sim <- callSimplePerson2()))) 40 | 41 | ## Check return object 42 | test_returned_object_structure(sim) 43 | 44 | ## Nested check of execution time 45 | test_speed(time_str) 46 | }) 47 | } 48 | 49 | test_callSimplePerson2() 50 | --------------------------------------------------------------------------------