diff --git a/.Rbuildignore b/.Rbuildignore index bd962fb943c647d5f51359fd02a30be3b81e0157..f999c629c3c8052e248a9a7eae1581707314251c 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -1,5 +1,9 @@ .idea test +Make_data +tests_current +README.md .DS_Store ^.*\.Rproj$ ^\.Rproj\.user$ +^CRAN-SUBMISSION$ diff --git a/.gitignore b/.gitignore index bccc9fa03ae1e5141020c0245d765caf71249888..10541f1ffbcf960819716b6b48a999b55a72a800 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,7 @@ inst/doc run_algorithm.R .Rproj.user +.idea +test +*.o +*.so \ No newline at end of file diff --git a/DESCRIPTION b/DESCRIPTION index 09540812c0d9d079ed29960bddf4229bb0e5539a..f822687e64b9a3c6f1054d334064cb2a1a21a498 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,20 +1,27 @@ -Package: GMJMCMC +Package: FBMS Type: Package -Title: Genetically Modified Mode Jumping MCMC -Version: 1.0 -Date: 2023-06-30 +Title: Flexible Bayesian Model Selection and Model Averaging +Version: 1.1 +Date: 2025-02-26 Encoding: UTF-8 -Author: Jon Lachamnn -Maintainer: Jon Lachmann -Description: Implements the GMJMCMC and MJMCMC algorithms used to fit Bayesian Generalized Non-Linear Models (BGNLM). +Language: en-US +Authors@R: c( + person("Jon", "Lachmann", email = "jon@lachmann.nu", role = c("cre", "aut")), + person("Aliaksandr", "Hubin", email = "aliaksah@math.uio.no", role = "aut") + ) +Description: Implements the Mode Jumping Markov Chain Monte Carlo algorithm described in and its Genetically Modified counterpart described in as well as the sub-sampling versions described in for flexible Bayesian model selection and model averaging. License: GPL-2 Depends: R (>= 3.5.0), fastglm, GenSA, parallel, + methods, stats, - graphics + graphics, + r2r, + BAS, + tolerance Imports: Rcpp LinkingTo: @@ -23,7 +30,12 @@ Suggests: testthat, knitr, rmarkdown, - markdown -RoxygenNote: 7.2.3 + markdown, + lme4, + kernlab, + mvtnorm, + cAIC4 +RoxygenNote: 7.3.2 Roxygen: list(markdown = TRUE) VignetteBuilder: knitr +LazyData: true diff --git a/Make_data/Read_sanger_data.R b/Make_data/Read_sanger_data.R new file mode 100644 index 0000000000000000000000000000000000000000..d39668f96620a4a0167b3bbb4b44b6c4fe9043dc --- /dev/null +++ b/Make_data/Read_sanger_data.R @@ -0,0 +1,51 @@ +#Read Sanger data +#Download first from https://ftp.sanger.ac.uk/pub/genevar/ the files + #https://ftp.sanger.ac.uk/pub/genevar/CEU_children_norm_march2007.zip + #https://ftp.sanger.ac.uk/pub/genevar/CHB_unrelated_norm_march2007.zip + #https://ftp.sanger.ac.uk/pub/genevar/JPT_unrelated_norm_march2007.zip + #https://ftp.sanger.ac.uk/pub/genevar/YRI_parents_norm_march2007.zip +#and unzip these + +#Specify right path +path = "/mn/sarpanitu/ansatte-u2/geirs/prj/FBMS/data/" +x1 = t(read.table(paste(path,"CEU_parents_norm_march2007.txt",sep=""),header=T)) +x2 = t(read.table(paste(path,"CHB_unrelated_norm_march2007.txt",sep=""),header=T)) +x3 = t(read.table(paste(path,"JPT_unrelated_norm_march2007.txt",sep=""),header=T)) +x4 = t(read.table(paste(path,"YRI_parents_norm_march2007.txt",sep=""),header=T)) + +rnames = c(rownames(x1)[-1],rownames(x2)[-1],rownames(x3)[-1],rownames(x4)[-1]) +nam = x1[1,] +x1 = apply(x1[-1,],2,as.numeric) +x2 = apply(x2[-1,],2,as.numeric) +x3 = apply(x3[-1,],2,as.numeric) +x4 = apply(x4[-1,],2,as.numeric) +df = rbind(x1,x2,x3,x4) +colnames(df) = nam +rownames(df) = rnames + +#Make columnn 24266 the first column, corresponding to CCT8 +#(from the illumina_Human_WG-6_array_content.csv file) +df <- df[,c(24266,1:24265,24267:ncol(df))] + +#Choose response variable +SangerData = df +usethis::use_data(SangerData,overwrite=TRUE) + +#Rename columns +#colnames(df) = c("y",paste0("x",1:47292)) + +#Reduced dataset first by those having maximum expression levels below the +#25-th percentile of all measured expression levels +q = quantile(df[,-1],0.25) +foo = apply(df[,-1],2,max) +nC = ncol(df)-1 +df = df[,c(1,1+c(1:nC)[foo>q])] + +#Reduced dataset by deleting rows with range<2 +drange = function(x){diff(range(x))} +foo2 = apply(df,2,drange) +nC = ncol(df)-1 +df = df[,c(1,1+c(1:nC)[foo2>2])] +SangerData2 = as.data.frame(df) +usethis::use_data(SangerData2,overwrite=TRUE) + diff --git a/NAMESPACE b/NAMESPACE index 5b0cb274f9207b80c991371e65fb420b437c42fe..19a6c86f898a30bcefecaf2e40e2c5e8deb9ba95 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -4,6 +4,7 @@ S3method(plot,gmjmcmc) S3method(plot,gmjmcmc_merged) S3method(plot,mjmcmc) S3method(plot,mjmcmc_parallel) +S3method(predict,bgnlm_model) S3method(predict,gmjmcmc) S3method(predict,gmjmcmc_merged) S3method(predict,gmjmcmc_parallel) @@ -14,24 +15,34 @@ S3method(summary,gmjmcmc) S3method(summary,gmjmcmc_merged) S3method(summary,mjmcmc) S3method(summary,mjmcmc_parallel) -export(cos.rad) +export(arcsinh) +export(compute_effects) +export(cos_deg) +export(diagn_plot) export(erf) -export(exp.dbl) -export(gauss) +export(exp_dbl) +export(fbms) +export(fbms.mlik.master) export(gaussian.loglik) export(gaussian.loglik.alpha) -export(gaussian.loglik.bic.irlssgd) +export(gaussian.loglik.g) +export(gaussian_tcch_log_likelihood) export(gelu) export(gen.params.gmjmcmc) export(gen.params.mjmcmc) export(gen.probs.gmjmcmc) export(gen.probs.mjmcmc) +export(get.best.model) +export(get.mpm.model) +export(glm.loglik) +export(glm.logpost.bas) export(gmjmcmc) -export(gmjmcmc.iact) export(gmjmcmc.parallel) export(hs) -export(linear.g.prior.loglik) +export(lm.logpost.bas) +export(log_prior) export(logistic.loglik) +export(logistic.loglik.ala) export(logistic.loglik.alpha) export(marginal.probs) export(merge_results) @@ -60,27 +71,65 @@ export(pm2) export(relu) export(set.transforms) export(sigmoid) -export(sin.rad) +export(sin_deg) export(sqroot) export(string.population) export(string.population.models) -export(to25) -export(to35) export(troot) +importFrom(BAS,CCH) +importFrom(BAS,EB.local) +importFrom(BAS,Jeffreys) +importFrom(BAS,TG) +importFrom(BAS,beta.prime) +importFrom(BAS,bic.prior) +importFrom(BAS,g.prior) +importFrom(BAS,hyper.g) +importFrom(BAS,hyper.g.n) +importFrom(BAS,hypergeometric1F1) +importFrom(BAS,hypergeometric2F1) +importFrom(BAS,intrinsic) +importFrom(BAS,phi1) +importFrom(BAS,robust) +importFrom(BAS,tCCH) +importFrom(BAS,uniform) importFrom(GenSA,GenSA) importFrom(Rcpp,sourceCpp) importFrom(fastglm,fastglm) importFrom(graphics,barplot) +importFrom(graphics,lines) importFrom(graphics,text) +importFrom(methods,is) +importFrom(parallel,clusterEvalQ) +importFrom(parallel,clusterExport) +importFrom(parallel,detectCores) +importFrom(parallel,makeCluster) importFrom(parallel,mclapply) +importFrom(parallel,parLapply) +importFrom(parallel,stopCluster) +importFrom(r2r,has_key) +importFrom(r2r,hashmap) +importFrom(stats,Gamma) importFrom(stats,acf) +importFrom(stats,as.formula) importFrom(stats,binomial) importFrom(stats,cor) +importFrom(stats,gaussian) +importFrom(stats,glm.control) importFrom(stats,lm) importFrom(stats,lm.fit) +importFrom(stats,median) +importFrom(stats,model.matrix) +importFrom(stats,model.response) importFrom(stats,pnorm) +importFrom(stats,poisson) +importFrom(stats,predict) +importFrom(stats,qnorm) importFrom(stats,rbinom) importFrom(stats,rnorm) importFrom(stats,runif) +importFrom(stats,sd) +importFrom(stats,terms) importFrom(stats,var) -useDynLib(GMJMCMC) +importFrom(tolerance,F1) +importFrom(utils,sessionInfo) +useDynLib(FBMS) diff --git a/R/RcppExports.R b/R/RcppExports.R index 68d0ec11cbce6a5ebf59175554d98309c40630de..5f8c2b2d35a0ac77d33abc0c9d5896544804a52c 100644 --- a/R/RcppExports.R +++ b/R/RcppExports.R @@ -2,10 +2,10 @@ # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 set_alphas <- function(formula) { - .Call('_GMJMCMC_set_alphas', PACKAGE = 'GMJMCMC', formula) + .Call('_FBMS_set_alphas', PACKAGE = 'FBMS', formula) } vec_in_mat <- function(mat, vec, firstCol = 0L, lastCol = 0L) { - .Call('_GMJMCMC_vec_in_mat', PACKAGE = 'GMJMCMC', mat, vec, firstCol, lastCol) + .Call('_FBMS_vec_in_mat', PACKAGE = 'FBMS', mat, vec, firstCol, lastCol) } diff --git a/R/abalone-data.R b/R/abalone-data.R new file mode 100644 index 0000000000000000000000000000000000000000..dc3d245b4cf4ab0a3e0189ce08e3f0e5a68496c0 --- /dev/null +++ b/R/abalone-data.R @@ -0,0 +1,31 @@ +#' Physical measurements of 4177 abalones, a species of sea snail. +#' +#' %% ~~ A concise (1-5 lines) description of the dataset. ~~ +#' +#' See the web page \url{https://archive.ics.uci.edu/ml/datasets/Abalone} for +#' more information about the data set. +#' +#' @name abalone +#' @docType data +#' @format A data frame with 4177 observations on the following 9 variables. +#' \describe{ +#' \item{Diameter}{Diameter Perpendicular to length, continuous} +#' \item{Height}{Height with with meat in shell, continuous.} +#' \item{Length}{Longest shell measurement, continuous} +#' \item{Rings}{+1.5 gives the age in years, integer} +#' \item{Sex}{Sex of the abalone, \code{F} is female, \code{M} male, and \code{I} infant, categorical.} +#' \item{Weight_S}{Grams after being dried, continuous.} +#' \item{Weight_Sh}{Grams weight of meat, continuous.} +#' \item{Weight_V}{Grams gut weight (after bleeding), continuous.} +#' \item{Weight_W}{Grams whole abalone, continuous.} } +#' @source Dua, D. and Graff, C. (2019). UCI Machine Learning Repository +#' \url{https://archive.ics.uci.edu/ml/}. Irvine, CA: University of California, +#' School of Information and Computer Science. +#' +#' @keywords datasets +#' @examples +#' +#' data(abalone) +#' ## maybe str(abalone) ; plot(abalone) ... +#' +NULL diff --git a/R/alpha_generation.R b/R/alpha_generation.R index cda610be06b04f06fddb72887011742eefec0b8e..24587a117bdbdfbdd59a8ddc8ea8b305840bab29 100644 --- a/R/alpha_generation.R +++ b/R/alpha_generation.R @@ -3,15 +3,17 @@ # Created by: jonlachmann # Created on: 2021-03-16 -gen.alphas <- function (strategy, feature, data, loglik) { - if (strategy == 1) stop("Not implemented.") - else if (strategy == 2) stop("Not implemented.") - else if (strategy == 3) feature <- alpha_3(feature, data, loglik) +gen.alphas <- function (strategy, feature, data, loglik, verbose) { + if (strategy == "deep") feature <- alpha_3(feature, data, loglik, verbose) + else if (strategy == "random") feature <- alpha_4(feature, data) else stop("Not implemented.") return(feature) } #' Alpha generator using strategy 1 as per Hubin et. al. #' TODO: This is just a placeholder. +#' +#' @noRd +#' #' @param feature The feature to generate alphas for alpha_1 <- function (feature) { return(feature) @@ -19,6 +21,9 @@ alpha_1 <- function (feature) { #' Alpha generator using strategy 2 as per Hubin et. al. #' TODO: This is just a placeholder. +#' +#' @noRd +#' #' @param feature The feature to generate alphas for alpha_2 <- function (feature) { return(feature) @@ -29,31 +34,48 @@ alpha_2 <- function (feature) { #' @param feature The feature to generate alphas for #' @param data The dataset used #' @param loglik log likelihood function to use -alpha_3 <- function (feature, data, loglik) { +#' +#' @noRd +#' +alpha_3 <- function (feature, data, loglik, verbose) { # Create the string representation of the feature with variable alphas - featfun <- print.feature(feature, dataset = TRUE, alphas = TRUE) + featfun <- print.feature(feature, dataset = TRUE, fixed = data$fixed, alphas = TRUE) featfun <- set_alphas(featfun) # Return if there are no alphas to set if (featfun$count == 0) return(feature) # Set initial range for Simulated Annealing - cat("Generating alphas\n") range <- 10 done <- FALSE while (!done) { # Run simulated annealing on current range sares <- GenSA::GenSA(rnorm(featfun$count), loglik, rep(-range / 2, featfun$count), rep(range / 2, featfun$count), - control = list(max.call = 5e3), data, featfun$formula) + control = list(max.call = 5e3, maxit = 20,nb.stop.improvement = 5), data, featfun$formula) # Check if any estimate is on the edge of the range, if so, extend the range and run again if (sum((sares$par == (-range / 2)) + (sares$par == (range / 2))) != 0) range <- range*2 else done <- TRUE } if (sum(sares$par == 0) == featfun$count) { - cat("All zero feature occured.\n") + if (verbose) cat("All zero feature occured.\n") return(NULL) } # Inject the new alphas into the feature feature <- update.alphas(feature, sares$par) return(feature) } + +#' Alpha generator using strategy 4 as per Hubin et. al. +#' +#' @param feature The feature to generate alphas for +#' +#' @noRd +#' +alpha_4 <- function (feature, data) { + # Create the string representation of the feature with variable alphas + featfun <- print.feature(feature, dataset = TRUE, fixed = data$fixed, alphas = TRUE) + featfun <- set_alphas(featfun) + + feature <- update.alphas(feature, rnorm(featfun$count,0,1)) + return(feature) +} diff --git a/R/arguments.R b/R/arguments.R index 2a3c68cc536eefa24b529fc3190e6e4ad3b4a41d..ab55bcbdfaba52a1cd6b326feb63f4feaa45fa6d 100644 --- a/R/arguments.R +++ b/R/arguments.R @@ -3,15 +3,35 @@ # Created by: jonlachmann # Created on: 2021-02-19 -#' Generate a probability list for MJMCMC +#' Generate a probability list for MJMCMC (Mode Jumping MCMC) #' +#' @return A named list with five elements: +#' \describe{ +#' \item{\code{large}}{A numeric value representing the probability of making a large jump. If a large jump is not made, a local MH (Metropolis-Hastings) proposal is used instead.} +#' \item{\code{large.kern}}{A numeric vector of length 4 specifying the probabilities for different types of large jump kernels. The four components correspond to: +#' \enumerate{ +#' \item Random change with random neighborhood size +#' \item Random change with fixed neighborhood size +#' \item Swap with random neighborhood size +#' \item Swap with fixed neighborhood size +#' } +#' These probabilities will be automatically normalized if they do not sum to 1.} +#' \item{\code{localopt.kern}}{A numeric vector of length 2 specifying the probabilities for different local optimization methods during large jumps. The first value represents the probability of using simulated annealing, while the second corresponds to the greedy optimizer. These probabilities will be normalized if needed.} +#' \item{\code{random.kern}}{A numeric vector of length 2 specifying the probabilities of different randomization kernels applied after local optimization of type one or two. These correspond to the first two kernel types as in \code{large.kern} but are used for local proposals with different neighborhood sizes.} +#' \item{\code{mh}}{A numeric vector specifying the probabilities of different standard Metropolis-Hastings kernels, where the first four as the same as for other kernels, while fifths and sixes components are uniform addition/deletion of a covariate.} +#' } +#' +#' @examples +#' gen.probs.mjmcmc() +#' #' @export gen.probs.mjmcmc +#' gen.probs.mjmcmc <- function () { ## Mode jumping algorithm probabilities large <- 0.05 # probability of a large jump large.kern <- c(0, 0, 0, 1) # probability for type of large jump, only allow type 1-4 localopt.kern <- c(0.5, 0.5) # probability for each localopt algorithm - random.kern <- c(0.3, 0.3, 0.2, 0.2) # probability for random jump kernels + random.kern <- c(0.5, 0.5) # probability for random jump kernels mh <- c(0.2, 0.2, 0.2, 0.2, 0.1, 0.1) # probability for regular mh kernels # Compile the list @@ -21,13 +41,64 @@ gen.probs.mjmcmc <- function () { return(probs) } -#' Generate a probability list for GMJMCMC +#' Generate a probability list for GMJMCMC (Genetically Modified MJMCMC) #' #' @param transforms A list of the transformations used (to get the count). #' +#' @return A named list with eight elements: +#' \describe{ +#' \item{\code{large}}{The probability of a large jump kernel in the MJMCMC algorithm. +#' With this probability, a large jump proposal will be made; otherwise, a local +#' Metropolis-Hastings proposal will be used. One needs to consider good mixing +#' around and between modes when specifying this parameter.} +#' +#' \item{\code{large.kern}}{A numeric vector of length 4 specifying the probabilities +#' for different types of large jump kernels. +#' The four components correspond to: +#' \enumerate{ +#' \item Random change with random neighborhood size +#' \item Random change with fixed neighborhood size +#' \item Swap with random neighborhood size +#' \item Swap with fixed neighborhood size +#' } +#' These probabilities will be automatically normalized if they do not sum to 1.} +#' +#' \item{\code{localopt.kern}}{A numeric vector of length 2 specifying the probabilities +#' for different local optimization methods during large jumps. The first value represents +#' the probability of using simulated annealing, while the second corresponds to the +#' greedy optimizer. These probabilities will be normalized if needed.} +#' +#' \item{\code{random.kern}}{A numeric vector of length 2 specifying the probabilities +#' of first two randomization kernels applied after local optimization. These correspond +#' to the same kernel types as in \code{large.kern} but are used for local proposals +#' where type and 2 only are allowed.} +#' +#' \item{\code{mh}}{A numeric vector specifying the probabilities of different standard Metropolis-Hastings kernels, where the first four as the same as for other kernels, while fifths and sixes components are uniform addition/deletion of a covariate.} +#' +#' \item{\code{filter}}{A numeric value controlling the filtering of features +#' with low posterior probabilities in the current population. Features with +#' posterior probabilities below this threshold will be removed with a probability +#' proportional to \eqn{1 - P(\text{feature} \mid \text{population})}.} +#' +#' \item{\code{gen}}{A numeric vector of length 4 specifying the probabilities of different +#' feature generation operators. These determine how new nonlinear features are introduced. +#' The first entry gives the probability for an interaction, followed by modification, +#' nonlinear projection, and a mutation operator, which reintroduces discarded features. +#' If these probabilities do not sum to 1, they are automatically normalized.} +#' +#' \item{\code{trans}}{A numeric vector of length equal to the number of elements in \code{transforms}, +#' specifying the probabilities of selecting each nonlinear transformation from \eqn{\mathcal{G}}. +#' By default, a uniform distribution is assigned, but this can be modified by providing a specific +#' \code{transforms} argument.} +#' } +#' +#' @examples +#' gen.probs.gmjmcmc(c("p0", "exp_dbl")) +#' +#' #' @export gen.probs.gmjmcmc gen.probs.gmjmcmc <- function (transforms) { - if (class(transforms) != "character") + if (!is.character(transforms)) stop("The argument transforms must be a character vector specifying the transformations.") # Get probs for mjmcmc @@ -48,26 +119,77 @@ gen.probs.gmjmcmc <- function (transforms) { return(probs) } -#' Generate a parameter list for MJMCMC +#' Generate a parameter list for MJMCMC (Mode Jumping MCMC) +#' +#' @param ncov The number of covariates in the dataset that will be used in the algorithm +#' +#' @return A list of parameters to use when running the mjmcmc function. +#' +#' The list contains the following elements: +#' +#' \describe{ +#' \item{\code{burn_in}}{The burn-in period for the MJMCMC algorithm, which is set to 100 iterations by default.} +#' +#' \item{\code{mh}}{A list containing parameters for the regular Metropolis-Hastings (MH) kernel: +#' \describe{ +#' \item{\code{neigh.size}}{The size of the neighborhood for MH proposals with fixed proposal size, default set to 1.} +#' \item{\code{neigh.min}}{The minimum neighborhood size for random proposal size, default set to 1.} +#' \item{\code{neigh.max}}{The maximum neighborhood size for random proposal size, default set to 2.} +#' } +#' } #' -#' @param data The dataset that will be used in the algorithm +#' \item{\code{large}}{A list containing parameters for the large jump kernel: +#' \describe{ +#' \item{\code{neigh.size}}{The size of the neighborhood for large jump proposals with fixed neighborhood size, default set to the smaller of 0.35 \eqn{\times p} and 35, where \eqn{p} is the number of covariates.} +#' \item{\code{neigh.min}}{The minimum neighborhood size for large jumps with random size of the neighborhood, default set to the smaller of 0.25 \eqn{\times p} and 25.} +#' \item{\code{neigh.max}}{The maximum neighborhood size for large jumps with random size of the neighborhood, default set to the smaller of 0.45 \eqn{\times p} and 45.} +#' } +#' } #' -#' @return A list of parameters to use when running the MJMCMC algorithm. +#' \item{\code{random}}{A list containing a parameter for the randomization kernel: +#' \describe{ +#' \item{\code{prob}}{The small probability of changing the component around the mode, default set to 0.01.} +#' } +#' } #' -#' TODO: WRITE MORE +#' \item{\code{sa}}{A list containing parameters for the simulated annealing kernel: +#' \describe{ +#' \item{\code{probs}}{A numeric vector of length 6 specifying the probabilities for different types of proposals in the simulated annealing algorithm.} +#' \item{\code{neigh.size}}{The size of the neighborhood for the simulated annealing proposals, default set to 1.} +#' \item{\code{neigh.min}}{The minimum neighborhood size, default set to 1.} +#' \item{\code{neigh.max}}{The maximum neighborhood size, default set to 2.} +#' \item{\code{t.init}}{The initial temperature for simulated annealing, default set to 10.} +#' \item{\code{t.min}}{The minimum temperature for simulated annealing, default set to 0.0001.} +#' \item{\code{dt}}{The temperature decrement factor, default set to 3.} +#' \item{\code{M}}{The number of iterations in the simulated annealing process, default set to 12.} +#' } +#' } #' -#' Note that the $loglik item is an empty list, which is passed to the log likelihood function of the model, +#' \item{\code{greedy}}{A list containing parameters for the greedy algorithm: +#' \describe{ +#' \item{\code{probs}}{A numeric vector of length 6 specifying the probabilities for different types of proposals in the greedy algorithm.} +#' \item{\code{neigh.size}}{The size of the neighborhood for greedy algorithm proposals, set to 1.} +#' \item{\code{neigh.min}}{The minimum neighborhood size for greedy proposals, set to 1.} +#' \item{\code{neigh.max}}{The maximum neighborhood size for greedy proposals, set to 2.} +#' \item{\code{steps}}{The number of steps for the greedy algorithm, set to 20.} +#' \item{\code{tries}}{The number of tries for the greedy algorithm, set to 3.} +#' } +#' } +#' +#' \item{\code{loglik}}{A list to store log-likelihood values, which is by default empty.} +#' } +#' +#' Note that the `$loglik` item is an empty list, which is passed to the log likelihood function of the model, #' intended to store parameters that the estimator function should use. #' +#' @examples +#' gen.params.mjmcmc(matrix(rnorm(600), 100)) +#' +#' #' @export gen.params.mjmcmc -gen.params.mjmcmc <- function (data) { +gen.params.mjmcmc <- function (ncov) { ### Create a list of parameters for the algorithm - ## Get the dimensions of the data to set parameters based on it - data.dim <- data.dims(data) - ncov <- data.dim[2] - 2 - nobs <- data.dim[1] - ## Local optimization parameters sa_kern <- list(probs=c(0.1, 0.05, 0.2, 0.3, 0.2, 0.15), neigh.size=1, neigh.min=1, neigh.max=2) # Simulated annealing proposal kernel parameters @@ -85,39 +207,134 @@ gen.params.mjmcmc <- function (data) { neigh.min = min(as.integer(ncov * 0.25),25), neigh.max = min(as.integer(ncov * 0.45),45) ) - random_params <- list(neigh.size = 1, neigh.min = 1, neigh.max = 2) # Small random jump parameters + random_params <- list(prob = 0.01) # Small random jump parameters mh_params <- list(neigh.size = 1, neigh.min = 1, neigh.max = 2) # Regular MH parameters ## Compile the list and return params <- list(burn_in=burn_in, mh=mh_params, large=large_params, random=random_params, - sa=sa_params, greedy=greedy_params, loglik=list()) + sa=sa_params, greedy=greedy_params) return(params) } -#' Generate a parameter list for GMJMCMC +#' Generate a parameter list for GMJMCMC (Genetically Modified MJMCMC) +#' +#' This function generates the full list of parameters required for the Generalized Mode Jumping Markov Chain Monte Carlo (GMJMCMC) algorithm, building upon the parameters from \code{gen.params.mjmcmc}. The generated parameter list includes feature generation settings, population control parameters, and optimization controls for the search process. +#' +#' @param ncov The number of covariates in the dataset that will be used in the algorithm +#' @return A list of parameters for controlling GMJMCMC behavior: #' -#' @param data The dataset that will be used in the algorithm +#' @section Feature Generation Parameters (\code{feat}): +#' \describe{ +#' \item{\code{feat$D}}{Maximum feature depth, default \code{5}. Limits the number of recursive feature transformations. For fractional polynomials, it is recommended to set \code{D = 1}.} +#' \item{\code{feat$L}}{Maximum number of features per model, default \code{15}. Increase for complex models.} +#' \item{\code{feat$alpha}}{Strategy for generating $alpha$ parameters in non-linear projections: +#' \describe{ +#' \item{\code{"unit"}}{(Default) Sets all components to 1.} +#' \item{\code{"deep"}}{Optimizes $alpha$ across all feature layers.} +#' \item{\code{"random"}}{Samples $alpha$ from the prior for a fully Bayesian approach.} +#' }} +#' \item{\code{feat$pop.max}}{Maximum feature population size per iteration. Defaults to \code{min(100, as.integer(1.5 * p))}, where \code{p} is the number of covariates.} +#' \item{\code{feat$keep.org}}{Logical flag; if \code{TRUE}, original covariates remain in every population (default \code{FALSE}).} +#' \item{\code{feat$prel.filter}}{Threshold for pre-filtering covariates before the first population generation. Default \code{0} disables filtering.} +#' \item{\code{feat$prel.select}}{Indices of covariates to include initially. Default \code{NULL} includes all.} +#' \item{\code{feat$keep.min}}{Minimum proportion of features to retain during population updates. Default \code{0.8}.} +#' \item{\code{feat$eps}}{Threshold for feature inclusion probability during generation. Default \code{0.05}.} +#' \item{\code{feat$check.col}}{Logical; if \code{TRUE} (default), checks for collinearity during feature generation.} +#' \item{\code{feat$max.proj.size}}{Maximum number of existing features used to construct a new one. Default \code{15}.} +#' } #' +#' @section Scaling Option: +#' \describe{ +#' \item{\code{rescale.large}}{Logical flag for rescaling large data values for numerical stability. Default \code{FALSE}.} +#' } +#' +#' @section MJMCMC Parameters: +#' \describe{ +#' \item{\code{burn_in}}{The burn-in period for the MJMCMC algorithm, which is set to 100 iterations by default.} +#' +#' \item{\code{mh}}{A list containing parameters for the regular Metropolis-Hastings (MH) kernel: +#' \describe{ +#' \item{\code{neigh.size}}{The size of the neighborhood for MH proposals with fixed proposal size, default set to 1.} +#' \item{\code{neigh.min}}{The minimum neighborhood size for random proposal size, default set to 1.} +#' \item{\code{neigh.max}}{The maximum neighborhood size for random proposal size, default set to 2.} +#' } +#' } +#' +#' \item{\code{large}}{A list containing parameters for the large jump kernel: +#' \describe{ +#' \item{\code{neigh.size}}{The size of the neighborhood for large jump proposals with fixed neighborhood size, default set to the smaller of \code{0.35 * p} and \code{35}, where \eqn{p} is the number of covariates.} +#' \item{\code{neigh.min}}{The minimum neighborhood size for large jumps with random size of the neighborhood, default set to the smaller of \code{0.25 * p} and \code{25}.} +#' \item{\code{neigh.max}}{The maximum neighborhood size for large jumps with random size of the neighborhood, default set to the smaller of \code{0.45 * p} and \code{45}.} +#' } +#' } +#' +#' \item{\code{random}}{A list containing a parameter for the randomization kernel: +#' \describe{ +#' \item{\code{prob}}{The small probability of changing the component around the mode, default set to 0.01.} +#' } +#' } +#' +#' \item{\code{sa}}{A list containing parameters for the simulated annealing kernel: +#' \describe{ +#' \item{\code{probs}}{A numeric vector of length 6 specifying the probabilities for different types of proposals in the simulated annealing algorithm.} +#' \item{\code{neigh.size}}{The size of the neighborhood for the simulated annealing proposals, default set to 1.} +#' \item{\code{neigh.min}}{The minimum neighborhood size, default set to 1.} +#' \item{\code{neigh.max}}{The maximum neighborhood size, default set to 2.} +#' \item{\code{t.init}}{The initial temperature for simulated annealing, default set to 10.} +#' \item{\code{t.min}}{The minimum temperature for simulated annealing, default set to 0.0001.} +#' \item{\code{dt}}{The temperature decrement factor, default set to 3.} +#' \item{\code{M}}{The number of iterations in the simulated annealing process, default set to 12.} +#' } +#' } +#' +#' \item{\code{greedy}}{A list containing parameters for the greedy algorithm: +#' \describe{ +#' \item{\code{probs}}{A numeric vector of length 6 specifying the probabilities for different types of proposals in the greedy algorithm.} +#' \item{\code{neigh.size}}{The size of the neighborhood for greedy algorithm proposals, set to 1.} +#' \item{\code{neigh.min}}{The minimum neighborhood size for greedy proposals, set to 1.} +#' \item{\code{neigh.max}}{The maximum neighborhood size for greedy proposals, set to 2.} +#' \item{\code{steps}}{The number of steps for the greedy algorithm, set to 20.} +#' \item{\code{tries}}{The number of tries for the greedy algorithm, set to 3.} +#' } +#' } +#' +#' \item{\code{loglik}}{A list to store log-likelihood values, which is by default empty.} +#' } +#' +#' @examples +#' data <- data.frame(y = rnorm(100), x1 = rnorm(100), x2 = rnorm(100)) +#' params <- gen.params.gmjmcmc(ncol(data) - 1) +#' str(params) +#' +#' @seealso \code{\link{gen.params.mjmcmc}}, \code{\link{gmjmcmc}} +#' #' @export gen.params.gmjmcmc -gen.params.gmjmcmc <- function (data) { +gen.params.gmjmcmc <- function (ncov) { # Get mjmcmc params - params <- gen.params.mjmcmc(data) - - ncov <- ncol(data) - 2 + params <- gen.params.mjmcmc(ncov) feat_params <- list(D = 5, L = 15, # Hard limits on feature complexity - alpha = 0, # alpha strategy (0 = None, 1,2,3 = strategies as per Hubin et al.) TODO: Fully Bayesian - pop.max = min(100,as.integer(ncov * 1.5)), # Max features population size - keep.org = F, # Always keep original covariates in every population - prel.filter = NULL, # Filtration threshold for first population (i.e. filter covariates even if keep.org=T) + alpha = "unit", # alpha strategy ("unit" = None, "deep" strategy 3 from Hubin et al., "random" fully Bayesian strategy) + pop.max = min(100, as.integer(ncov * 1.5)), # Max features population size + keep.org = FALSE, # Always keep original covariates in every population + prel.filter = 0, # Filtration threshold for first population (i.e. filter covariates even if keep.org=TRUE) keep.min = 0.8, # Minimum proportion of features to always keep [0,1] eps = 0.05, # Inclusion probability limit for feature generation check.col = TRUE, # Whether the colinearity should be checked col.check.mock.data = FALSE, # Use mock data when checking for colinearity during feature generation max.proj.size = 15) # Maximum projection size params$feat <- feat_params - params$rescale.large <- F - params$prel.filter <- NULL # Specify which covariates to keep in the first population. See Issue #15. + + # Large jump parameters + large_params <- list( + neigh.size = min(as.integer(params$feat$pop.max * 0.35), as.integer(ncov * 0.35), 35), + neigh.min = min(as.integer(params$feat$pop.max * 0.35), as.integer(ncov * 0.25), 25), + neigh.max = min(as.integer(params$feat$pop.max * 0.35), as.integer(ncov * 0.45), 45) + ) + params$large <- large_params + + params$rescale.large <- FALSE + params$prel.select <- NULL # Specify which covariates to keep in the first population. See Issue #15. return(params) } diff --git a/R/diagnostics.R b/R/diagnostics.R index ca04c1ab138e47158f75b0b7a4af57a16cb4f360..a2e7048593533b5700f531dace4f7100ee87f969 100644 --- a/R/diagnostics.R +++ b/R/diagnostics.R @@ -3,48 +3,91 @@ # Created by: jonlachmann # Created on: 2021-02-24 -# TODO: We do not really know if this works as intended... -# TODO: It should be investigated how to properly calculate acf for binary vectors -#' Integrated Auto-Correlation Time -#' -#' @param x A matrix where each row is a model -#' -#' @export gmjmcmc.iact -gmjmcmc.iact <- function (x) { - xlen <- nrow(x) - tmp <- acf(as.numeric(x), lag.max = xlen, plot = FALSE)$acf - li <- min(which(tmp < 0.05)) - out <- 1 + 2 * sum(tmp[1:(li - 1)]) - out -} - -# TODO: Inter-thread variance comparison of the marginal log posterior of the best found model. - #' Plot convergence of best/median/mean/other summary log posteriors in time #' #' @param res Object corresponding gmjmcmc output #' @param FUN The summary statistics to check convergence -#' @param conf which confidence intervals to plot -#' @param burnin how many first populations to skip -#' @param window sliding window for computing the standard deviation -#' @return summary statistics with given confidence intervals +#' @param conf Which confidence intervals to plot +#' @param burnin How many first populations to skip +#' @param window Sliding window for computing the standard deviation +#' @param ylim Limits for the plotting range; if unspecified, min and max of confidence intervals will be used +#' @param ... Additional graphical parameters passed to plot and lines functions, e.g. col, lwd, lty, main, xlab, ylab, ylim #' -plot.diagn <- function (res, FUN = median, conf = 0.95, burnin = 0, window = 10000) { +#' @return A list of summary statistics for checking convergence with given confidence intervals +#' +#' @examples +#' result <- gmjmcmc(y = matrix(rnorm(100), 100), +#' x = matrix(rnorm(600), 100), +#' P = 2, +#' transforms = c("p0", "exp_dbl")) +#' diagnstats <- diagn_plot(result) +#' +#' @export +diagn_plot <- function(res, FUN = median, conf = 0.95, burnin = 0, window = 5, ylim = NULL, ...) { + + args <- list(...) + args[["..."]] <- NULL # Remove any "..." element to avoid warning - if(length(res$thread.best)>0) + if(length(res$thread.best) > 0) matrix.results <- res$best.log.posteriors else matrix.results <- as.matrix(unlist(res$best.margs)) - sr <- sapply((1+burnin):dim(matrix.results)[1], FUN = function(x)FUN(matrix.results[x,])) - sds <- c(0,sapply(2:length(sr), function(x)sd(sr[max(1,x-window):x]))) - ub <- sr + qnorm(p = 1-(1-conf)/2)*sds - lb <- sr - qnorm(p = 1-(1-conf)/2)*sds + sr <- sapply((1 + burnin):dim(matrix.results)[1], function(x) FUN(matrix.results[x, ])) + sds <- c(0, sapply(2:length(sr), function(x) sd(sr[max(1, x - window):x]))) + + ub <- sr + qnorm(1 - (1 - conf) / 2) * sds + lb <- sr - qnorm(1 - (1 - conf) / 2) * sds - plot(y = sr,x = (burnin+1):(dim(matrix.results)[1]), type = "l",col = 1,ylim = c(min(lb), max(ub)), main = "Convergence", xlab = "Population", ylab = "Summary") - lines(y = ub,x = (burnin+1):(dim(matrix.results)[1]),col = 1,lty = 2) - lines(y = lb,x = (burnin+1):(dim(matrix.results)[1]),col = 1,lty = 2) + if (is.null(ylim) && is.null(args$ylim)) + ylim <- c(min(lb), max(ub)) + else if (is.null(ylim)) + ylim <- args$ylim + + main <- if (!is.null(args$main)) args$main else "Convergence" + xlab <- if (!is.null(args$xlab)) args$xlab else "Population" + ylab <- if (!is.null(args$ylab)) args$ylab else "Summary" + + args$main <- NULL + args$xlab <- NULL + args$ylab <- NULL + args$ylim <- NULL + + do.call(plot, c( + list( + y = sr, + x = (burnin + 1):(dim(matrix.results)[1]), + type = "l", + col = 1, + ylim = ylim, + main = main, + xlab = xlab, + ylab = ylab + ), + args + )) + + do.call(lines, c( + list( + y = ub, + x = (burnin + 1):(dim(matrix.results)[1]), + col = 1, + lty = 2 + ), + args + )) + + do.call(lines, c( + list( + y = lb, + x = (burnin + 1):(dim(matrix.results)[1]), + col = 1, + lty = 2 + ), + args + )) return(list(stat = sr, lower = lb, upper = ub)) } + diff --git a/R/exa-data.R b/R/exa-data.R index 8537b455526e81e219c23fcaf46b5cea4bc6b4ec..08e2763aaaefee00200c50e9217b26353c7d88b6 100644 --- a/R/exa-data.R +++ b/R/exa-data.R @@ -5,17 +5,16 @@ #' The variables are as follows: #' #' \itemize{ -#' \item TypeFlag: Flag indicating the type of data -#' \item PlanetaryMassJpt: Mass of the planetary object in Jupiter masses -#' \item RadiusJpt: Radius of the planetary object in Jupiter radii -#' \item PeriodDays: Orbital period of the planetary object in days -#' \item SemiMajorAxisAU: Semi-major axis of the planetary object's orbit in astronomical units -#' \item Eccentricity: Eccentricity of the planetary object's orbit -#' \item HostStarMassSlrMass: Mass of the host star in solar masses -#' \item HostStarRadiusSlrRad: Radius of the host star in solar radii -#' \item HostStarMetallicity: Metallicity of the host star -#' \item HostStarTempK: Effective temperature of the host star in Kelvin -#' \item PlanetaryDensJpt: Density of the planetary object up to a constant +#' \item semimajoraxis: Semi-major axis of the planetary object's orbit in astronomical units +#' \item mass: Mass of the planetary object in Jupiter masses +#' \item radius: Radius of the planetary object in Jupiter radii +#' \item period: Orbital period of the planetary object in days +#' \item eccentricity: Eccentricity of the planetary object's orbit +#' \item hoststar_mass: Mass of the host star in solar masses +#' \item hoststar_radius: Radius of the host star in solar radii +#' \item hoststar_metallicity: Metallicity of the host star +#' \item hoststar_temperature: Effective temperature of the host star in Kelvin +#' \item binaryflag: Flag indicating the type of planetary system #' } #' #' @docType data diff --git a/R/fbms.R b/R/fbms.R new file mode 100644 index 0000000000000000000000000000000000000000..b1e4b6a717554b39031a38e8b50b71c496a481d8 --- /dev/null +++ b/R/fbms.R @@ -0,0 +1,388 @@ +#' Fit a BGNLM model using Genetically Modified Mode Jumping Markov Chain Monte Carlo (MCMC) sampling. +#' Or Fit a BGLM model using Modified Mode Jumping Markov Chain Monte Carlo (MCMC) sampling. +#' +#' This function fits a model using the relevant MCMC sampling. The user can specify the formula, +#' family, data, transforms, and other parameters to customize the model. +#' +#' @param formula A formula object specifying the model structure. Default is NULL. +#' @param family The distribution family of the response variable. Currently supports "gaussian", "binomial", "poisson", "gamma", and "custom". Default is "gaussian". +#' @param beta_prior Type of prior as a string (default: "g-prior" with a = max(n, p^2)). Possible values include: +#' - "beta.prime": Beta-prime prior (GLM/Gaussian, no additional args) +#' - "CH": Compound Hypergeometric prior (GLM/Gaussian, requires `a`, `b`, optionally `s`) +#' - "EB-local": Empirical Bayes local prior (GLM/Gaussian, requires `a` for Gaussian) +#' - "EB-global": Empirical Bayes local prior (Gaussian, requires `a` for Gaussian) +#' - "g-prior": Zellner's g-prior (GLM/Gaussian, requires `g`) +#' - "hyper-g": Hyper-g prior (GLM/Gaussian, requires `a`) +#' - "hyper-g-n": Hyper-g/n prior (GLM/Gaussian, requires `a`) +#' - "tCCH": Truncated Compound Hypergeometric prior (GLM/Gaussian, requires `a`, `b`, `s`, `rho`, `v`, `k`) +#' - "intrinsic": Intrinsic prior (GLM/Gaussian, no additional args) +#' - "TG": Truncated Gamma prior (GLM/Gamma, requires `a`, `s`) +#' - "Jeffreys": Jeffreys prior (GLM/Gaussian, no additional args) +#' - "uniform": Uniform prior (GLM/Gaussian, no additional args) +#' - "benchmark": Benchmark prior (Gaussian/GLM, no additional args) +#' - "ZS-adapted": Zellner-Siow adapted prior (Gaussian TCCH, no additional args) +#' - "robust": Robust prior (Gaussian/GLM, no additional args) +#' - "Jeffreys-BIC": Jeffreys prior with BIC approximation of marginal likelihood (Gaussian/GLM) +#' - "ZS-null": Zellner-Siow null prior (Gaussian, requires `a`) +#' - "ZS-full": Zellner-Siow full prior (Gaussian, requires `a`) +#' - "hyper-g-laplace": Hyper-g Laplace prior (Gaussian, requires `a`) +#' - "AIC": AIC prior from BAS (Gaussian, requires penalty `a`) +#' - "BIC": BIC prior from BAS (Gaussian/GLM) +#' - "JZS": Jeffreys-Zellner-Siow prior (Gaussian, requires `a`) +#' - r: Model complexity penalty (default: 1/n) +#' - g: Tuning parameter for g-prior (default: max(n, p^2)) +#' - a, b, s, v, rho, k: Hyperparameters for various priors +#' - n: Sample size for some priors (default: length(y)) +#' - var: Variance assumption for Gaussian models ("known" or "unknown", default: "unknown") +#' - laplace: Logical for Laplace approximation in GLM only (default: FALSE) +#' @param model_prior a list with parameters of model priors, by default r should be provided +#' @param extra_params extra parameters to be passed to the loglik.pi function +#' @param loglik.pi Custom function to compute the logarithm of the posterior mode based on logarithm of marginal likelihood and logarithm of prior functions (needs specification only used if family = "custom") +#' @param data A data frame or matrix containing the data to be used for model fitting. If the outcome variable is in the first column of the data frame, the formula argument in fbms can be omitted, provided that all other columns are intended to serve as input covariates. +#' @param method Which fitting algorithm should be used, currently implemented options include "gmjmcmc", "gmjmcmc.parallel", "mjmcmc" and "mjmcmc.parallel" with "mjmcmc" being the default and 'mjmcmc' means that only linear models will be estimated +#' @param verbose If TRUE, print detailed progress information during the fitting process. Default is TRUE. +#' @param impute TRUE means imputation combined with adding a dummy column with indicators of imputed values, FALSE (default) means only full data is used. +#' @param ... Additional parameters to be passed to the underlying method. +#' +#' @return An object containing the results of the fitted model and MCMC sampling. +#' +#' @examples +#' # Fit a Gaussian multivariate time series model +#' fbms_result <- fbms( +#' X1 ~ ., +#' family = "gaussian", +#' method = "gmjmcmc.parallel", +#' data = data.frame(matrix(rnorm(600), 100)), +#' transforms = c("sin","cos"), +#' P = 10, +#' runs = 1, +#' cores = 1 +#' ) +#' summary(fbms_result) +#' +#' +#' @seealso \code{\link{mjmcmc}}, \code{\link{gmjmcmc}}, \code{\link{gmjmcmc.parallel}} +#' @export +#' @importFrom stats terms +fbms <- function ( + formula = NULL, + family = "gaussian", + beta_prior = list(type = "g-prior"), + model_prior = NULL, + extra_params = NULL, + data = NULL, + impute = FALSE, + loglik.pi = NULL, + method = "mjmcmc", + verbose = TRUE, + ... +) { + + if (length(data) == 0) + stop("Training data must be provided!") + + if (length(model_prior) == 0) + model_prior = list(r = 1 / dim(data)[1]) + if (family != "custom") { + mlpost_params <- model_prior + loglik.pi <- select.mlpost.fun(beta_prior$type, family) + if (family == "gaussian") { + mlpost_params$beta_prior <- gen.mlpost.params.lm(beta_prior$type, beta_prior, ncol(data) - 1, nrow(data)) + } else { + mlpost_params$beta_prior <- gen.mlpost.params.glm(beta_prior$type, beta_prior, ncol(data) - 1, nrow(data)) + mlpost_params$beta_prior$type <- beta_prior$type + mlpost_params$family <- family + } + } else { + loglik.pi <- loglik.pi + mlpost_params <- c(model_prior, beta_prior, extra_params) + } + + if (!is.null(formula)) { + if (missing(data)) { + data <- environment(formula) + } + + na.opt <- getOption("na.action") + if (impute) + options(na.action = 'na.pass') + else + options(na.action = 'na.omit') + mf <- match.call(expand.dots = FALSE) + m <- match(c("formula", "data"), names(mf), 0L) + mf <- mf[c(1L, m)] + mf$drop.unused.levels <- TRUE + mf[[1L]] <- quote(stats::model.frame) + mf <- eval(mf, parent.frame()) + + Y <- model.response(mf, "any") + X <- model.matrix(formula, data = data) + intercept <- attr(terms(formula, data = data), "intercept") == 1 + if (intercept) X <- X[, -1, drop = FALSE] + mis.Y <- which(is.na(Y)) + if (length(mis.Y) > 0) { + warning("Missing values in the response. Dropped.") + Y <- Y[-c(mis.Y)] + X <- X[-c(mis.Y), ] + } + + mis.X <- sum(is.na(X)) + imputed <- NULL + if (impute && mis.X > 0) { + print("Imputing missing values!") + X <- data.frame(X) + na.matr <- data.frame(1 * (is.na(X))) + names(na.matr) <- paste0("mis_", names(na.matr)) + cm <- colMeans(na.matr) + na.matr <- na.matr[, cm != 0] + for (i in seq_along(X)) { + X[[i]][is.na(X[[i]])] <- median(X[[i]], na.rm = TRUE) + } + imputed <- names(X)[cm != 0] + X <- data.frame(X, na.matr) + rm(na.matr) + rm(cm) + print("Continue to sampling!") + } else if (mis.X > 0) { + print("Dropping missing values!") + } + } else { + Y <- data[, 1] + X <- data[, -1, drop = FALSE] + intercept <- TRUE + imputed <- NULL + na.opt <- getOption("na.action") + if (impute) { + options(na.action = 'na.pass') + stop("Imputation is only implemented when formula is provided.\n Please specify formula and rerun!") + } else { + options(na.action = 'na.omit') + } + } + + if (method == "mjmcmc.parallel") + res <- mjmcmc.parallel(x = X, y = Y, loglik.pi = loglik.pi, mlpost_params = mlpost_params, intercept = intercept, verbose = verbose, ...) + else if (method == "mjmcmc") + res <- mjmcmc(x = X, y = Y, loglik.pi = loglik.pi, mlpost_params = mlpost_params, intercept = intercept, verbose = verbose, ...) + else if (method == "gmjmcmc.parallel") + res <- gmjmcmc.parallel(x = X, y = Y, loglik.pi = loglik.pi, mlpost_params = mlpost_params, intercept = intercept, verbose = verbose,...) + else if (method == "gmjmcmc") + res <- gmjmcmc(x = X, y = Y, loglik.pi = loglik.pi, mlpost_params = mlpost_params, intercept = intercept, verbose = verbose, ...) + else + stop("Error: Method must be one of gmjmcmc, gmjmcmc.parallel, mjmcmc or mjmcmc.parallel!") + + attr(res, "imputed") <- imputed + attr(res, "all_names") <- names(X)[1:(dim(X)[2] - 1)] + options(na.action = na.opt) + return(res) +} + +gen.mlpost.params.glm <- function (beta_prior, user_params, p, n) { + + if(beta_prior == "Jeffreys-BIC") + { + return(NULL) + } else if(beta_prior == "beta.prime") { + return(BAS::beta.prime(n = n)) + } else if (beta_prior == "CH") { + check_required_params(c("a", "b", "s"), user_params, beta_prior) + return(BAS::CCH(alpha = user_params$a, beta = user_params$b, s = user_params$s)) + } else if (beta_prior == "EB-local") { + return(BAS::EB.local()) + } else if (beta_prior == "g-prior") { + if (is.null(user_params$g)) { + user_params$g <- max(p^2, n) + } + return(BAS::g.prior(user_params$g)) + } else if (beta_prior == "hyper-g") { + check_required_params("a", user_params, beta_prior) + params <- BAS::hyper.g(alpha = user_params$a) + params$method <- 1 + return(params) + } else if (beta_prior == "tCCH") { + check_required_params(c("a", "b", "s", "rho", "v", "k"), user_params, beta_prior) + return(BAS::tCCH( + alpha = user_params$a, + beta = user_params$b, + s = user_params$s, + r = user_params$rho, + v = user_params$v, + theta = user_params$k + )) + } else if (beta_prior == "intrinsic") { + return(BAS::intrinsic(n = n)) + } else if (beta_prior == "TG") { + check_required_params("a", user_params, beta_prior) + return(BAS::TG(alpha = user_params$a)) + } else if (beta_prior == "Jeffreys") { + return(BAS::Jeffreys()) + } else if (beta_prior == "uniform") { + return(BAS::tCCH(alpha = 2, beta = 2, s = 0, r = 0, v = 1, theta = 1)) + } else if (beta_prior == "benchmark") { + return(BAS::tCCH(alpha = 0.02, beta = 0.02 * max(n, p^2), s = 0, r = 0, v = 1, theta = 1)) + } else if (beta_prior == "ZS-adapted") { + return(BAS::tCCH(alpha = 1, beta = 2, s = n + 3, r = 0, v = 1, theta = 1)) + } else if (beta_prior == "robust") { + return(BAS::robust(n = as.numeric(n)))# important to cast to numeric for BAS, do not change. + } else if (beta_prior == "hyper-g-n") { + if (is.null(user_params$a)) user_params$a <- 3 + return(BAS::hyper.g.n(alpha = user_params$a, n = n)) + } else if (beta_prior == "BIC") { + return(BAS::bic.prior(n = n)) + } + stop("Unknown prior, please verify your inputs.") +} + + +gen.mlpost.params.lm <- function (beta_prior, user_params, p, n) { + + if (beta_prior == "Jeffreys-BIC") { + if(length(user_params$var)==0) + { + user_params$var <- "unknown" + } + return(list(var = user_params$var)) + }else if (beta_prior == "beta.prime") { + return(list(type = "beta.prime")) + } else if (beta_prior == "CH") { + check_required_params(c("a", "b", "s"), user_params, beta_prior) + user_params <- list(type = + "CH", + a = user_params$a, + b = user_params$b, + s = user_params$s + ) + return(user_params) + } else if (beta_prior == "tCCH") { + check_required_params(c("a", "b", "s", "rho", "v", "k"), user_params, beta_prior) + user_params <- list( + type = "tCCH", + a = user_params$a, + b = user_params$b, + s = user_params$s, + rho = user_params$rho, + v = user_params$v, + k = user_params$k + ) + return(user_params) + } else if (beta_prior == "intrinsic") { + return(list(type = "intrinsic")) + } else if (beta_prior == "TG") { + check_required_params(c("a", "s"), user_params, beta_prior) + user_params <- list( + type = "TG", + a = user_params$a, + s = user_params$s + ) + return(user_params) + } else if (beta_prior == "Jeffreys") { + return(list(type = "Jeffreys")) + } else if (beta_prior == "ZS-adapted") { + return(list(type = "ZS-adapted")) + } else if (beta_prior == "benchmark") { + return(list(type = "benchmark")) + } else if (beta_prior == "robust") { + return(list(type = "robust")) + } else if (beta_prior == "uniform") { + return(list(type = "uniform")) + } else{ + if(!is.null(user_params$g)) + user_params$a <- user_params$g + if (!is.null(user_params$a)) { + alpha <- user_params$a + } else { + if (beta_prior == "g-prior") { + alpha <- min(p^2, n) + } else { + alpha <- -1 #check how BAS uses the default + } + } + if (beta_prior == "g-prior") { + return(list(method = 0, alpha = alpha)) + } else if (beta_prior == "hyper-g") { + return(list(method = 1, alpha = alpha)) + } else if (beta_prior == "EB-local") { + return(list(method = 2, alpha = alpha)) + } else if (beta_prior == "BIC") { + return(list(method = 3, alpha = alpha)) + } else if (beta_prior == "ZS-null") { + return(list(method = 4, alpha = alpha)) + } else if (beta_prior == "ZS-full") { + return(list(method = 5, alpha = alpha)) + } else if (beta_prior == "hyper-g-laplace") { + return(list(method = 6, alpha = alpha)) + } else if (beta_prior == "AIC") { + return(list(method = 7, alpha = alpha)) + } else if (beta_prior == "EB-global") { + return(list(method = 2, alpha = alpha)) + } else if (beta_prior == "JZS") { + return(list(method = 9, alpha = alpha)) + } else if (beta_prior == "hyper-g-n") { + return(list(method = 8, alpha = alpha)) + } else { + stop("Unrecognized prior_beta for Gaussian GLM: ", beta_prior) + } + } +} + +check_required_params <- function (required, user_params, beta_prior) { + for (req in required) { + if (is.null(user_params[[req]]) || !is.numeric(user_params[[req]])) { + par_names <- paste0(required, collapse = ", ") + stop(paste0("The parameters: ", par_names, " must be provided for the ", beta_prior, " prior.")) + return(FALSE) + } + } + return(TRUE) +} + +select.mlpost.fun <- function (beta_prior, family) { + if (!(family %in% c("binomial", "poisson", "gamma", "gaussian"))) { + stop(paste0( + "Unsupported family: ", family, ". Supported families are 'binomial', 'poisson', 'gamma', or 'gaussian'." + )) + } + + gaussian_only_priors <- c("ZS-null", "ZS-full", "hyper-g-laplace","BIC", "AIC", "JZS","EB-global") + gaussian_not_robust <- c("CH", "tCCH", "ZS-adapted", "TG", "beta.prime", "benchmark", "Jeffreys") + gaussian_robust <- c("g-prior", "hyper-g", "EB-local","BIC", "Jeffreys-BIC", "ZS-null", "ZS-full", "hyper-g-laplace", + "AIC", "hyper-g-n", "JZS") + gaussian_tcch <- c("CH", "tCCH", "TG","beta.prime", "intrinsic", "ZS-adapted", "uniform","Jeffreys", "benchmark", "robust") + gaussian_bas <- c("g-prior", "hyper-g", "EB-local","ZS-null", "ZS-full", "BIC", "hyper-g-laplace", "AIC", "EB-global", "hyper-g-n", "JZS") + glm_priors <- c("CH", "tCCH", "TG","beta.prime", "EB-local", "g-prior", "hyper-g", "hyper-g-n", + "intrinsic", "ZS-adapted", "Jeffreys", "uniform", "benchmark", "robust", "Jeffreys-BIC") + + if (family %in% c("binomial", "poisson", "gamma")) { + if (beta_prior %in% gaussian_only_priors) { + stop(paste0( + "Prior ", beta_prior, " is not supported for the GLM family", family, + ". Supported priors are: ", paste(glm_priors, collapse = ", ") + )) + } + if (beta_prior == "Jeffreys-BIC") { + if (family == "binomial") { + return(logistic.loglik) + } else { + return(glm.loglik) + } + } else { + return(glm.logpost.bas) + } + } else if (family == "gaussian") { + if (beta_prior %in% gaussian_not_robust) { + warning(paste0( + "Prior ", beta_prior, " is not recommended for Gaussian family models as it may be unstable for strong signals (R^2 > 0.9).", + "Recommended priors under the Gaussian family are: ", paste(gaussian_robust, collapse = ", ") + )) + } + if (beta_prior %in% gaussian_tcch) { + return(gaussian_tcch_log_likelihood) + } else if (beta_prior == "Jeffreys-BIC") { + return(gaussian.loglik) + } else if (beta_prior %in% gaussian_bas) { + return(lm.logpost.bas) + } + } + stop("Unknown prior, please verify your inputs.") +} + diff --git a/R/feature.R b/R/feature.R index c34b3415c03d5272e37284fb684725c03667cfcd..05c350737c11bda66de7ed43e660541e580ca30d 100644 --- a/R/feature.R +++ b/R/feature.R @@ -22,6 +22,7 @@ #' @param features A list of features to include #' @param trans.priors A vector of prior inclusion penalties for the different transformations. #' @param alphas A numeric vector denoting the alphas to use +#' @noRd create.feature <- function (transform, features, trans.priors, alphas=NULL) { # Given no alphas, assume no intercept and unit coefficients if (is.null(alphas)) alphas <- c(0, rep(1, length(features))) @@ -62,6 +63,7 @@ create.feature <- function (transform, features, trans.priors, alphas=NULL) { #' @param feature The feature to be updated #' @param alphas The alphas that will be used #' @param recurse If we are recursing, to note the number of alphas used +#' @noRd update.alphas <- function (feature, alphas, recurse=FALSE) { feat <- feature[[length(feature)]] alpha <- 0 @@ -95,13 +97,23 @@ update.alphas <- function (feature, alphas, recurse=FALSE) { #' #' @param x An object of class "feature" #' @param dataset Set the regular covariates as columns in a dataset +#' @param fixed How many of the first columns in dataset are fixed and do not contribute to variable selection #' @param alphas Print a "?" instead of actual alphas to prepare the output for alpha estimation #' @param labels Should the covariates be named, or just referred to as their place in the data.frame. #' @param round Should numbers be rounded when printing? Default is FALSE, otherwise it can be set to the number of decimal places. #' @param ... Not used. -#' +#' +#' @return String representation of a feature +#' +#' @examples +#' result <- gmjmcmc(x = matrix(rnorm(600), 100), +#' y = matrix(rnorm(100), 100), +#' P = 2, +#' transforms = c("p0", "exp_dbl")) +#' print(result$populations[[1]][1]) +#' #' @export -print.feature <- function (x, dataset = FALSE, alphas = FALSE, labels = FALSE, round = FALSE, ...) { +print.feature <- function (x, dataset = FALSE, fixed = 0, alphas = FALSE, labels = FALSE, round = FALSE, ...) { fString <- "" feat <- x[[length(x)]] # This is a more complex feature @@ -111,7 +123,7 @@ print.feature <- function (x, dataset = FALSE, alphas = FALSE, labels = FALSE, r # Assume that we are not doing multiplication op <- "+" # Add the outer transform is there is one - if (feat[1,1] > 0) fString <- paste0(fString, transforms[[feat[1,1]]], "(") + if (feat[1, 1] > 0) fString <- paste0(fString, transforms[[feat[1, 1]]], "(") # If g = 0, we are doing multiplication else { op <- "*" @@ -119,33 +131,33 @@ print.feature <- function (x, dataset = FALSE, alphas = FALSE, labels = FALSE, r } # If we are printing rounded features for neat output, round all alphas if (round) { - feat[,3] <- round(feat[,3], round) + feat[, 3] <- round(feat[, 3], round) } for (j in seq_len(nrow(feat))) { # No plus or multiplication sign on the last one if (j == nrow(feat)) op <- "" # If this is an intercept just add it in - if (j == 1 && feat[j,3] != 0) { - if (!alphas) fString <- paste0(fString, feat[j,3], op) + if (j == 1 && feat[j, 3] != 0) { + if (!alphas) fString <- paste0(fString, feat[j, 3], op) else fString <- paste0(fString, "?", op) } # Otherwise this is a feature or covariate, do a recursive conversion if (j != 1) { # Process alphas, which are only present if there is more than one term in the feature # this implies that the feature is not a multiplication (i.e. only one _term_). - if ((nrow(feat) > 2 || feat[1,3] != 0) && feat[1,1] > 0) { + if ((nrow(feat) > 2 || feat[1, 3] != 0) && feat[1, 1] > 0) { if (alphas) fString <- paste0(fString, "?*") else fString <- paste0(fString, feat[j,3], "*") } - fString <- paste0(fString, print.feature(x[[feat[j, 2]]], dataset, alphas, labels, round), op) + fString <- paste0(fString, print.feature(x[[feat[j, 2]]], dataset, fixed, alphas, labels, round), op) } } fString <- paste0(fString, ")") } # This is a plain covariate else if (is.numeric(feat)) { - if (dataset) fString <- paste0("data[,", feat+2, "]") - else if (labels[1] != F) fString <- labels[feat] + if (dataset) fString <- paste0("data$x[,", fixed + feat, "]") + else if (labels[1] != FALSE) fString <- labels[feat] else fString <- paste0("x", feat) } else stop("Invalid feature structure") return(fString) diff --git a/R/feature_generation.R b/R/feature_generation.R index 7d25b3e54abd1052d8507d79249efcb68c461a08..5ddd3a980b91568cf385016d3ce4458bbd750721 100644 --- a/R/feature_generation.R +++ b/R/feature_generation.R @@ -1,4 +1,4 @@ -# Title : Features generation for use in GMJMCMC +# Title : Features generation for use in GMJMCMC (Genetically Modified MJMCMC) # Objective : Generate features for use in GMJMCMC at the population transition step # Created by: jonlachmann # Created on: 2021-02-10 @@ -6,13 +6,13 @@ # Generate a multiplication feature gen.multiplication <- function (features, marg.probs) { # Sample two features to be multiplied - feats <- sample.int(n = length(features), size = 2, prob = marg.probs, replace = T) + feats <- sample.int(n = length(features), size = 2, prob = marg.probs+0.00001, replace = TRUE) create.feature(0, features[feats]) } # Generate a modification feature gen.modification <- function (features, marg.probs, trans.probs, trans.priors) { - feat <- sample.int(n = length(features), size = 1, prob = marg.probs) + feat <- sample.int(n = length(features), size = 1, prob = marg.probs+0.00001) trans <- sample.int(n = length(trans.probs), size = 1, prob = trans.probs) create.feature(trans, features[feat], trans.priors) } @@ -23,7 +23,7 @@ gen.projection <- function (features, marg.probs, trans.probs, max.width, max.si max.width <- min(max.width, max.size + 1) } feat.count <- sample.int(n = (min(max.width, (length(features)))-1), size = 1) - feats <- sample.int(n = length(features), size = feat.count, prob = marg.probs) + feats <- sample.int(n = length(features), size = feat.count, prob = marg.probs+0.00001) trans <- sample.int(n = length(trans.probs), size = 1, prob = trans.probs) # TODO: Generate alphas properly using various methods alphas <- rep(1, length(feats)+1) @@ -37,7 +37,7 @@ gen.new <- function (features, F.0.size) { } # Select a feature to generate and generate it -gen.feature <- function (features, marg.probs, data, loglik.alpha, probs, F.0.size, params) { +gen.feature <- function (features, marg.probs, data, loglik.alpha, probs, F.0.size, params, verbose = TRUE) { tries <- 0 feat.ok <- F while (!feat.ok && tries < 50) { @@ -49,8 +49,8 @@ gen.feature <- function (features, marg.probs, data, loglik.alpha, probs, F.0.si # Check that the feature is not too wide or deep if (!(depth.feature(feat) > params$D || width.feature(feat) > params$L)) { # Generate alphas using the strategy chosen - if (params$alpha > 0) { - feat <- gen.alphas(params$alpha, feat, data, loglik.alpha) + if (params$alpha != "unit") { + feat <- gen.alphas(params$alpha, feat, data, loglik.alpha, verbose) } if (!is.null(feat)) { # Check for linear dependence of new the feature @@ -75,26 +75,30 @@ check.collinearity <- function (proposal, features, F.0.size, data, mock) { # Add the proposal to the feature list for evaluation features[[length(features) + 1]] <- proposal # Generate mock data to test with (avoiding too costly computations) - if (mock) - mock.data <- matrix(c(runif((F.0.size * 2), -100, 100), rep(1, F.0.size * 2), - runif((F.0.size * 2) * (F.0.size), -100, 100)), F.0.size * 2, F.0.size + 2) - else - mock.data <- check.data(data[seq_len(min(F.0.size * 2, dim(data)[1])), ]) + n <- F.0.size * 2 + if (mock) { + mock.data <- list(x = matrix(runif(n * (F.0.size + data$fixed), -100, 100), n, F.0.size + data$fixed), + y = matrix(runif(n * (ncol(data$y)), -100, 100), n, ncol(data$y)), + fixed = data$fixed) + } else { + obs_idx <- seq_len(min(n, nrow(data$x))) + mock.data <- list(x = data$x[obs_idx, ], y = data$y[obs_idx, ], fixed = data$fixed) + } # Use the mock data to precalc the features mock.data.precalc <- precalc.features(mock.data, features) # Fit a linear model with the mock data precalculated features - linearmod <- lm(as.data.frame(mock.data.precalc[, -2])) + linearmod <- lm.fit(mock.data.precalc$x, mock.data.precalc$y) # Check if all coefficients were possible to calculate if (sum(is.na(linearmod$coefficients)) == 0) return(FALSE) else return(TRUE) } # Generate features to represent the covariates, just takes the count needed -gen.covariates <- function (count) { +gen.covariates <- function (data) { features <- list() - for (i in 1:count) { + for (i in seq_len(ncol(data$x) - data$fixed)) { features <- c(features, i) - class(features[[i]]) <- "feature" + class(features[[length(features)]]) <- "feature" } return(features) } \ No newline at end of file diff --git a/R/functions.R b/R/functions.R index 08d4a3b94aa5b2469214991288a791a719d3e44c..9b43b27eaf45111cd62f17ec315bd76efdb30e21 100644 --- a/R/functions.R +++ b/R/functions.R @@ -18,7 +18,7 @@ replace.infinite.data.frame <- function(df, replacewith = c(.Machine$double.xmin } # Print a progress bar while iterating over a population -print.progressbar <- function (progress, size=40) { +print_progressbar <- function (progress, size=40) { cat("\r", "|") for (p in 1:size-1) { if (progress >= p) cat("=") @@ -29,7 +29,7 @@ print.progressbar <- function (progress, size=40) { } # Print a distribution as a horizontal histogram -print.dist <- function(probs, labels, threshold, size=30) { +print_dist <- function(probs, labels, threshold, size=30) { threshold <- round((1 - threshold) * size) for (i in seq_along(probs)) { for (p in 1:size - 1) { @@ -43,7 +43,7 @@ print.dist <- function(probs, labels, threshold, size=30) { } # A more intuitive sample function which does not change behaviour when length(x) == 1. -sample2 <- function(x, size, replace = F, prob = NULL) { +sample2 <- function(x, size, replace = FALSE, prob = NULL) { if (length(x) == 1) return(x) base::sample(x, size = size, replace = replace, prob = prob) } \ No newline at end of file diff --git a/R/gmjmcmc.R b/R/gmjmcmc.R index 11a123b94fd98a98ba3506b9a38d24a825ff1b92..b29e6d40d36da587e8735a17b80580c50637e30b 100644 --- a/R/gmjmcmc.R +++ b/R/gmjmcmc.R @@ -4,42 +4,102 @@ # Created on: 2021-02-11 # Allow the package to access Rcpp functions -#' @useDynLib GMJMCMC +#' @useDynLib FBMS #' @importFrom Rcpp sourceCpp NULL -#' Main algorithm for GMJMCMC -#' TODO: More documentation - borrow from https://github.com/aliaksah/EMJMCMC2016/blob/master/man/EMJMCMC.Rd if applicable. +#' Main algorithm for GMJMCMC (Genetically Modified MJMCMC) #' -#' @param data A matrix containing the data to use in the algorithm, -#' first column should be the dependent variable, second should be the intercept -#' and the rest of the columns should be the independent variables. -#' @param loglik.pi The (log) density to explore -#' @param loglik.alpha The likelihood function to use for alpha calculation -#' @param transforms A Character vector including the names of the non-linear functions to be used by the modification -#' and the projection operator. -#' @param P The number of generations for GMJMCMC. -#' The default value is $P = 10$. -#' A larger value like $P = 50$ might be more realistic for more complicated examples where one expects a lot of non-linear structures. -#' @param N.init The number of iterations per population (total iterations = (T-1)*N.init+N.final) -#' @param N.final The number of iterations for the final population (total iterations = (T-1)*N.init+N.final) -#' @param probs A list of the various probability vectors to use -#' @param params A list of the various parameters for all the parts of the algorithm -#' @param sub An indicator that if the likelihood is inexact and should be improved each model visit (EXPERIMENTAL!) +#' @param x matrix containing the design matrix with data to use in the algorithm +#' @param y response variable +#' @param transforms A character vector including the names of the non-linear functions to be used by the modification and the projection operator. +#' @param P The number of population iterations for GMJMCMC. The default value is P = 10, which was used in our initial example for illustrative purposes. However, a larger value, such as P = 50, is typically more appropriate for most practical applications. +#' @param N The number of MJMCMC iterations per population. +#' The default value is N = 100; however, for real applications, a larger value such as N = 1000 or higher is often preferable. +#' @param N.final The number of MJMCMC iterations performed for the final population. Per default one has N.final = N, but for practical applications, a much larger value (e.g., N.final = 1000) is recommended. Increasing N.final is particularly important if predictions and inferences are based solely on the last population. +#' @param probs A list of various probability vectors used by GMJMCMC, generated by \code{gen.probs.gmjmcmc}. +#' The key component \code{probs.gen} defines probabilities of different operators in the feature generation process. +#' Defaults typically favor interactions and modifications (0.4 each) over projections and mutations (0.1 each) to encourage interpretable nonlinear features. +#' @param params A list of various parameter vectors used by GMJMCMC, generated by \code{gen.params.gmjmcmc}. +#' @param loglik.pi A function specifying the marginal log-posterior of the model up to a constant, including the logarithm of the model prior: +#' \eqn{\log p(M|Y) = \text{const} + \log p(Y|M) + \log p(M)}. +#' Typically assumes a Gaussian model with Zellner'swith \eqn{g = max(n,p^2) by default}. +#' @param loglik.alpha Relevant only if the non-linear projection features depend on parameters \eqn{\alpha}. +#' If \eqn{\alpha} is estimated, this argument specifies the corresponding marginal log-likelihood. +#' The default method sets all \eqn{\alpha} to 1 (fastest, but sometimes suboptimal). +#' Alternative estimation strategies ("deep" and "random") are implemented in \pkg{FBMS}. +#' @param mlpost_params All parameters for the estimator function loglik.pi +#' @param intercept Logical. Whether to include an intercept in the design matrix. Default is \code{TRUE}. No variable selection is performed on the intercept. +#' @param fixed Integer specifying the number of leading columns in the design matrix to always include in the model. Default is 0. +#' @param sub Logical. If \code{TRUE}, uses subsampling or a stochastic approximation approach to the likelihood rather than the full likelihood. Default is \code{FALSE}. +#' @param verbose Logical. Whether to print messages during execution. Default is \code{TRUE} for \code{gmjmcmc} and \code{FALSE} for the parallel version. +#' +#' @return A list containing the following elements: +#' \item{models}{All models per population.} +#' \item{mc.models}{All models accepted by mjmcmc per population.} +#' \item{populations}{All features per population.} +#' \item{marg.probs}{Marginal feature probabilities per population.} +#' \item{model.probs}{Marginal feature probabilities per population.} +#' \item{model.probs.idx}{Marginal feature probabilities per population.} +#' \item{best.margs}{Best marginal model probability per population.} +#' \item{accept}{Acceptance rate per population.} +#' \item{accept.tot}{Overall acceptance rate.} +#' \item{best}{Best marginal model probability throughout the run, represented as the maximum value in \code{unlist(best.margs)}.} +#' +#' @examples +#' result <- gmjmcmc(y = matrix(rnorm(100), 100), +#' x = matrix(rnorm(600), 100), +#' P = 2, +#' transform = c("p0", "exp_dbl")) +#' summary(result) +#' plot(result) #' #' @export gmjmcmc -gmjmcmc <- function (data, loglik.pi = gaussian.loglik, loglik.alpha = gaussian.loglik.alpha, transforms, P = 10, N.init = 100, N.final = 100, probs = NULL, params = NULL, sub = FALSE) { +gmjmcmc <- function ( + x, + y, + transforms, + P = 10, + N = 100, + N.final = NULL, + probs = NULL, + params = NULL, + loglik.pi = NULL, + loglik.alpha = gaussian.loglik.alpha, + mlpost_params = list(family = "gaussian", beta_prior = list(type = "g-prior")), + intercept = TRUE, + fixed = 0, + sub = FALSE, + verbose = TRUE +) { # Verify that the data is well-formed - data <- check.data(data) + if (intercept) { + x <- cbind(1, x) + fixed <- fixed + 1 + } + data <- check.data(x, y, fixed, verbose) + if (is.null(loglik.pi)) { + if (is.null(mlpost_params$beta_prior$type) || is.null(mlpost_params$family)) + stop("mlpost_params$beta_prior and mlpost_params$family must be specified") + loglik.pi <- select.mlpost.fun(mlpost_params$beta_prior$type, mlpost_params$family) + if (mlpost_params$family == "gaussian") + mlpost_params$beta_prior <- gen.mlpost.params.lm(mlpost_params$beta_prior$type, mlpost_params$beta_prior, ncol(data$x) - 1, nrow(data$x)) + else { + mlpost_params$beta_prior <- gen.mlpost.params.glm(mlpost_params$beta_prior$type, mlpost_params$beta_prior, ncol(data$x) - 1, nrow(data$x)) + mlpost_params$beta_prior$type <- mlpost_params$beta_prior$type + } + + } + # Generate default probabilities and parameters if there are none supplied. if (is.null(probs)) probs <- gen.probs.gmjmcmc(transforms) - if (is.null(params)) params <- gen.params.gmjmcmc(data) - + if (is.null(params)) params <- gen.params.gmjmcmc(ncol(data$x) - data$fixed) + if (!is.null(mlpost_params)) params$mlpost <- mlpost_params # Extract labels from column names in dataframe - labels <- get.labels(data) + labels <- get.labels(data, verbose) # Set the transformations option - options("gmjmcmc-transformations" = transforms) + set.transforms(transforms) # Acceptance probability per population accept <- vector("list", P) accept <- lapply(accept, function (x) x <- 0) @@ -47,7 +107,7 @@ gmjmcmc <- function (data, loglik.pi = gaussian.loglik, loglik.alpha = gaussian. S <- vector("list", P) # A list of models that have been visited, refering to the populations models <- vector("list", P) - lo.models <- vector("list", P) + mc.models <- vector("list", P) # A list of all the marginal probabilities for the features, per population marg.probs <- vector("list", P) # A list of all the marginal probabilities for the models, per population @@ -58,37 +118,39 @@ gmjmcmc <- function (data, loglik.pi = gaussian.loglik, loglik.alpha = gaussian. best.margs <- vector("list", P) # Create first population - F.0 <- gen.covariates(ncol(data) - 2) - if (is.null(params$feat$prel.filter)) + F.0 <- gen.covariates(data) + if (is.null(params$prel.select)) S[[1]] <- F.0 else - S[[1]] <- F.0[params$feat$prel.filter] + S[[1]] <- F.0[params$prel.select] complex <- complex.features(S[[1]]) + if(length(N.final) == 0) + N.final <- N ### Main algorithm loop - Iterate over P different populations + N.this <- N for (p in seq_len(P)) { # Set population iteration count - if (p != P) N <- N.init - else N <- N.final + if (p == P) N.this <- N.final # Precalculate covariates and put them in data.t if (length(params$feat$prel.filter) > 0 | p != 1) data.t <- precalc.features(data, S[[p]]) else data.t <- data # Initialize first model of population model.cur <- as.logical(rbinom(n = length(S[[p]]), size = 1, prob = 0.5)) - model.cur.res <- loglik.pre(loglik.pi, model.cur, complex, data.t, params$loglik) + model.cur.res <- loglik.pre(loglik.pi, model.cur, complex, data.t, params$mlpost, NULL, FALSE) model.cur <- list(prob = 0, model = model.cur, coefs = model.cur.res$coefs, crit = model.cur.res$crit, alpha = 0) best.crit <- model.cur$crit # Reset first best criteria value # Run MJMCMC over the population - cat(paste("Population", p, "begin.")) - mjmcmc_res <- mjmcmc.loop(data.t, complex, loglik.pi, model.cur, N, probs, params, sub) - cat(paste("\nPopulation", p, "done.\n")) + if (verbose) cat(paste("Population", p, "begin.")) + mjmcmc_res <- mjmcmc.loop(data.t, complex, loglik.pi, model.cur, N.this, probs, params, sub, verbose) + if (verbose) cat(paste("\nPopulation", p, "done.\n")) # Add the models visited in the current population to the model list models[[p]] <- mjmcmc_res$models - lo.models[[p]] <- mjmcmc_res$lo.models + mc.models[[p]] <- mjmcmc_res$mc.models # Store marginal likelihoods for current features marg.probs[[p]] <- mjmcmc_res$marg.probs # Store marginal likelihoods for the visited models @@ -97,26 +159,30 @@ gmjmcmc <- function (data, loglik.pi = gaussian.loglik, loglik.alpha = gaussian. model.probs.idx[[p]] <- mjmcmc_res$model.probs.idx # Store best marginal model probability for current population best.margs[[p]] <- mjmcmc_res$best.crit + # Store the accepted number of steps for the current population + accept[[p]] <- mjmcmc_res$accept # Print the marginal posterior distribution of the features after MJMCMC - cat(paste("\rCurrent best crit:", mjmcmc_res$best.crit, "\n")) - cat("Feature importance:\n") - print.dist(marg.probs[[p]], sapply(S[[p]], print.feature, labels = labels, round = 2), probs$filter) + if (verbose) { + cat(paste("\rCurrent best crit:", mjmcmc_res$best.crit, "\n")) + cat("Feature importance:\n") + print_dist(marg.probs[[p]], sapply(S[[p]], print.feature, labels = labels, round = 2), probs$filter) + } if (params$rescale.large) prev.large <- params$large # Generate a new population of features for the next iteration (if this is not the last) if (p != P) { - S[[p + 1]] <- gmjmcmc.transition(S[[p]], F.0, data, loglik.alpha, marg.probs[[1]], marg.probs[[p]], labels, probs, params$feat) + S[[p + 1]] <- gmjmcmc.transition(S[[p]], F.0, data, loglik.alpha, marg.probs[[1]], marg.probs[[p]], labels, probs, params$feat, verbose) complex <- complex.features(S[[p + 1]]) if (params$rescale.large) params$large <- lapply(prev.large, function(x) x * length(S[[p + 1]]) / length(S[[p]])) } } # Calculate acceptance rate - accept.tot <- sum(unlist(accept)) / (N.init * (P - 1) + N.final) - accept <- lapply(accept, function (x) x / N.init) - accept[[P]] <- accept[[P]] * N.init / N.final + accept.tot <- sum(unlist(accept)) / (N * (P - 1) + N.final) + accept <- lapply(accept, function (x) x / N) + accept[[P]] <- accept[[P]] * N / N.final # Return formatted results results <- list( models = models, # All models per population - lo.models = lo.models, # All local optim models per population + mc.models = mc.models, # Only mjmcmc models per population populations = S, # All features per population marg.probs = marg.probs, # Marginal feature probabilities per population model.probs = model.probs, # Marginal feature probabilities per population @@ -124,14 +190,19 @@ gmjmcmc <- function (data, loglik.pi = gaussian.loglik, loglik.alpha = gaussian. best.margs = best.margs, # Best marginal model probability per population accept = accept, # Acceptance rate per population accept.tot = accept.tot, # Overall acceptance rate - best = max(unlist(best.margs)) # Best marginal model probability throughout the run + best = max(unlist(best.margs)), # Best marginal model probability throughout the run + transforms = transforms # Transformations used by the model ) + results$labels <- labels + results$fixed <- fixed + results$intercept <- intercept + results$ncov <- ncol(data$x) - data$fixed attr(results, "class") <- "gmjmcmc" return(results) } -#' Subalgorithm for generating a new population of features in GMJMCMC +#' Subalgorithm for generating a new population of features in GMJMCMC (Genetically Modified MJMCMC) #' #' @param S.t The current population of features #' @param F.0 The initial population of features, i.e. the bare covariates @@ -142,9 +213,13 @@ gmjmcmc <- function (data, loglik.pi = gaussian.loglik, loglik.alpha = gaussian. #' @param labels Variable labels for printing #' @param probs A list of the various probability vectors to use #' @param params A list of the various parameters for all the parts of the algorithm +#' @param verbose A logical denoting if messages should be printed #' #' @return The updated population of features, that becomes S.t+1 -gmjmcmc.transition <- function (S.t, F.0, data, loglik.alpha, marg.probs.F.0, marg.probs, labels, probs, params) { +#' +#' @noRd +#' +gmjmcmc.transition <- function (S.t, F.0, data, loglik.alpha, marg.probs.F.0, marg.probs, labels, probs, params, verbose = TRUE) { # Sample which features to keep based on marginal inclusion below probs$filter feats.keep <- as.logical(rbinom(n = length(marg.probs), size = 1, prob = pmin(marg.probs / probs$filter, 1))) @@ -153,17 +228,24 @@ gmjmcmc.transition <- function (S.t, F.0, data, loglik.alpha, marg.probs.F.0, ma if (params$prel.filter > 0) { # Do preliminary filtering if turned on feats.keep[(seq_along(F.0))[marg.probs.F.0 > params$prel.filter]] <- T - #removed.count <- sum(marg.probs.F.0 <= params$prel.filter) - #cat("Preliminary filtering removed",removed.count,"features.") } # Keep all if no preliminary filtering else feats.keep[seq_along(F.0)] <- T } # Avoid removing too many features - if (length(feats.keep) > 0 && mean(feats.keep) < params$keep.min) { + if (length(feats.keep) > 0 && mean(feats.keep) < params$keep.min & sum(feats.keep) < params$pop.max/2) { feats.add.n <- round((params$keep.min - mean(feats.keep)) * length(feats.keep)) feats.add <- sample(which(!feats.keep), feats.add.n) - feats.keep[feats.add] <- T + if ((length(feats.add) + sum(feats.keep)) >= params$pop.max) + feats.keep[feats.add] <- T + } + + if (sum(feats.keep)>params$pop.max) { + warning("Number of features to keep greater than pop.max! + Continue with first pop.max features to be kept! + \n Ignore if the final set of features with high probabilities is smaller than the specified $feat$pop.max + \n Otherwise check your tuning parameters and increase $feat$pop.max or probs$filter!") + feats.keep[which(feats.keep==TRUE)[(params$pop.max+1):length(which(feats.keep==TRUE))]] <- FALSE } # Create a list of which features to replace @@ -174,30 +256,39 @@ gmjmcmc.transition <- function (S.t, F.0, data, loglik.alpha, marg.probs.F.0, ma marg.probs.use <- c(rep(params$eps, length(F.0)), pmin(pmax(marg.probs, params$eps), (1-params$eps))) # Perform the replacements + if (length(S.t) > params$pop.max) + feats.replace <- sort(feats.replace,decreasing = T) for (i in feats.replace) { prev.size <- length(S.t) - prev.feat.string <- print.feature(S.t[[i]], labels=labels, round = 2) - S.t[[i]] <- gen.feature(c(F.0, S.t), marg.probs.use, data, loglik.alpha, probs, length(F.0), params) - if (prev.size > length(S.t)) { + prev.feat.string <- print.feature(S.t[[i]], labels = labels, round = 2) + if (prev.size > params$pop.max) { cat("Removed feature", prev.feat.string, "\n") - cat("Population shrinking, returning.\n") - return(S.t) + S.t[[i]] <- NULL + } else { + S.t[[i]] <- gen.feature(c(F.0, S.t), marg.probs.use, data, loglik.alpha, probs, length(F.0), params, verbose) + if (prev.size > length(S.t)) { + if (verbose) { + cat("Removed feature", prev.feat.string, "\n") + cat("Population shrinking, returning.\n") + } + return(S.t) + } + if (verbose) cat("Replaced feature", prev.feat.string, "with", print.feature(S.t[[i]], labels=labels, round = 2), "\n") + feats.keep[i] <- T + marg.probs.use[i] <- mean(marg.probs.use) } - cat("Replaced feature", prev.feat.string, "with", print.feature(S.t[[i]], labels=labels, round = 2), "\n") - feats.keep[i] <- T - marg.probs.use[i] <- mean(marg.probs.use) } # Add additional features if the population is not at max size if (length(S.t) < params$pop.max) { for (i in (length(S.t)+1):params$pop.max) { prev.size <- length(S.t) - S.t[[i]] <- gen.feature(c(F.0, S.t), marg.probs.use, data, loglik.alpha, probs, length(F.0), params) + S.t[[i]] <- gen.feature(c(F.0, S.t), marg.probs.use, data, loglik.alpha, probs, length(F.0), params, verbose) if (prev.size == length(S.t)) { - cat("Population not growing, returning.\n") + if (verbose) cat("Population not growing, returning.\n") return(S.t) } - cat("Added feature", print.feature(S.t[[i]], labels=labels, round = 2), "\n") + if (verbose) cat("Added feature", print.feature(S.t[[i]], labels=labels, round = 2), "\n") marg.probs.use <- c(marg.probs.use, params$eps) } } diff --git a/R/gmjmcmc_support.R b/R/gmjmcmc_support.R index dca529a72e03401e9c930b5def89e0d5d19aea09..8a58fd7c9ee9275705682fb03e138eb7512dddc2 100644 --- a/R/gmjmcmc_support.R +++ b/R/gmjmcmc_support.R @@ -1,16 +1,24 @@ # Title : GMJMCMC Support functions -# Objective : Support functions for GMJMCMC algorithm +# Objective : Support functions for GMJMCMC (Genetically Modified MJMCMC) algorithm # Created by: jonlachmann # Created on: 2021-02-11 -#' Set the transformations option for GMJMCMC, +#' Set the transformations option for GMJMCMC (Genetically Modified MJMCMC), #' this is also done when running the algorithm, but this function allows for it to be done manually. #' #' @param transforms The vector of non-linear transformations #' +#' @return No return value, just sets the gmjmcmc-transformations option +#' +#' @examples +#' set.transforms(c("p0","p1")) +#' +#' #' @export set.transforms set.transforms <- function (transforms) { - options("gmjmcmc-transformations"=transforms) + old_transforms <- getOption("gmjmcmc-transformations") + options("gmjmcmc-transformations" = transforms) + return(old_transforms) } # Function to verify inputs and help the user find if they did anything wrong @@ -32,6 +40,16 @@ verify.inputs <- function (data, loglik.pi, transforms, T, N, N.final, probs, pa #' Function for calculating marginal inclusion probabilities of features given a list of models #' @param models The list of models to use. +#' +#' @return A numeric vector of marginal model probabilities based on relative frequencies of model visits in MCMC. +#' +#' @examples +#' result <- gmjmcmc(x = matrix(rnorm(600), 100), +#' y = matrix(rnorm(100), 100), +#' P = 2, +#' transforms = c("p0", "exp_dbl")) +#' marginal.probs(result$models[[1]]) +#' #' @export marginal.probs <- function (models) { mod.count <- length(models) @@ -46,13 +64,18 @@ marginal.probs <- function (models) { #' Function for calculating feature importance through renormalized model estimates #' @param models The models to use. #' @param type Select which probabilities are of interest, features or models +#' +#' @noRd marginal.probs.renorm <- function (models, type = "features") { models <- lapply(models, function (x) x[c("model", "crit")]) model.size <- length(models[[1]]$model) models.matrix <- matrix(unlist(models), ncol = model.size + 1, byrow = TRUE) duplicates <- duplicated(models.matrix[, 1:(model.size)], dim = 1, fromLast = TRUE) models.matrix <- models.matrix[!duplicates, ] - max_mlik <- max(models.matrix[, (model.size + 1)]) + if(!is.matrix(models.matrix)) + models.matrix <- t(as.matrix(models.matrix)) + + max_mlik <- max(models.matrix[,(model.size + 1)]) crit.sum <- sum(exp(models.matrix[, (model.size + 1)] - max_mlik)) if (type == "features" || type == "both") { probs.f <- matrix(NA,1, model.size) @@ -76,29 +99,37 @@ marginal.probs.renorm <- function (models, type = "features") { # Function for precalculating features for a new feature population precalc.features <- function (data, features) { - precalc <- matrix(NA, nrow(data), length(features) + 2) - precalc[, 1:2] <- data[, 1:2] + precalc <- matrix(NA, nrow(data$x), length(features)) for (f in seq_along(features)) { - feature_string <- print.feature(features[[f]], dataset = TRUE) - precalc[, (f + 2)] <- eval(parse(text = feature_string)) + feature_string <- print.feature(features[[f]], dataset = TRUE, fixed = data$fixed) + precalc[, f] <- eval(parse(text = feature_string)) } # Replace any -Inf and Inf values caused by under- or overflow precalc <- replace.infinite.data.frame(precalc) - return(precalc) + data$x <- cbind(data$x[, seq_len(data$fixed)], precalc) + return(data) } # TODO: Compare to previous mliks here instead, also add a flag to do that in full likelihood estimation scenarios. # Function to call the model function -loglik.pre <- function (loglik.pi, model, complex, data, params = NULL) { +loglik.pre <- function (loglik.pi, model, complex, data, params = NULL, visited.models, sub) { + if (!is.null(visited.models) && has_key(visited.models, model)) { + if (!sub) { + return(visited.models[[model]]) + } else { + params$coefs <- visited.models[[model]]$coefs + params$crit <- visited.models[[model]]$crit + } + } # Get the complexity measures for just this model complex <- list(width = complex$width[model], oc = complex$oc[model], depth = complex$depth[model]) # Call the model estimator with the data and the model, note that we add the intercept to every model - model.res <- loglik.pi(data[, 1], data[, -1], c(T, model), complex, params) + model.res <- loglik.pi(data$y, data$x, c(rep(TRUE, data$fixed), model), complex, params) # Check that the critical value is acceptable if (!is.numeric(model.res$crit) || is.nan(model.res$crit)) model.res$crit <- -.Machine$double.xmax # Alpha cannot be calculated if the current and proposed models have crit which are -Inf or Inf if (is.infinite(model.res$crit)) { - if (model.res$crit > 0) model.res$crit <- .Machine$double.xmax + if (model.res$crit > 0) model.res$crit <- .Machine$double.xmax else model.res$crit <- -.Machine$double.xmax } return(model.res) @@ -107,34 +138,43 @@ loglik.pre <- function (loglik.pi, model, complex, data, params = NULL) { # Function to check the data # Checks that there is an intercept in the data, adds it if missing # Coerces the data to be of type matrix -check.data <- function (data) { - if (!is.matrix(data)) { - data <- as.matrix(data) - cat("Data coerced to matrix type.\n") +check.data <- function (x, y, fixed, verbose) { + if (!is.matrix(x)) { + x <- as.matrix(x) + #if (verbose) cat("Data (x) coerced to matrix type.\n") } - if (sum(data[, 2] == 1) != nrow(data)) { - data <- cbind(data[, 1], 1, data[, -1]) - cat("Intercept added to data.\n") + if (!is.matrix(y)) { + y <- as.matrix(y) + #if (verbose) cat("Data (y) coerced to matrix type.\n") + } + if (nrow(x) != nrow(y)) { + stop("x and y must have the same number of rows") } - return(data) -} -# Function to get the dimensions of a dataset, adding an intercept if necessary -data.dims <- function (data) { - dims <- dim(data) - if (sum(data[,2] == 1) != nrow(data)) { - dims[2] <- dims[2] + 1 + # Ensure that the first F0.size * 2 lines do not contain zero variance variables + if ((ncol(x) - fixed) * 2 < nrow(x)) { + vars <- diag(var(x[seq_len((ncol(x) - fixed) * 2), ])) + for (i in which(vars == 0)[-seq_len(fixed)]) { + j <- which(x[, i] != x[1, i])[1] + if (is.na(j)) { + stop(paste0("column with index ", i, " is constant and only the intercept may be constant, please remove it and try again.")) + } + x <- rbind(x[j, , drop = FALSE], x[-j, , drop = FALSE]) + y <- rbind(y[j, , drop = FALSE], y[-j, , drop = FALSE]) + } } - return(dims) + + return(list(x = x, y = y, fixed = fixed)) } # Function to extract column names if they are well formed -get.labels <- function (data) { - labels <- colnames(data)[-(1:2)] - if (is.null(labels)) return(F) +get.labels <- function (data, verbose) { + labels <- colnames(data$x) + if (is.null(labels)) return(FALSE) if (sum(is.na(labels)) != 0) { - cat("NA labels present, using x#\n") - return(F) + if (verbose) cat("NA labels present, using x#\n") + return(FALSE) } + if (data$fixed > 0) labels <- labels[-seq_len(data$fixed)] return(labels) -} \ No newline at end of file +} diff --git a/R/imports.R b/R/imports.R index 8018c3f7c60528b1004ad6d0608eb52575ea2e36..9c9287daedebcd26605031ca15ee1d669e2fc3a0 100644 --- a/R/imports.R +++ b/R/imports.R @@ -1,6 +1,9 @@ #' @importFrom GenSA GenSA #' @importFrom fastglm fastglm -#' @importFrom parallel mclapply -#' @importFrom stats rnorm runif lm pnorm lm.fit var rbinom acf binomial cor -#' @importFrom graphics barplot text -NULL \ No newline at end of file +#' @importFrom parallel mclapply parLapply detectCores makeCluster clusterEvalQ clusterExport stopCluster +#' @importFrom stats rnorm runif lm pnorm lm.fit var rbinom acf binomial cor gaussian median qnorm sd model.matrix model.response predict as.formula +#' @importFrom graphics barplot text lines +#' @importFrom utils sessionInfo +#' @importFrom r2r hashmap has_key +#' @importFrom methods is +NULL diff --git a/R/likelihoods.R b/R/likelihoods.R index 061dbae977cbae8c23779c2234d992d15c81a958..e3481c575c5431722c3d0ba0fd5f8d533fa5efbd 100644 --- a/R/likelihoods.R +++ b/R/likelihoods.R @@ -3,7 +3,7 @@ # Created by: jonlachmann # Created on: 2021-02-24 -#' Log likelihood function for logistic regression with a prior p(m)=sum(total_width) +#' Log likelihood function for glm regression with parameter priors from BAS package #' This function is created as an example of how to create an estimator that is used #' to calculate the marginal likelihood of a model. #' @@ -11,48 +11,511 @@ #' @param x The matrix containing the precalculated features #' @param model The model to estimate as a logical vector #' @param complex A list of complexity measures for the features -#' @param params A list of parameters for the log likelihood, supplied by the user +#' @param mlpost_params A list of parameters for the log likelihood, supplied by the user, important to specify the tuning parameters of beta priors and family that BAS uses in glm models +#' +#' @return A list with the log marginal likelihood combined with the log prior (crit) and the posterior mode of the coefficients (coefs). +#' +#' @examples +#' glm.logpost.bas(as.integer(rnorm(100) > 0), +#' cbind(1, matrix(rnorm(100))), +#' c(TRUE, TRUE), +#' list(oc = 1)) +#' +#' @importFrom BAS uniform Jeffreys g.prior +#' @importFrom stats poisson Gamma glm.control +#' @export glm.logpost.bas +glm.logpost.bas <- function (y, x, model, complex, mlpost_params = list(r = NULL, family = "binomial", beta_prior = Jeffreys(), laplace = FALSE)) { + if (length(mlpost_params) == 0) + mlpost_params <- list(r = 1 / dim(x)[1], family = "binomial", beta_prior = g.prior(max(dim(x)[1], sum(model) - 1)), laplace = FALSE) + else if(length(mlpost_params$r) == 0) + mlpost_params$r = 1 / dim(x)[1] + if(length(mlpost_params$laplace) == 0) + mlpost_params$laplace = FALSE + p <- sum(model) - 1 + if (p == 0) { + probinit <- as.numeric(c(1, 0.99)) + model[2] <- T + } else { + probinit <- as.numeric(c(1, rep(0.99, p))) + } + + + mod <- NULL + + if (mlpost_params$family == "binomial") + family_use <- binomial() + else if (mlpost_params$family == "poisson") + family_use <- poisson() + else + family_use <- Gamma() + + + tryCatch({ suppressWarnings({ + mod <- .Call( + BAS:::C_glm_deterministic, + y = as.numeric(y), + X = as.matrix(x[, model]), + Roffset = as.numeric(rep(0, length(y))), + Rweights = as.numeric(rep(1, length(y))), + Rprobinit = probinit, + Rmodeldim = as.integer(rep(0, ifelse(p == 0,2,1))), + modelprior = uniform(), + betaprior = mlpost_params$beta_prior, + family = family_use, + Rcontrol = glm.control(), + Rlaplace = as.integer(mlpost_params$laplace) + ) + }) + }, error = function(e) { + # Handle the error by setting result to NULL + mod <- NULL + # You can also print a message or log the error if needed + cat("An error occurred:", conditionMessage(e), "\n") + }) + + if (length(mod) == 0 || is.nan(mod$logmarg[2])) { + return(list(crit = -.Machine$double.xmax + log_prior(mlpost_params, complex), coefs = rep(0, p + 1))) + } + + if (p == 0) { + ret <- mod$logmarg[2] + log(mlpost_params$r) * sum(complex$oc) + return(list(crit = ret, coefs = mod$mle[[2]])) + } + ret <- mod$logmarg + log(mlpost_params$r) * sum(complex$oc) + return(list(crit = ret, coefs = mod$mle[[1]])) +} + + +#' Log likelihood function for Gaussian regression with parameter priors from BAS package +#' This function is created as an example of how to create an estimator that is used +#' to calculate the marginal likelihood of a model. +#' +#' @param y A vector containing the dependent variable +#' @param x The matrix containing the precalculated features +#' @param model The model to estimate as a logical vector +#' @param complex A list of complexity measures for the features +#' @param mlpost_params A list of parameters for the log likelihood, supplied by the user, important to specify the tuning parameters of beta priors where the corresponding integers as prior_beta must be provided "g-prior" = 0, "hyper-g" = 1, "EB-local" = 2, "BIC" = 3, "ZS-null" = 4, "ZS-full" = 5, "hyper-g-laplace" = 6, "AIC" = 7, "EB-global" = 2, "hyper-g-n" = 8, "JZS" = 9 and in Gaussian models +#' +#' @return A list with the log marginal likelihood combined with the log prior (crit) and the posterior mode of the coefficients (coefs). +#' +#' @examples +#' lm.logpost.bas(rnorm(100), cbind(1,matrix(rnorm(100))), c(TRUE,TRUE), list(oc = 1)) +#' +#' +#' @export lm.logpost.bas +lm.logpost.bas <- function (y, x, model, complex, mlpost_params = list(r = exp(-0.5), beta_prior = list(method = 1))) { + if (length(mlpost_params) == 0) + mlpost_params <- list( + r = 1 / dim(x)[1], + beta_prior = list(method = 0, alpha = max(dim(x)[1], sum(model)^2)) + ) else if(length(mlpost_params$r) == 0) mlpost_params$r = 1 / dim(x)[1] + + p <- sum(model) - 1 + if (p == 0) { + probinit <- as.numeric(c(1, 0.99)) + model[2] <- T + } else { + probinit <- as.numeric(c(1, rep(0.99, p))) + } + + mod <- NULL + + tryCatch({ + suppressWarnings({ + mod <- .Call(BAS:::C_deterministic, + y = y, X = as.matrix(x[, model]), + as.numeric(rep(1, length(y))), + probinit, + as.integer(rep(0, ifelse(p == 0,2,1))), + incint = as.integer(F), + alpha = ifelse(length(mlpost_params$beta_prior$a) > 0, as.numeric(mlpost_params$beta_prior$a), NULL), + method = as.integer(mlpost_params$beta_prior$method), + modelprior = uniform(), + Rpivot = TRUE, + Rtol = 1e-7) + }) + }, error = function(e) { + # Handle the error by setting result to NULL + mod <- NULL + # You can also print a message or log the error if needed + cat("An error occurred:", conditionMessage(e), "\n") + }) + + if (length(mod) == 0 || is.nan(mod$logmarg[2])) { + return(list(crit = -.Machine$double.xmax + log_prior(mlpost_params, complex), coefs = rep(0, p + 1))) + } + + if (p == 0) { + ret <- mod$logmarg[2] + log(mlpost_params$r) * sum(complex$oc) + return(list(crit = ret, coefs = mod$mle[[2]])) + } + ret <- mod$logmarg + log(mlpost_params$r) * sum(complex$oc) + return(list(crit = ret, coefs = mod$mle[[1]])) +} + + +#' Log likelihood function for logistic regression with a Jeffreys parameter prior and BIC approximations of the posterior +#' This function is created as an example of how to create an estimator that is used +#' to calculate the marginal likelihood of a model. +#' +#' @param y A vector containing the dependent variable +#' @param x The matrix containing the precalculated features +#' @param model The model to estimate as a logical vector +#' @param complex A list of complexity measures for the features +#' @param mlpost_params A list of parameters for the log likelihood, supplied by the user +#' +#' @return A list with the log marginal likelihood combined with the log prior (crit) and the posterior mode of the coefficients (coefs). +#' +#' @examples +#' logistic.loglik(as.integer(rnorm(100) > 0), matrix(rnorm(100)), TRUE, list(oc = 1)) +#' #' #' @export logistic.loglik -logistic.loglik <- function (y, x, model, complex, params = list(r = 1)) { +logistic.loglik <- function (y, x, model, complex, mlpost_params = list(r = exp(-0.5))) { + if (length(mlpost_params) == 0) + mlpost_params <- list(r = 1 / dim(x)[1]) + else if(length(mlpost_params$r) == 0) + mlpost_params$r = 1 / dim(x)[1] suppressWarnings({mod <- fastglm(as.matrix(x[, model]), y, family = binomial())}) - ret <- (-(mod$deviance -2 * log(params$r) * sum(complex$oc))) / 2 - return(list(crit=ret, coefs=mod$coefficients)) + + if (length(mod) == 0 || is.nan(mod$deviance)) { + return(list(crit = -.Machine$double.xmax + log_prior(mlpost_params, complex), coefs = rep(0, sum(model)))) + } + + + ret <- (-(mod$deviance + log(length(y)) * (mod$rank - 1) - 2 * log(mlpost_params$r) * sum(complex$oc))) / 2 + return(list(crit = ret, coefs = mod$coefficients)) } -#' Log likelihood function for logistic regression for alpha calculation -#' This function is just the bare likelihood function +#' Log likelihood function for glm regression with a Jeffreys parameter prior and BIC approximations of the posterior +#' This function is created as an example of how to create an estimator that is used +#' to calculate the marginal likelihood of a model. #' -#' @param a A vector of the alphas to be used -#' @param data The data to be used for calculation -#' @param mu_func The function linking the mean to the covariates, -#' as a string with the alphas as a[i]. +#' @param y A vector containing the dependent variable +#' @param x The matrix containing the precalculated features +#' @param model The model to estimate as a logical vector +#' @param complex A list of complexity measures for the features +#' @param mlpost_params A list of parameters for the log likelihood, supplied by the user, family must be specified #' -#' @export logistic.loglik.alpha -logistic.loglik.alpha <- function (a, data, mu_func) { - m <- 1 / (1 + exp(-eval(parse(text = mu_func)))) - -sum((data[,1] * log(m) + (1 - data[, 1]) * log(1 - m))) +#' @return A list with the log marginal likelihood combined with the log prior (crit) and the posterior mode of the coefficients (coefs). +#' +#' @examples +#' glm.loglik(abs(rnorm(100))+1, matrix(rnorm(100)), TRUE, list(oc = 1)) +#' +#' +#' @export glm.loglik +glm.loglik <- function (y, x, model, complex, mlpost_params = list(r = exp(-0.5), family = "Gamma")) { + if (length(mlpost_params) == 0) + mlpost_params <- list(r = 1 / dim(x)[1]) + else if(length(mlpost_params$r) == 0) + mlpost_params$r = 1 / dim(x)[1] + + if (mlpost_params$family == "binomial") { + fam = binomial() + } else if (mlpost_params$family == "poisson") { + fam = poisson() + } else { + fam = Gamma() + } + + #browser() + suppressWarnings({mod <- fastglm(as.matrix(x[, model]), y, family = fam)}) + + if (length(mod) == 0 || is.nan(mod$deviance)) { + return(list(crit = -.Machine$double.xmax + log_prior(mlpost_params, complex), coefs = rep(0, sum(model)))) + } + + ret <- (-(mod$deviance + log(length(y)) * (mod$rank - 1) - 2 * log(mlpost_params$r) * sum(complex$oc))) / 2 + return(list(crit = ret, coefs = mod$coefficients)) } -#' Log likelihood function for gaussian regression with a prior p(m)=r*sum(total_width). + +#' Log likelihood function for gaussian regression with a Jeffreys prior and BIC approximation of MLIK with both known and unknown variance of the responses #' #' @param y A vector containing the dependent variable #' @param x The matrix containing the precalculated features #' @param model The model to estimate as a logical vector #' @param complex A list of complexity measures for the features -#' @param params A list of parameters for the log likelihood, supplied by the user +#' @param mlpost_params A list of parameters for the log likelihood, supplied by the user +#' +#' @return A list with the log marginal likelihood combined with the log prior (crit) and the posterior mode of the coefficients (coefs). +#' +#' @examples +#' gaussian.loglik(rnorm(100), matrix(rnorm(100)), TRUE, list(oc = 1), NULL) +#' #' #' @export gaussian.loglik -gaussian.loglik <- function (y, x, model, complex, params) { - - if(length(params) == 0) - params = list(r = 1/dim(x)[1]) - +gaussian.loglik <- function (y, x, model, complex, mlpost_params) { + if (sum(model) == 0) + return(list(crit = -Inf, coefs = numeric())) + if (length(mlpost_params) == 0) + mlpost_params <- list() + if (length(mlpost_params$r) == 0) + mlpost_params$r <- 1/dim(x)[1] + if (length(mlpost_params$beta_prior$var) == 0) + mlpost_params$beta_prior$var <- "unknown" suppressWarnings({mod <- fastglm(as.matrix(x[, model]), y, family = gaussian())}) - ret <- (-(mod$deviance + 2 * log(length(y)) * (mod$rank - 1) - 2 * log(params$r) * (sum(complex$oc)))) / 2 + + if (mlpost_params$beta_prior$var == "unknown") + ret <- (-(mod$aic + (log(length(y)) - 2) * (mod$rank) - 2 * log(mlpost_params$r) * (sum(complex$oc)))) / 2 + else + ret <- (-(mod$deviance / mlpost_params$beta_prior$var + log(length(y)) * (mod$rank - 1) - 2 * log_prior(mlpost_params, complex))) / 2 + + return(list(crit = ret, coefs = mod$coefficients)) +} + + +#' Log likelihood function for linear regression using Zellners g-prior +#' +#' @param y A vector containing the dependent variable +#' @param x The matrix containing the precalculated features +#' @param model The model to estimate as a logical vector +#' @param complex A list of complexity measures for the features +#' @param mlpost_params A list of parameters for the log likelihood, supplied by the user +#' +#' @return A list with the log marginal likelihood combined with the log prior (crit) and the posterior mode of the coefficients (coefs). +#' +#' @examples +#' gaussian.loglik.g(rnorm(100), matrix(rnorm(100)), TRUE, list(oc=1)) +#' +#' @export gaussian.loglik.g +gaussian.loglik.g <- function (y, x, model, complex, mlpost_params = NULL) { + if (sum(model) == 0) + return(list(crit = -Inf, coefs = numeric())) + if (length(mlpost_params) == 0) + mlpost_params <- list() + if (length(mlpost_params$r) == 0) + mlpost_params$r <- 1/dim(x)[1] + suppressWarnings({ + mod <- fastglm(as.matrix(x[, model]), y, family = gaussian()) + }) + # Calculate R-squared + y_mean <- mean(y) + TSS <- sum((y - y_mean)^2) + RSS <- sum(mod$residuals^2) + Rsquare <- 1 - (RSS / TSS) + + if (length(mlpost_params$r) == 0 || length(mlpost_params$g) == 0) { + mlpost_params$r <- 1 / dim(x)[1] + if (!is.null(mlpost_params$beta_prior$g)) + mlpost_params$g <- mlpost_params$beta_prior$g + else + mlpost_params$g <- max(mod$rank^2, length(y)) + } + + # logarithm of marginal likelihood + mloglik <- 0.5 * (log(1.0 + mlpost_params$g) * (dim(x)[1] - mod$rank) - log(1.0 + mlpost_params$g * (1.0 - Rsquare)) * (dim(x)[1] - 1)) * (mod$rank != 1) + + # logarithm of model prior + # default value or parameter r + lp <- log_prior(mlpost_params, complex) + + return(list(crit = mloglik + lp, coefs = mod$coefficients)) +} + + +#' Log likelihood function for Gaussian regression with parameter priors from BAS package +#' +#' This function computes the marginal likelihood of a Gaussian regression model under different priors. +#' +#' @param y A numeric vector containing the dependent variable. +#' @param x A matrix containing the independent variables, including an intercept column. +#' @param model A logical vector indicating which variables to include in the model. +#' @param complex A list containing complexity measures for the features. +#' @param mlpost_params A list of parameters for the log likelihood, specifying the tuning parameters of beta priors. +#' +#' @return A list with elements: +#' \item{crit}{Log marginal likelihood combined with the log prior.} +#' \item{coefs}{Posterior mode of the coefficients.} +#' +#' @examples +#' gaussian_tcch_log_likelihood(rnorm(100), matrix(rnorm(100)), c(TRUE), list(oc=1)) +#' +#' @importFrom BAS phi1 hypergeometric1F1 hypergeometric2F1 +#' @importFrom tolerance F1 +#' @export +gaussian_tcch_log_likelihood <- function(y, x, model, complex, mlpost_params = list(r = exp(-0.5), beta_prior = list(type = "intrinsic"))) { + # Fit the linear model using fastglm + fitted_model <- fastglm(as.matrix(x[, model]), y, family = gaussian()) + log_likelihood <- -(fitted_model$aic -2 * (fitted_model$rank))/2 + # Compute R-squared manually + y_mean <- mean(y) + TSS <- sum((y - y_mean)^2) + RSS <- sum(fitted_model$residuals^2) + R2_M <- 1 - (RSS / TSS) + + p_M <- fitted_model$rank + n <- length(y) + + # Switch-like structure to assign hyperparameters based on prior + hyper <- mlpost_params$beta_prior + if (mlpost_params$beta_prior$type == "CH") { + # CH prior: b and s should be user-specified, with defaults if not provided + a <- ifelse(!is.null(hyper$a), hyper$a, 1) # Default to 1 if not specified + b <- ifelse(!is.null(hyper$b), hyper$b, 2) # Default to 1 if not specified + r <- 0 + s <- ifelse(!is.null(hyper$s), hyper$s, 1) # Default to 1 if not specified + v <- 1 + k <- 1 + } else if (mlpost_params$beta_prior$type == "hyper-g") { + a <- 1 + b <- 2 + r <- 0 + s <- 0 + v <- 1 + k <- 1 + } else if (mlpost_params$beta_prior$type == "uniform") { + a <- 2 + b <- 2 + r <- 0 + s <- 0 + v <- 1 + k <- 1 + } else if (mlpost_params$beta_prior$type == "Jeffreys") { + a <- 0.0001 + b <- 2 + r <- 0 + s <- 0 + v <- 1 + k <- 1 + } else if (mlpost_params$beta_prior$type == "beta.prime") { + a <- 1/2 + b <- n - p_M - 1.5 + r <- 0 + s <- 0 + v <- 1 + k <- 1 + } else if (mlpost_params$beta_prior$type == "benchmark") { + a <- 0.02 + b <- 0.02 * max(n, p_M^2) + r <- 0 + s <- 0 + v <- 1 + k <- 1 + } else if (mlpost_params$beta_prior$type == "TG") { + a <- 2 * ifelse(!is.null(hyper$a), hyper$a, 1) + b <- 2 + r <- 0 + s <- 2 * ifelse(!is.null(hyper$s), hyper$s, 1) + v <- 1 + k <- 1 + } else if (mlpost_params$beta_prior$type == "ZS-adapted") { + a <- 1 + b <- 2 + r <- 0 + s <- n + 3 + v <- 1 + k <- 1 + } else if (mlpost_params$beta_prior$type == "robust") { + a <- 1 + b <- 2 + r <- 1.5 + s <- 0 + v <- (n + 1) / (p_M + 1) + k <- 1 + } else if (mlpost_params$beta_prior$type == "hyper-g-n") { + a <- 1 + b <- 2 + r <- 1.5 + s <- 0 + v <- 1 + k <- 1 + } else if (mlpost_params$beta_prior$type == "intrinsic") { + a <- 1 + b <- 1 + r <- 1 + s <- 0 + v <- (n + p_M + 1) / (p_M + 1) + k <- (n + p_M + 1) / n + } else if (mlpost_params$beta_prior$type == "tCCH") { + a <- hyper$a + b <- hyper$b + r <- hyper$rho + s <- hyper$s + v <- hyper$v + k <- hyper$k + } else { + stop("Unknown prior name: ", mlpost_params$beta_prior$type) + } + + if (!is.null(r) & r == 0) { + term1 <- lbeta((a + p_M) / 2, b / 2) + term2 <- phi1(b / 2, (n - 1) / 2, (a + b + p_M) / 2, s / (2 * v), min(0.8, R2_M / (v - (v - 1) * R2_M), log = TRUE)) + + if (R2_M / (v - (v - 1) * R2_M) > 0.8) { + warning("Infinite marginal log likelihood! phi1 last argument reduced to 0.8. Use a different prior_beta (Robust, Hyper-g/n, Intrinsic, or g-prior)") + } + + term3 <- lbeta(a / 2, b / 2) + term4 <- hypergeometric1F1(b / 2, (a + b) / 2, s / (2 * v), log = TRUE) + marginal_likelihood <- log_likelihood + (term1) + (term2) - (p_M / 2) * log(v) - ((n - 1) / 2) * log(1 - (1 - 1 / v) * R2_M) - (term3) - (term4) + } else if (!is.null(s) & s == 0) { + term1 <- lbeta((a + p_M) / 2, b / 2) + term2 <- hypergeometric2F1(r, b / 2, (a + b) / 2, 1 - k, log = TRUE) + term3 <- F1((a + p_M) / 2, (a + b + p_M + 1 - n - 2 * r) / 2, (n - 1) / 2, (a + b + p_M) / 2, 1 - k, 1 - k - (R2_M^2 * k) / ((1 - R2_M) * v)) + marginal_likelihood <- log_likelihood + (a + p_M - 2 * r) / 2 * log(k) + (term1) - (term2) - (term3) - (p_M / 2) * log(v) - log(1 - R2_M) * ((n - 1) / 2) - lbeta(a / 2, b / 2) + + } else { + stop("Invalid inputs: either r = 0 or s = 0 must be specified.") + } + + if (length(mlpost_params$r) == 0) mlpost_params$r <- 1 / dim(x)[1] # default value or parameter r + + lp <- log_prior(mlpost_params, complex) + + if (is.nan(marginal_likelihood)) { + return(list(crit = -.Machine$double.xmax + lp, coefs = rep(0,sum(model)))) + } + + return(list(crit = marginal_likelihood + lp, coefs = fitted_model$coefficients)) +} + + + +#' Log likelihood function for logistic regression with an approximate Laplace approximations used +#' This function is created as an example of how to create an estimator that is used +#' to calculate the marginal likelihood of a model. +#' +#' @param y A vector containing the dependent variable +#' @param x The matrix containing the precalculated features +#' @param model The model to estimate as a logical vector +#' @param complex A list of complexity measures for the features +#' @param mlpost_params A list of parameters for the log likelihood, supplied by the user +#' +#' @return A list with the log marginal likelihood combined with the log prior (crit) and the posterior mode of the coefficients (coefs). +#' +#' @examples +#' logistic.loglik.ala(as.integer(rnorm(100) > 0), matrix(rnorm(100)), TRUE, list(oc = 1)) +#' +#' +#' @export logistic.loglik.ala +logistic.loglik.ala <- function (y, x, model, complex, mlpost_params = list(r = exp(-0.5))) { + if (length(mlpost_params) == 0) + mlpost_params <- list(r = 1/dim(x)[1]) + suppressWarnings({mod <- fastglm(as.matrix(x[, model]), y, family = binomial(),maxit = 1)}) + ret <- (-(mod$deviance + log(length(y)) * (mod$rank - 1) -2 * log(mlpost_params$r) * sum(complex$oc))) / 2 return(list(crit=ret, coefs=mod$coefficients)) } + + +#' Log likelihood function for logistic regression for alpha calculation +#' This function is just the bare likelihood function +#' +#' @param a A vector of the alphas to be used +#' @param data The data to be used for calculation +#' @param mu_func The function linking the mean to the covariates, +#' as a string with the alphas as a\[i\]. +#' +#' @return A numeric with the log likelihood. +#' +#' @export logistic.loglik.alpha +logistic.loglik.alpha <- function (a, data, mu_func) { + m <- 1 / (1 + exp(-eval(parse(text = mu_func)))) + -sum((data$y[,1] * log(m) + (1 - data$y[, 1]) * log(1 - m))) +} + + #' Log likelihood function for gaussian regression for alpha calculation #' This function is just the bare likelihood function #' Note that it only gives a proportional value and is equivalent to least squares @@ -60,47 +523,116 @@ gaussian.loglik <- function (y, x, model, complex, params) { #' @param a A vector of the alphas to be used #' @param data The data to be used for calculation #' @param mu_func The function linking the mean to the covariates, -#' as a string with the alphas as a[i]. +#' as a string with the alphas as a\[i\]. #' +#' @return A numeric with the log likelihood. +#' @examples +#'\dontrun{ +#'gaussian.loglik.alpha(my_alpha,my_data,my_mu) +#'} #' @export gaussian.loglik.alpha gaussian.loglik.alpha <- function (a, data, mu_func) { - m <- eval(parse(text=mu_func)) - sum((data[,1]-m)^2) + m <- eval(parse(text = mu_func)) + sum((data$y[, 1] - m)^2) } -#' Log likelihood function for gaussian regression with a prior p(m)=r*sum(total_width), using subsampling. + +#' Log model prior function +#' @param mlpost_params list of passed parameters of the likelihood in GMJMCMC +#' @param complex list of complexity measures of the features included into the model #' -#' @param y A vector containing the dependent variable -#' @param x The matrix containing the precalculated features -#' @param model The model to estimate as a logical vector -#' @param complex A list of complexity measures for the features -#' @param params A list of parameters for the log likelihood, supplied by the user -#' -#' @export gaussian.loglik.bic.irlssgd -gaussian.loglik.bic.irlssgd <- function (y, x, model, complex, params = list(r = 1, subs = 0.5)) { - mod <- irls.sgd(as.matrix(x[,model]), y, gaussian(), - irls.control=list(subs=params$subs, maxit=20, tol=1e-7, cooling = c(1,0.9,0.75), expl = c(3,1.5,1)), - sgd.control=list(subs=params$subs, maxit=250, alpha=0.001, decay=0.99, histfreq=10)) - ret <- (-(mod$deviance + 2 * log(length(y)) * (mod$rank-1) - 2 * log(params$r) * (sum(complex$oc)))) / 2 - return(list(crit=ret, coefs=mod$coefficients)) +#' @return A numeric with the log model prior. +#' +#' @examples +#' log_prior(mlpost_params = list(r=2), complex = list(oc = 2)) +#' +#' @export log_prior +log_prior <- function (mlpost_params, complex) { + pl <- log(mlpost_params$r) * (sum(complex$oc)) + return(pl) } -#' Log likelihood function for linear regression using Zellners g-prior + +#' Master Log Marginal Likelihood Function #' -#' @param y A vector containing the dependent variable -#' @param x The matrix containing the precalculated features -#' @param model The model to estimate as a logical vector -#' @param complex A list of complexity measures for the features -#' @param params A list of parameters for the log likelihood, supplied by the user -#' -#' @export linear.g.prior.loglik -linear.g.prior.loglik <- function (y, x, model, complex, params = list(g = 4)) { - out <- lm.fit(as.matrix(x[, model]), y) - rsquared <- 1 - sum(var(out$residuals)) / sum(var(y)) - p <- out$rank - n <- nrow(x) - logmarglik <- 0.5 * (log(1 + params$g) * (n - p) - log(1 + params$g * (1 - rsquared)) * (n - 1)) * (p != 1) - return(logmarglik) -} +#' This function serves as a unified interface to compute the log marginal likelihood +#' for different regression models and priors by calling specific log likelihood functions. +#' +#' @param y A numeric vector containing the dependent variable. +#' @param x A matrix containing the precalculated features (independent variables). +#' @param model A logical vector indicating which variables to include in the model. +#' @param complex A list of complexity measures for the features. +#' @param mlpost_params A list of parameters controlling the model family, prior, and tuning parameters. +#' Key elements include: +#' - family: "binomial", "poisson", "gamma" (all three referred to as GLM below), or "gaussian" (default: "gaussian") +#' - prior_beta: Type of prior as a string (default: "g-prior"). Possible values include: +#' - "beta.prime": Beta-prime prior (GLM/Gaussian, no additional args) +#' - "CH": Compound Hypergeometric prior (GLM/Gaussian, requires `a`, `b`, optionally `s`) +#' - "EB-local": Empirical Bayes local prior (GLM/Gaussian, requires `a` for Gaussian) +#' - "EB-global": Empirical Bayes local prior (Gaussian, requires `a` for Gaussian) +#' - "g-prior": Zellner's g-prior (GLM/Gaussian, requires `g`) +#' - "hyper-g": Hyper-g prior (GLM/Gaussian, requires `a`) +#' - "hyper-g-n": Hyper-g/n prior (GLM/Gaussian, requires `a`) +#' - "tCCH": Truncated Compound Hypergeometric prior (GLM/Gaussian, requires `a`, `b`, `s`, `rho`, `v`, `k`) +#' - "intrinsic": Intrinsic prior (GLM/Gaussian, no additional args) +#' - "TG": Truncated Gamma prior (GLM/Gamma, requires `a`, `s`) +#' - "Jeffreys": Jeffreys prior (GLM/Gaussian, no additional args) +#' - "uniform": Uniform prior (GLM/Gaussian, no additional args) +#' - "benchmark": Benchmark prior (Gaussian/GLM, no additional args) +#' - "ZS-adapted": Zellner-Siow adapted prior (Gaussian TCCH, no additional args) +#' - "robust": Robust prior (Gaussian/GLM, no additional args) +#' - "Jeffreys-BIC": Jeffreys prior with BIC approximation of marginal likelihood (Gaussian/GLM) +#' - "ZS-null": Zellner-Siow null prior (Gaussian, requires `a`) +#' - "ZS-full": Zellner-Siow full prior (Gaussian, requires `a`) +#' - "hyper-g-laplace": Hyper-g Laplace prior (Gaussian, requires `a`) +#' - "AIC": AIC prior from BAS (Gaussian, requires penalty `a`) +#' - "BIC": BIC prior from BAS (Gaussian/GLM) +#' - "JZS": Jeffreys-Zellner-Siow prior (Gaussian, requires `a`) +#' - r: Model complexity penalty (default: 1/n) +#' - a: Tuning parameter for g-prior (default: max(n, p^2)) +#' - a, b, s, v, rho, k: Hyperparameters for various priors +#' - n: Sample size for some priors (default: length(y)) +#' - var: Variance assumption for Gaussian models ("known" or "unknown", default: "unknown") +#' - laplace: Logical for Laplace approximation in GLM only (default: FALSE) +#' +#' @return A list with elements: +#' \item{crit}{Log marginal likelihood combined with the log prior.} +#' \item{coefs}{Posterior mode of the coefficients.} +#' +#' @examples +#' fbms.mlik.master(y = rnorm(100), +#' x = matrix(rnorm(100)), +#' c(TRUE,TRUE), +#' list(oc = 1), +#' mlpost_params = list(family = "gaussian", beta_prior = list(type = "g-prior", a = 2), +#' r = exp(-0.5))) +#' +#' @importFrom BAS robust beta.prime bic.prior CCH EB.local g.prior hyper.g hyper.g.n tCCH intrinsic TG Jeffreys uniform +#' @export +fbms.mlik.master <- function(y, x, model, complex, mlpost_params = list(family = "gaussian", beta_prior = list(type = "g-prior"), r = NULL)) { + # Extract dimensions + n <- length(y) + p <- length(model) - 1 # Number of predictors excluding intercept + params_use <- list() + if(length(mlpost_params$r) == 0) + mlpost_params$r <- 1/length(y) + + if(mlpost_params$family == "gaussian") + params_use$beta_prior <- gen.mlpost.params.lm(mlpost_params$beta_prior$type, mlpost_params$beta_prior, p, n) + else + { + params_use$beta_prior <- gen.mlpost.params.glm(mlpost_params$beta_prior$type, mlpost_params$beta_prior, p, n) + params_use$family <- mlpost_params$family + } + + params_use$r <- mlpost_params$r + + + loglik.pi <- select.mlpost.fun(mlpost_params$beta_prior$type, mlpost_params$family) + + + result <- loglik.pi(y, x, model, complex, params_use) + return(list(crit = result$crit, coefs = result$coefs)) +} \ No newline at end of file diff --git a/R/local_optim.R b/R/local_optim.R index eb6767b9135d1bf0bd5bcbd754fe8b3150357bd0..a198329d5a95731eb3a85504d0092895b7e09df1 100644 --- a/R/local_optim.R +++ b/R/local_optim.R @@ -3,7 +3,7 @@ # Created by: jonlachmann # Created on: 2021-02-11 -simulated.annealing <- function (model, data, loglik.pi, indices, complex, params, loglikparams, kernel=NULL) { +simulated.annealing <- function (model, data, loglik.pi, indices, complex, params, loglikparams, kernel=NULL, visited.models=NULL, sub = FALSE) { # Initialize a list to keep models that we visit in models <- vector("list", 0) @@ -13,19 +13,18 @@ simulated.annealing <- function (model, data, loglik.pi, indices, complex, param temp <- params$t.init # Initial temperature # Calculate current likelihood - model.res <- loglik.pre(loglik.pi, model, complex, data, loglikparams) + model.res <- loglik.pre(loglik.pi, model, complex, data, loglikparams, visited.models, sub) model.lik <- model.res$crit - models[[length(models) + 1]] <- list(prob=NA, model=model, coefs=model.res$coefs, crit=model.lik, alpha=NA) - # print(paste("SA Start:", model.lik)) + models[[length(models) + 1]] <- list(prob = NA, model = model, coefs = model.res$coefs, crit = model.lik, alpha = NA) while (temp > params$t.min) { # Make M tries at current temperature for (m in 1:params$M) { # Get a modified model as proposal and calculate its likelihood proposal <- xor(model, gen.proposal(model, params$kern, kernel, indices)$swap) - model.proposal <- loglik.pre(loglik.pi, proposal, complex, data, loglikparams) + model.proposal <- loglik.pre(loglik.pi, proposal, complex, data, loglikparams, visited.models = visited.models, sub = sub) proposal.lik <- model.proposal$crit # Store the model that we have calculated - models[[length(models) + 1]] <- list(prob=NA, model=proposal, coefs=model.proposal$coefs, crit=proposal.lik, alpha=NA) + models[[length(models) + 1]] <- list(prob = NA, model = proposal, coefs = model.proposal$coefs, crit = proposal.lik, alpha = NA) # Calculate move probability for negative steps (Bolzmann distribution, see Blum and Roli p. 274) if (proposal.lik > model.lik) alpha <- 1 else alpha <- min(1, exp((proposal.lik - model.lik) / temp)) @@ -38,11 +37,10 @@ simulated.annealing <- function (model, data, loglik.pi, indices, complex, param # Update temperature temp <- temp * exp(-params$dt) } - # print(paste("SA Finish:", model.lik)) - return(list(model=model, kern=kernel, models=models)) + return(list(model = model, kern = kernel, models = models)) } -greedy.optim <- function (model, data, loglik.pi, indices, complex, params, loglikparams, kernel=NULL) { +greedy.optim <- function (model, data, loglik.pi, indices, complex, params, loglikparams, kernel = NULL, visited.models = NULL, sub = FALSE) { # Initialize a list to keep models that we visit in models <- vector("list", 0) @@ -50,7 +48,7 @@ greedy.optim <- function (model, data, loglik.pi, indices, complex, params, logl if (is.null(kernel)) kernel <- sample.int(n = 6, size = 1, prob = params$kern$probs) # Calculate current likelihood - model.res <- loglik.pre(loglik.pi, model, complex, data, loglikparams) + model.res <- loglik.pre(loglik.pi, model, complex, data, loglikparams,visited.models, sub) model.lik <- model.res$crit models[[length(models)+1]] <- list(prob=NA, model=model, coefs=model.res$coefs, crit=model.lik, alpha=NA) @@ -62,7 +60,7 @@ greedy.optim <- function (model, data, loglik.pi, indices, complex, params, logl for (j in 1:params$tries) { # Get a modified model as proposal and calculate its likelihood proposal <- xor(model, gen.proposal(model, params$kern, kernel, indices)$swap) - model.proposal <- loglik.pre(loglik.pi, proposal, complex, data, loglikparams) + model.proposal <- loglik.pre(loglik.pi, proposal, complex, data, loglikparams, visited.models=visited.models, sub = sub) proposal.lik <- model.proposal$crit # Store the model that we have calculated models[[length(models)+1]] <- list(prob=NA, model=proposal, coefs=model.proposal$coefs, crit=proposal.lik, alpha=NA) @@ -80,12 +78,12 @@ greedy.optim <- function (model, data, loglik.pi, indices, complex, params, logl return(list(model=model, kern=kernel, models=models)) } -local.optim <- function (model, data, loglik.pi, indices, complex, type, params, kernel=NULL) { +local.optim <- function (model, data, loglik.pi, indices, complex, type, params, kernel = NULL, visited.models = NULL, sub = FALSE) { if (type == 1) { - return(simulated.annealing(model, data, loglik.pi, indices, complex, params$sa, params$loglik, kernel)) + return(simulated.annealing(model, data, loglik.pi, indices, complex, params$sa, params$mlpost, kernel, visited.models = visited.models, sub = sub)) } if (type == 2) { - return(greedy.optim(model, data, loglik.pi, indices, complex, params$greedy, params$loglik, kernel)) + return(greedy.optim(model, data, loglik.pi, indices, complex, params$greedy, params$mlpost, kernel, visited.models = visited.models, sub = sub)) } if (type == 3) { return("not implemented") diff --git a/R/mjmcmc.R b/R/mjmcmc.R index c69c4bd7932e5cb7cfe25057737c0618b5592fb5..97be31d3bad3879cf0208bce34295a460fd11ac3 100644 --- a/R/mjmcmc.R +++ b/R/mjmcmc.R @@ -3,51 +3,113 @@ # Created by: jonlachmann # Created on: 2021-04-27 -#' Main algorithm for MJMCMC +#' Main algorithm for MJMCMC (Genetically Modified MJMCMC) #' -#' @param data A matrix containing the data to use in the algorithm, -#' first column should be the dependent variable, second should be the intercept -#' and the rest of the columns should be the independent variables. -#' @param loglik.pi The (log) density to explore -#' @param N The number of iterations to run for -#' @param probs A list of the various probability vectors to use -#' @param params A list of the various parameters for all the parts of the algorithm -#' @param sub An indicator that if the likelihood is inexact and should be improved each model visit (EXPERIMENTAL!) +#' @param x matrix containing the design matrix with data to use in the algorithm, +#' @param y response variable +#' @param N The number of MJMCMC iterations to run for (default 100) +#' @param probs A list of various probability vectors used by GMJMCMC, generated by \code{gen.probs.mjmcmc}. +#' @param params A list of various parameter vectors used by MJMCMC, generated by \code{gen.params.mjmcmc}. +#' @param loglik.pi A function specifying the marginal log-posterior of the model up to a constant, including the logarithm of the model prior: +#' \eqn{\log p(M|Y) = \text{const} + \log p(Y|M) + \log p(M)}. +#' Typically assumes a Gaussian model with Zellner's g prior with \eqn{g = max(n,p^2) by default}. +#' @param mlpost_params All parameters for the estimator function loglik.pi +#' @param intercept Logical. Whether to include an intercept in the design matrix. Default is \code{TRUE}. No variable selection is performed on the intercept. +#' @param fixed Integer specifying the number of leading columns in the design matrix to always include in the model. Default is 0. +#' @param sub Logical. If \code{TRUE}, uses subsampling or a stochastic approximation approach to the likelihood rather than the full likelihood. Default is \code{FALSE}. +#' @param verbose Logical. Whether to print messages during execution. Default is \code{TRUE} for \code{gmjmcmc} and \code{FALSE} for the parallel version. +#' +#' @return A list containing the following elements: +#' \item{models}{All visited models in both mjmcmc and local optimization.} +#' \item{accept}{Average acceptance rate of the chain.} +#' \item{mc.models}{All models visited during mjmcmc iterations.} +#' \item{best.crit}{The highest log marginal probability of the visited models.} +#' \item{marg.probs}{Marginal probabilities of the features.} +#' \item{model.probs}{Marginal probabilities of all of the visited models.} +#' \item{model.probs.idx}{Indices of unique visited models.} +#' \item{populations}{The covariates represented as a list of features.} +#' +#' @examples +#' result <- mjmcmc( +#' y = matrix(rnorm(100), 100), +#' x = matrix(rnorm(600), 100), +#' loglik.pi = gaussian.loglik) +#' summary(result) +#' plot(result) #' #' @export mjmcmc -mjmcmc <- function (data, loglik.pi, N = 100, probs = NULL, params = NULL, sub = FALSE) { +mjmcmc <- function ( + x, + y, + N = 1000, + probs = NULL, + params = NULL, + loglik.pi = NULL, + mlpost_params = list(family = "gaussian", beta_prior = list(type = "g-prior")), + intercept = TRUE, + fixed = 0, + sub = FALSE, + verbose = TRUE +) { # Verify that data is well-formed - data <- check.data(data) + if (intercept) { + x <- cbind(1, x) + fixed <- fixed + 1 + } + data <- check.data(x, y, fixed, verbose) + + if(is.null(loglik.pi)) + { + if(is.null(mlpost_params$beta_prior$type) || is.null(mlpost_params$family)) + stop("mlpost_params$beta_prior and mlpost_params$family must be specified") + loglik.pi <- select.mlpost.fun(mlpost_params$beta_prior$type, mlpost_params$family) + if(mlpost_params$family == "gaussian") + mlpost_params$beta_prior <- gen.mlpost.params.lm(mlpost_params$beta_prior$type, mlpost_params$beta_prior, ncol(data$x) - 1, nrow(data$x)) + else + { + mlpost_params$beta_prior <- gen.mlpost.params.glm(mlpost_params$beta_prior$type, mlpost_params$beta_prior, ncol(data$x) - 1, nrow(data$x)) + mlpost_params$beta_prior$type <- mlpost_params$beta_prior$type + } + + } + + labels <- colnames(x) + if (fixed != 0) + labels <- labels[-seq_len(fixed)] # Generate default probabilities and parameters if there are none supplied. if (is.null(probs)) probs <- gen.probs.mjmcmc() - if (is.null(params)) params <- gen.params.mjmcmc(data) + if (is.null(params)) params <- gen.params.mjmcmc(ncol(data$x) - data$fixed) + if (!is.null(mlpost_params)) params$mlpost <- mlpost_params # Acceptance probability accept <- 0 # Create a population of just the covariates - S <- gen.covariates(ncol(data)-2) + S <- gen.covariates(data) complex <- complex.features(S) # Initialize first model model.cur <- as.logical(rbinom(n = length(S), size = 1, prob = 0.5)) - model.cur.res <- loglik.pre(loglik.pi, model.cur, complex, data, params$loglik) - model.cur <- list(prob=0, model=model.cur, coefs=model.cur.res$coefs, crit=model.cur.res$crit, alpha=0) + model.cur.res <- loglik.pre(loglik.pi, model.cur, complex, data, params$mlpost, visited.models = NULL, sub = sub) + model.cur <- list(prob = 0, model = model.cur, coefs = model.cur.res$coefs, crit = model.cur.res$crit, alpha = 0) - cat("\nMJMCMC begin.\n") - result <- mjmcmc.loop(data, complex, loglik.pi, model.cur, N, probs, params, sub) - cat("\nMJMCMC done.\n") + if (verbose) cat("\nMJMCMC begin.\n") + result <- mjmcmc.loop(data, complex, loglik.pi, model.cur, N, probs, params, sub, verbose) + if (verbose) cat("\nMJMCMC done.\n") # Calculate acceptance rate result$accept <- result$accept / N result$populations <- S # Return formatted results + result$fixed <- data$fixed + result$labels <- labels + result$intercept <- intercept class(result) <- "mjmcmc" return(result) } -#' The main loop for the MJMCMC algorithm, used in both MJMCMC and GMJMCMC +#' The main loop for the MJMCMC (Mode Jumping MCMC) algorithm, used in both MJMCMC and GMJMCMC (Genetically Modified MJMCMC) #' #' @param data The data to use #' @param complex The complexity measures of the data @@ -57,66 +119,56 @@ mjmcmc <- function (data, loglik.pi, N = 100, probs = NULL, params = NULL, sub = #' @param probs A list of the various probability vectors to use #' @param params A list of the various parameters for all the parts of the algorithm #' @param sub An indicator that if the likelihood is inexact and should be improved each model visit (EXPERIMENTAL!) +#' @param verbose A logical denoting if messages should be printed +#' +#' @return A list containing the following elements: +#' \item{models}{All visited models.} +#' \item{accept}{Number of accepted proposals of the chain.} +#' \item{mc.models}{All models visited during mjmcmc.} +#' \item{best.crit}{The highest log marginal probability of the visited models.} +#' \item{marg.probs}{Marginal probabilities of the features.} +#' \item{model.probs}{Marginal probabilities of all of the visited models.} +#' \item{model.probs.idx}{Indices of unique visited models.} +#' +#' @noRd #' -#' @return A list containing the visited models, the models visited during local optimisation, -#' the acceptance count and the best critical value encountered. -mjmcmc.loop <- function (data, complex, loglik.pi, model.cur, N, probs, params, sub=F) { +mjmcmc.loop <- function (data, complex, loglik.pi, model.cur, N, probs, params, sub = FALSE, verbose = TRUE) { # Acceptance count accept <- 0 # Number of covariates or features - covar_count <- ncol(data) - 2 + covar_count <- ncol(data$x) # A list of models that have been visited models <- vector("list", N) # Initialize a vector to contain local opt visited models lo.models <- vector("list", 0) # Initialize list for keeping track of unique visited models - visited.models <- list(models=matrix(model.cur$model, 1, covar_count), crit=model.cur$crit, count=1) + visited.models <- hashmap() + visited.models[[model.cur$model]] <- list(crit = model.cur$crit, coefs = model.cur$coefs) best.crit <- model.cur$crit # Set first best criteria value progress <- 0 mcmc_total <- as.numeric(model.cur$model) - for (i in 1:N) { - if (N > 40 && i %% floor(N/40) == 0) progress <- print.progressbar(progress, 40) + for (i in seq_len(N)) { + if (verbose && N > 40 && i %% floor(N / 40) == 0) progress <- print_progressbar(progress, 40) - if (i > params$burn_in) pip_estimate <- mcmc_total/i - else pip_estimate <- rep(1/covar_count, covar_count) + if (i > params$burn_in) pip_estimate <- mcmc_total / i + else pip_estimate <- rep(1 / covar_count, covar_count) - proposal <- mjmcmc.prop(data, loglik.pi, model.cur, complex, pip_estimate, probs, params, visited.models) + proposal <- mjmcmc.prop(data, loglik.pi, model.cur, complex, pip_estimate, probs, params, visited.models, sub = sub) if (proposal$crit > best.crit) { best.crit <- proposal$crit - cat(paste("\rNew best crit:", best.crit, "\n")) + if (verbose) cat(paste("\rNew best crit in cur pop:", best.crit, "\n")) } # If we did a large jump and visited models to save if (!is.null(proposal$models)) { lo.models <- c(lo.models, proposal$models) - # If we are doing subsampling and want to update best mliks - if (sub) { - for (mod in seq_along(proposal$models)) { - # Check if we have seen this model before - mod.idx <- vec_in_mat(visited.models$models[1:visited.models$count,,drop=F], proposal$models[[mod]]$model) - if (mod.idx == 0) { - # If we have not seen the model before, add it - visited.models$count <- visited.models$count + 1 - visited.models$crit <- c(visited.models$crit, proposal$models[[mod]]$crit) - visited.models$models <- rbind(visited.models$models, proposal$models[[mod]]$model) - } # This is a model seen before, set the best of the values available - else visited.models$crit[mod.idx] <- max(proposal$models[[mod]]$crit, visited.models$crit[mod.idx]) - } + for (mod in seq_along(proposal$models)) { + visited.models[[proposal$models[[mod]]$model]] <- list(crit = proposal$models[[mod]]$crit, coefs = proposal$models[[mod]]$coefs) } proposal$models <- NULL } - if (sub) { - # Check if we have seen this model before - mod.idx <- vec_in_mat(visited.models$models[1:visited.models$count,,drop=F], proposal$model) - if (mod.idx == 0) { - # If we have not seen the model before, add it - visited.models$count <- visited.models$count + 1 - visited.models$crit <- c(visited.models$crit, proposal$crit) - visited.models$models <- rbind(visited.models$models, proposal$model) - } # This is a model seen before, set the best of the values available - else visited.models$crit[mod.idx] <- max (proposal$crit, visited.models$crit[mod.idx]) - } + visited.models[[proposal$model]] <- list(crit = proposal$crit, coefs = proposal$coefs) if (log(runif(1)) <= proposal$alpha) { model.cur <- proposal @@ -128,12 +180,14 @@ mjmcmc.loop <- function (data, complex, loglik.pi, model.cur, N, probs, params, } # Calculate and store the marginal inclusion probabilities and the model probabilities - marg.probs <- marginal.probs.renorm(c(models, lo.models), type = "both") - + all.models <- c(models, lo.models) + marg.probs <- marginal.probs.renorm(all.models, type = "both") + best.crit <- all.models[[marg.probs$idx[which.max(marg.probs$probs.m)]]]$crit + return(list( - models = models, + models = c(models, lo.models), accept = accept, - lo.models = lo.models, + mc.models = models, best.crit = best.crit, marg.probs = marg.probs$probs.f, model.probs = marg.probs$probs.m, @@ -151,8 +205,11 @@ mjmcmc.loop <- function (data, complex, loglik.pi, model.cur, N, probs, params, #' @param probs A list of the various probability vectors to use #' @param params A list of the various parameters for all the parts of the algorithm #' @param visited.models A list of the previously visited models to use when subsampling and avoiding recalculation +#' @param sub An indicator that if the likelihood is inexact and should be improved each model visit (EXPERIMENTAL!) +#' +#' @noRd #' -mjmcmc.prop <- function (data, loglik.pi, model.cur, complex, pip_estimate, probs, params, visited.models=NULL) { +mjmcmc.prop <- function (data, loglik.pi, model.cur, complex, pip_estimate, probs, params, visited.models = NULL, sub = FALSE) { l <- runif(1) if (l < probs$large) { ### Large jump @@ -160,33 +217,33 @@ mjmcmc.prop <- function (data, loglik.pi, model.cur, complex, pip_estimate, prob ### Select kernels to use for the large jump q.l <- sample.int(n = 4, size = 1, prob = probs$large.kern) # Select large jump kernel q.o <- sample.int(n = 2, size = 1, prob = probs$localopt) # Select optimizer function - q.r <- sample.int(n = 4, size = 1, prob = probs$random) # Select randomization kernel + q.r <- sample.int(n = 2, size = 1, prob = probs$random.kern) # Set randomization kernel # Generate and do large jump large.jump <- gen.proposal(model.cur$model, params$large, q.l, NULL, pip_estimate) # Get the large jump chi.0.star <- xor(model.cur$model, large.jump$swap) # Swap large jump indices # Optimize to find a mode - localopt <- local.optim(chi.0.star, data, loglik.pi, !large.jump$swap, complex, q.o, params) # Do local optimization + localopt <- local.optim(chi.0.star, data, loglik.pi, !large.jump$swap, complex, q.o, params, visited.models = visited.models, sub = sub) # Do local optimization chi.k.star <- localopt$model # Randomize around the mode - proposal <- gen.proposal(chi.k.star, params$random, q.r, !large.jump$swap, pip_estimate, prob=T) + proposal <- gen.proposal(chi.k.star, list(neigh.size = length(pip_estimate), neigh.min = 1, neigh.max = length(pip_estimate)), q.r, NULL, (pip_estimate * 0 + 1 - params$random$prob), prob=TRUE) proposal$model <- xor(chi.k.star, proposal$swap) # Do a backwards large jump and add in the kernel used in local optim to use the same for backwards local optim. chi.0 <- xor(proposal$model, large.jump$swap) # Do a backwards local optimization - localopt2 <- local.optim(chi.0, data, loglik.pi, !large.jump$swap, complex, q.o, params, kernel = localopt$kern) + localopt2 <- local.optim(chi.0, data, loglik.pi, !large.jump$swap, complex, q.o, params, kernel = localopt$kern, visited.models=visited.models, sub = sub) chi.k <- localopt2$model ### Calculate acceptance probability # Set up the parameters that were used to generate the proposal - prop.params <- list(neigh.min = params$random$min, neigh.max = params$random$max, neigh.size = proposal$S) + prop.params <- list(neigh.size = length(pip_estimate), neigh.min = 1, neigh.max = length(pip_estimate))#list(neigh.min = params$random$min, neigh.max = params$random$max, neigh.size = proposal$S) # Calculate current model probability given proposal - model.cur$prob <- prob.proposal(proposal$model, chi.k, q.r, prop.params, pip_estimate) # Get probability of gamma given chi.k + model.cur$prob <- prob.proposal(proposal$model, chi.k, q.r, prop.params, (pip_estimate*0 + 1 - params$random$prob)) # Get probability of gamma given chi.k # Store models visited during local optimization proposal$models <- c(localopt$models, localopt2$models) @@ -195,25 +252,16 @@ mjmcmc.prop <- function (data, loglik.pi, model.cur, complex, pip_estimate, prob # Select MH kernel q.g <- sample.int(n = 6, size = 1, prob = probs$mh) # Generate the proposal - proposal <- gen.proposal(model.cur$model, params$mh, q.g, NULL, pip_estimate, prob = T) + proposal <- gen.proposal(model.cur$model, params$mh, q.g, NULL, pip_estimate, prob = TRUE) proposal$model <- xor(proposal$swap, model.cur$model) # Calculate current model probability given proposal model.cur$prob <- prob.proposal(proposal$model, model.cur$model, q.g, params$mh, pip_estimate) } # Calculate log likelihoods for the proposed model - proposal.res <- loglik.pre(loglik.pi, proposal$model, complex, data, params$loglik) + proposal.res <- loglik.pre(loglik.pi, proposal$model, complex, data, params$mlpost, visited.models=visited.models, sub = sub) proposal$crit <- proposal.res$crit - # TODO: Compare to a list of best mliks for all visited models, - # TODO: update that list if our estimate is better, otherwise update our estimate. - # TODO: Save all models visited by local optim, and update the best mliks if we see one during local optim. - # If we are running with subsampling, check the list for a better mlik - if (!is.null(visited.models)) { - mod.idx <- vec_in_mat(visited.models$models[1:visited.models$count,,drop=F], proposal$model) - if (mod.idx != 0) proposal$crit <- max(proposal$crit, visited.models$crit[mod.idx]) - } - # Calculate acceptance probability for proposed model proposal$alpha <- min(0, (proposal$crit + model.cur$prob) - (model.cur$crit + proposal$prob)) diff --git a/R/nonlinear_functions.R b/R/nonlinear_functions.R index 99642f0828e9061e5aec196e9d4e89556c986f22..32c5b913254984c78a3adcce8dd81dd5c956e49e 100644 --- a/R/nonlinear_functions.R +++ b/R/nonlinear_functions.R @@ -8,32 +8,45 @@ #' @param x The vector of values #' @return The sigmoid of x #' +#' @examples +#' sigmoid(2) +#' +#' #' @export sigmoid -sigmoid <- function(x) 1 / (1 - exp(-x)) +sigmoid <- function(x) 1 / (1 + exp(-x)) #' Sine function for degrees #' #' @param x The vector of values in degrees #' @return The sine of x #' -#' @export sin.rad -sin.rad <- function(x) sin(x/180*pi) +#' @examples +#' sin_deg(0) +#' +#' @export sin_deg +sin_deg <- function(x) sin(x / 180 * pi) #' Cosine function for degrees #' #' @param x The vector of values in degrees #' @return The cosine of x #' -#' @export cos.rad -cos.rad <- function(x) cos(x/180*pi) +#' @examples +#' cos_deg(0) +#' +#' @export cos_deg +cos_deg <- function(x) cos(x / 180 * pi) #' Double exponential function #' #' @param x The vector of values #' @return e^(-abs(x)) #' -#' @export exp.dbl -exp.dbl <- function(x) exp(-abs(x)) +#' @examples +#' exp_dbl(2) +#' +#' @export exp_dbl +exp_dbl <- function(x) exp(-abs(x)) #' Square root function @@ -41,6 +54,9 @@ exp.dbl <- function(x) exp(-abs(x)) #' @param x The vector of values #' @return The square root of the absolute value of x #' +#' @examples +#' sqroot(4) +#' #' @export sqroot sqroot <- function(x) abs(x)^(1/2) @@ -49,55 +65,31 @@ sqroot <- function(x) abs(x)^(1/2) #' @param x The vector of values #' @return The cube root of x #' -#' @export troot -troot <- function(x) abs(x)^(1/3) - -#' To the 2.3 power function -#' -#' @param x The vector of values -#' @return x^2.3 +#' @examples +#' troot(27) #' #' @export troot -to23 <- function(x) abs(x)^(2.3) - -#' To the 7/2 power function -#' -#' @param x The vector of values -#' @return x^(7/2) -#' -#' @export troot -to72 <- function(x) abs(x)^(7/2) +troot <- function(x) abs(x)^(1/3) -#' Gaussian function +#' arcsinh transform #' #' @param x The vector of values -#' @return e^(-x^2) +#' @return arcsinh(x) #' -#' @export gauss -gauss <- function(x) exp(-x*x) - -#' To 2.5 power +#' @examples +#' arcsinh(2) #' -#' @param x The vector of values -#' @return x^(2.5) -#' -#' @export to25 -to25 <- function(x)abs(x)^(2.5) - - -#' To 3.5 power -#' -#' @param x The vector of values -#' @return x^(3.5) -#' -#' @export to35 -to35 <- function(x)abs(x)^(3.5) +#' @export arcsinh +arcsinh <- function(x) asinh(x) #' p0 polynomial term #' #' @param x The vector of values #' @return log(abs(x) + .Machine$double.eps) #' +#' @examples +#' p0(2) +#' #' @export p0 p0 <- function(x) log(abs(x)+.Machine$double.eps) @@ -106,6 +98,9 @@ p0 <- function(x) log(abs(x)+.Machine$double.eps) #' @param x The vector of values #' @return sign(x)*(abs(x)+.Machine$double.eps)^(-1) #' +#' @examples +#' pm1(2) +#' #' @export pm1 pm1 <- function(x) sign(x)*(abs(x)+.Machine$double.eps)^(-1) @@ -114,6 +109,9 @@ pm1 <- function(x) sign(x)*(abs(x)+.Machine$double.eps)^(-1) #' @param x The vector of values #' @return sign(x)*(abs(x)+.Machine$double.eps)^(-2) #' +#' @examples +#' pm2(2) +#' #' @export pm2 pm2 <- function(x) sign(x)*(abs(x)+.Machine$double.eps)^(-2) @@ -122,6 +120,9 @@ pm2 <- function(x) sign(x)*(abs(x)+.Machine$double.eps)^(-2) #' @param x The vector of values #' @return (abs(x)+.Machine$double.eps)^(-0.5) #' +#' @examples +#' pm05(2) +#' #' @export pm05 pm05 <- function(x) (abs(x)+.Machine$double.eps)^(-0.5) @@ -130,6 +131,9 @@ pm05 <- function(x) (abs(x)+.Machine$double.eps)^(-0.5) #' @param x The vector of values #' @return (abs(x)+.Machine$double.eps)^(0.5) #' +#' @examples +#' p05(2) +#' #' @export p05 p05 <- function(x) (abs(x)+.Machine$double.eps)^(0.5) @@ -138,6 +142,9 @@ p05 <- function(x) (abs(x)+.Machine$double.eps)^(0.5) #' @param x The vector of values #' @return x^(2) #' +#' @examples +#' p2(2) +#' #' @export p2 p2 <- function(x) x^(2) @@ -146,6 +153,9 @@ p2 <- function(x) x^(2) #' @param x The vector of values #' @return x^(3) #' +#' @examples +#' p3(2) +#' #' @export p3 p3 <- function(x) x^(3) @@ -154,6 +164,9 @@ p3 <- function(x) x^(3) #' @param x The vector of values #' @return p0(x)*p0(x) #' +#' @examples +#' p0p0(2) +#' #' @export p0p0 p0p0 <- function(x) p0(x)*p0(x) @@ -162,6 +175,9 @@ p0p0 <- function(x) p0(x)*p0(x) #' @param x The vector of values #' @return p0(x)*(x+.Machine$double.eps)^(-1) #' +#' @examples +#' p0pm1(2) +#' #' @export p0pm1 p0pm1 <- function(x) p0(x)*(x+.Machine$double.eps)^(-1) @@ -170,6 +186,9 @@ p0pm1 <- function(x) p0(x)*(x+.Machine$double.eps)^(-1) #' @param x The vector of values #' @return p0(x)*sign(x)*(abs(x)+.Machine$double.eps)^(-2) #' +#' @examples +#' p0pm2(2) +#' #' @export p0pm2 p0pm2 <- function(x) p0(x)*sign(x)*(abs(x)+.Machine$double.eps)^(-2) @@ -178,6 +197,9 @@ p0pm2 <- function(x) p0(x)*sign(x)*(abs(x)+.Machine$double.eps)^(-2) #' @param x The vector of values #' @return p0(x)*sign(x)*(abs(x)+.Machine$double.eps)^(-0.5) #' +#' @examples +#' p0pm05(2) +#' #' @export p0pm05 p0pm05 <- function(x) p0(x)*(abs(x)+.Machine$double.eps)^(-0.5) @@ -186,6 +208,9 @@ p0pm05 <- function(x) p0(x)*(abs(x)+.Machine$double.eps)^(-0.5) #' @param x The vector of values #' @return p0(x)*(abs(x)+.Machine$double.eps)^(0.5) #' +#' @examples +#' p0p05(2) +#' #' @export p0p05 p0p05 <- function(x) p0(x)*(abs(x)+.Machine$double.eps)^(0.5) @@ -194,6 +219,9 @@ p0p05 <- function(x) p0(x)*(abs(x)+.Machine$double.eps)^(0.5) #' @param x The vector of values #' @return p0(x)*x #' +#' @examples +#' p0p1(2) +#' #' @export p0p1 p0p1 <- function(x) p0(x)*x @@ -202,6 +230,9 @@ p0p1 <- function(x) p0(x)*x #' @param x The vector of values #' @return p0(x)*x^(2) #' +#' @examples +#' p0p2(2) +#' #' @export p0p2 p0p2 <- function(x) p0(x)*x^(2) @@ -210,6 +241,9 @@ p0p2 <- function(x) p0(x)*x^(2) #' @param x The vector of values #' @return p0(x)*x^(3) #' +#' @examples +#' p0p3(2) +#' #' @export p0p3 p0p3 <- function(x) p0(x)*x^(3) @@ -219,23 +253,21 @@ p0p3 <- function(x) p0(x)*x^(3) #' @param x The vector of values #' @return max(x,0) #' +#' @examples +#' relu(2) +#' #' @export relu relu <- function(x) max(x,0) -#' negative ReLu function -#' -#' @param x The vector of values -#' @return max(x,0) -#' -#' @export nrelu -nrelu <- function(x) max(x,0) - #' negative ReLu function #' #' @param x The vector of values #' @return max(-x,0) #' +#' @examples +#' nrelu(2) +#' #' @export nrelu nrelu <- function(x) max(-x,0) @@ -244,6 +276,9 @@ nrelu <- function(x) max(-x,0) #' @param x The vector of values #' @return x*pnorm(x) #' +#' @examples +#' gelu(2) +#' #' @export gelu gelu <- function(x)x *pnorm(x) @@ -253,6 +288,9 @@ gelu <- function(x)x *pnorm(x) #' @param x The vector of values #' @return -x*pnorm(-x) #' +#' @examples +#' ngelu(2) +#' #' @export ngelu ngelu <- function(x) -x*pnorm(-x) @@ -261,6 +299,9 @@ ngelu <- function(x) -x*pnorm(-x) #' @param x The vector of values #' @return 2 * pnorm(x * sqrt(2)) - 1 #' +#' @examples +#' erf(2) +#' #' @export erf erf <- function(x) 2 * pnorm(x * sqrt(2)) - 1 @@ -270,6 +311,9 @@ erf <- function(x) 2 * pnorm(x * sqrt(2)) - 1 #' @param x The vector of values #' @return as.integer(x>0) #' +#' @examples +#' hs(2) +#' #' @export hs hs <- function(x) as.integer(x>0) @@ -279,6 +323,9 @@ hs <- function(x) as.integer(x>0) #' @param x The vector of values #' @return as.integer(x<0) #' +#' @examples +#' nhs(2) +#' #' @export nhs nhs <- function(x) as.integer(x<0) @@ -287,6 +334,9 @@ nhs <- function(x) as.integer(x<0) #' @param x The vector of binary values #' @return 1-x #' +#' @examples +#' not(TRUE) +#' #' @export not not <- function(x) (1-x) diff --git a/R/parallel.R b/R/parallel.R index 7e47238a6fb0855f3c43b5948e56111e86eb4fce..95a62feec11eb4b0d5d95ca08c4275e45063427b 100644 --- a/R/parallel.R +++ b/R/parallel.R @@ -1,30 +1,161 @@ +#' rmclapply: Cross-platform mclapply/forking hack for Windows +#' +#' This function applies a function in parallel to a list or vector (`X`) using multiple cores. +#' On Linux/macOS, it uses `mclapply`, while on Windows it uses a hackish version of parallelism. +#' The Windows version is based on `parLapply` to mimic forking following Nathan VanHoudnos. +#' @param runs The runs to run +#' @param args The arguments to pass to fun +#' @param fun The function to run +#' @param mc.cores Number of cores to use for parallel processing. Defaults to `detectCores()`. +#' +#' @return A list of results, with one element for each element of `X`. +rmclapply <- function(runs, args, fun, mc.cores = NULL) { + if (is.null(args$verbose)) args$verbose <- TRUE + + if (is.null(mc.cores)) { + mc.cores <- min(length(runs), detectCores()) + } + + if (Sys.info()[["sysname"]] == "Windows" & mc.cores > 1) { + if (args$verbose) { + message("Using parallelization hack for Windows with parLapply.") + } + + + ## N.B. setting outfile to blank redirects output to + ## the master console, as is the default with + ## mclapply() on Linux / Mac + cl <- makeCluster(mc.cores, outfile = "") + loaded.package.names <- c( + sessionInfo()$basePkgs, + names(sessionInfo()$otherPkgs) + ) + + tryCatch({ + ## Copy over all of the objects within scope to + ## all clusters. + clusterEvalQ(cl, library(FBMS)) + clusterExport(cl, "args") + clusterExport(cl, ls(all.names = TRUE, envir = globalenv()), envir = globalenv()) + # Load required packages on each cluster node + parLapply(cl, seq_along(cl), function(xx) { + lapply(loaded.package.names, function(pkg) { + require(pkg, character.only = TRUE) + }) + }) + ## Run the lapply in parallel + res <- parLapply(cl, runs, function(x) { + set.seed(NULL) + set.seed(as.integer(x) + sample.int(100000,1)) + do.call(fun, args) + }) + gc() + return(res) + }, finally = { + ## Stop the cluster + stopCluster(cl) + }) + + ## Warn the user if they are using Windows + if (Sys.info()[["sysname"]] == "Windows" & args$verbose == TRUE) { + message(paste( + "\n", + " *** Microsoft Windows detected ***\n", + " \n", + " For technical reasons, the MS Windows version of mclapply()\n", + " is implemented as a serial function instead of a parallel\n", + " function.", + " \n\n", + " As a quick hack, we replace this serial version of mclapply()\n", + " with a wrapper to parLapply() for this R session. Please see\n\n", + " http://www.stat.cmu.edu/~nmv/2014/07/14/implementing-mclapply-on-windows \n\n", + " for details.\n\n" + )) + } + } else { + res <- mclapply(runs, function(x) do.call(fun, args), mc.cores = mc.cores) + gc() + return(res) + } +} + + + #' Run multiple mjmcmc runs in parallel, merging the results before returning. #' @param runs The number of runs to run #' @param cores The number of cores to run on -#' @param ... Further params passed to mjmcmc. +#' @param ... Further parameters passed to mjmcmc. #' @return Merged results from multiple mjmcmc runs +#' +#' @examples +#' result <- mjmcmc.parallel(runs = 1, +#' cores = 1, +#' loglik.pi = FBMS::gaussian.loglik, +#' y = matrix(rnorm(100), 100), +#' x = matrix(rnorm(600), 100)) +#' summary(result) +#' plot(result) +#' #' @export -mjmcmc.parallel <- function (runs, cores = getOption("mc.cores", 2L), ...) { - results <- mclapply(seq_len(runs), function (x) { mjmcmc(...) }, mc.cores = cores) +mjmcmc.parallel <- function(runs = 2, cores = getOption("mc.cores", 2L), ...) { + results <- list() + results$chains <- rmclapply(seq_len(runs), args = list(...), mc.cores = cores, fun = mjmcmc) + results$fixed <- results$chains[[1]]$fixed + results$intercept <- results$chains[[1]]$intercept + results$labels <- results$chains[[1]]$labels class(results) <- "mjmcmc_parallel" + gc() return(results) } -#' Run multiple gmjmcmc runs in parallel returning a list of all results. +#' Run multiple gmjmcmc (Genetically Modified MJMCMC) runs in parallel returning a list of all results. +#' @param x matrix containing the design matrix with data to use in the algorithm +#' @param y response variable +#' @param loglik.pi The (log) density to explore +#' @param mlpost_params parameters for the estimator function loglik.pi +#' @param loglik.alpha The likelihood function to use for alpha calculation +#' @param transforms A Character vector including the names of the non-linear functions to be used by the modification #' @param runs The number of runs to run #' @param cores The number of cores to run on -#' @param merge.options A list of options to pass to the [merge_results()] function run after the -#' @inheritParams gmjmcmc -#' @param ... Further params passed to mjmcmc. +#' @param verbose A logical denoting if messages should be printed +#' @param merge.options A list of options to pass to the [merge_results()] function run after the run +#' @param ... Further parameters passed to mjmcmc. #' @return Results from multiple gmjmcmc runs +#' +#' @examples +#' result <- gmjmcmc.parallel( +#' runs = 1, +#' cores = 1, +#' loglik.pi = NULL, +#' y = matrix(rnorm(100), 100), +#' x = matrix(rnorm(600), 100), +#' transforms = c("p0", "exp_dbl") +#' ) +#' +#' summary(result) +#' +#' plot(result) +#' #' @export -gmjmcmc.parallel <- function (runs, cores = getOption("mc.cores", 2L), merge.options = list(populations = "best", complex.measure = 2, tol = 0.0000001), data, loglik.pi = gaussian.loglik, loglik.alpha = gaussian.loglik.alpha(), transforms, ...) { +gmjmcmc.parallel <- function( + x, + y, + loglik.pi = NULL, + mlpost_params = list(family = "gaussian", beta_prior = list(type = "g-prior")), + loglik.alpha = gaussian.loglik.alpha, + transforms, + runs = 2, + cores = getOption("mc.cores", 2L), + verbose = FALSE, + merge.options = list(populations = "best", complex.measure = 2, tol = 0.0000001), + ... +) { options("gmjmcmc-transformations" = transforms) - results <- mclapply(seq_len(runs), function (x) { - gmjmcmc(data = data, loglik.pi = loglik.pi, loglik.alpha = loglik.alpha, transforms = transforms, ...) - }, mc.cores = cores) + results <- rmclapply(seq_len(runs), args = list(x = x, y = y, loglik.pi = loglik.pi, loglik.alpha = loglik.alpha, mlpost_params = mlpost_params, transforms = transforms, verbose = verbose, ...), mc.cores = cores, fun = gmjmcmc) class(results) <- "gmjmcmc_parallel" - merged <- merge_results(results, merge.options$populations, merge.options$complex.measure, merge.options$tol, data = data) + merged <- merge_results(results, merge.options$populations, merge.options$complex.measure, merge.options$tol, data = list(x = x, y = y)) + merged$labels <- merged$results.raw[[1]]$labels + gc() return(merged) } diff --git a/R/predict.R b/R/predict.R index f76d5143d1948cf10dd6822a66cb7e455843dbef..66db41e96e78ac740cbfa619ae8f58b6a3a48aca 100644 --- a/R/predict.R +++ b/R/predict.R @@ -1,6 +1,114 @@ +#' Predict responses from a BGNLM model +#' +#' This function generates predictions from a fitted \code{bgnlm_model} object given a new dataset. +#' +#' @param object A fitted \code{bgnlm_model} object obtained from the BGNLM fitting procedure. +#' It should contain the estimated coefficients in \code{model$coefs}. +#' @param x A \code{data.frame} containing the new data for which predictions are to be made. +#' The variables in \code{x} must match the features used in the model. +#' @param link A link function to apply to the linear predictor. +#' By default, it is the identity function \code{function(x)\{x\}}, +#' but it can be any function such as \code{plogis} for logistic regression models. +#' @param x_train Training design matrix to be provided when imputations are to be made from them +#' @param ... Additional arguments to pass to prediction function. +#' +#' @return A numeric vector of predicted values for the given data \code{x}. +#' These predictions are calculated as \eqn{\hat{y} = \text{link}(X \beta)}, +#' where \eqn{X} is the design matrix and \eqn{\beta} are the model coefficients. +#' +#' @examples +#' \dontrun{ +#' # Example with simulated data +#' set.seed(123) +#' x_train <- data.frame(PlanetaryMassJpt = rnorm(100), RadiusJpt = rnorm(100)) +#' model <- list( +#' coefs = c(Intercept = -0.5, PlanetaryMassJpt = 0.2, RadiusJpt = -0.1), +#' class = "bgnlm_model" +#' ) +#' class(model) <- "bgnlm_model" +#' +#' # New data for prediction +#' x_new <- data.frame(PlanetaryMassJpt = c(0.1, -0.3), RadiusJpt = c(0.2, -0.1)) +#' +#' # Predict using the identity link (default) +#' preds <- predict.bgnlm_model(model, x_new) +#' } +#' #' @export -predict.gmjmcmc <- function (object, x, link = function(x) x, quantiles = c(0.025, 0.5, 0.975), ...) { - merged <- merge_results(list(object)) +predict.bgnlm_model <- function(object, x, link = function(x) {x}, x_train = NULL, ... ) { + if(is.null(x_train)) + x <- impute_x(object, x) + else + x <- impute_x_pred(object, x_test = x, x_train = x_train) + x <- data.frame(x) + if (object$needs.precalc) { + if (object$intercept) { + x <- cbind(1, x) + } + + if(length(object$features)==0) + { + warning("MPM has no featres included! All posteriors below 0.5! Baseline only used.") + x.precalc <- model.matrix(~1, data = x) + } else precalc <- precalc.features(list(x = x, y = NULL, fixed = object$fixed), object$features) + + if (dim(precalc$x)[2]>length(object$coefs[object$coefs!=0])) { + precalc$x <- as.matrix(precalc$x[,-1]) + } + + yhat <- link(precalc$x %*% object$coefs[object$coefs != 0]) + } else { + + if(length(object$coefs)==1) + { + warning("MPM has no featres included! All posteriors below 0.5! Baseline only used.") + x.precalc <- model.matrix(~1, data = x) + } + else{ + x.precalc <- model.matrix( + as.formula(paste0("~I(", paste0(names(object$coefs)[-1][object$coefs[-1]!=0], collapse = ")+I("), ")")), + data = x + ) + } + + if (dim(x.precalc)[2]length(object$coefs[object$coefs!=0])) { + x.precalc <- as.matrix(x.precalc[,-1]) + } + yhat <- link(x.precalc %*% object$coefs[object$coefs!=0]) + } + return(yhat) +} + + +#' Predict using a gmjmcmc result object. +#' +#' @inheritParams predict.gmjmcmc_merged +#' @return A list containing aggregated predictions and per model predictions. +#' \item{aggr}{Aggregated predictions with mean and quantiles.} +#' \item{preds}{A list of lists containing individual predictions per model per population in object.} +#' +#' @examples +#' result <- gmjmcmc( +#' x = matrix(rnorm(600), 100), +#' y = matrix(rnorm(100), 100), +#' P = 2, +#' transforms = c("p0", "exp_dbl") +#' ) +#' preds <- predict(result, matrix(rnorm(600), 100)) +#' +#' +#' @export +predict.gmjmcmc <- function (object, x, link = function(x) x, quantiles = c(0.025, 0.5, 0.975), pop = NULL,tol = 0.0000001, x_train = NULL, ...) { + transforms.bak <- set.transforms(object$transforms) + if(is.null(x_train)) + x <- impute_x(object, x) + else + x <- impute_x_pred(object, x, x_train) + + merged <- merge_results(list(object), data = list(x = x, object$fixed), populations = pop, tol = tol) + set.transforms(transforms.bak) return(predict.gmjmcmc_merged(merged, x, link, quantiles)) } @@ -8,26 +116,65 @@ predict.gmjmcmc <- function (object, x, link = function(x) x, quantiles = c(0.02 #' Produces slightly different results from the fun above since this is using all lo.models too. #' @inheritParams predict.gmjmcmc_merged #' @param pop The population to use. -predict.gmjmcmc.2 <- function (object, x, link = function(x) x, quantiles = c(0.025, 0.5, 0.975), pop = 1, ...) { - +#' @noRd +predict.gmjmcmc.2 <- function (object, x, link = function(x) x, quantiles = c(0.025, 0.5, 0.975), pop = 1, x_train = NULL, ...) { + transforms.bak <- set.transforms(object$transforms) + if(is.null(x_train)) + x <- impute_x(object, x) + else + x <- impute_x_pred(object, x, x_train) + mmodel <- lapply(object[1:8], function (x) x[[pop]]) - + # Precalculate the features for the new data (c(0,1...) is because precalc features thinks there is an intercept and y col). x.precalc <- precalc.features(cbind(0, 1, x), mmodel$populations)[, -1] + set.transforms(transforms.bak) return(predict.mjmcmc(mmodel, x.precalc, link, quantiles)) } -#' Predict using a BGNLM model. +#' Predict using a merged gmjmcmc result object. #' #' @param object The model to use. #' @param x The new data to use for the prediction, a matrix where each row is an observation. #' @param link The link function to use -#' @param quantiles The quantiles to calculate credible intervals for the posterior moddes (in model space). +#' @param quantiles The quantiles to calculate credible intervals for the posterior modes (in model space). +#' @param pop The population to plot, defaults to last +#' @param tol The tolerance to use for the correlation when finding equivalent features, default is 0.0000001 +#' @param x_train Training design matrix to be provided when imputations are to be made from them +#' #' @param ... Not used. +#' @return A list containing aggregated predictions and per model predictions. +#' \item{aggr}{Aggregated predictions with mean and quantiles.} +#' \item{preds}{A list of lists containing individual predictions per model per population in object.} +#' +#' @examples +#' result <- gmjmcmc.parallel( +#' runs = 1, +#' cores = 1, +#' x = matrix(rnorm(600), 100), +#' y = matrix(rnorm(100), 100), +#' P = 2, +#' transforms = c("p0", "exp_dbl") +#' ) +#' preds <- predict(result, matrix(rnorm(600), 100)) #' #' @export -predict.gmjmcmc_merged <- function (object, x, link = function(x) x, quantiles = c(0.025, 0.5, 0.975), ...) { - x <- as.matrix(x) +predict.gmjmcmc_merged <- function (object, x, link = function(x) x, quantiles = c(0.025, 0.5, 0.975), pop = NULL, tol = 0.0000001, x_train = NULL, ...) { + + + if(is.null(x_train)) + x <- impute_x(object, x) + else + x <- impute_x_pred(object, x, x_train) + if (object$intercept) { + x <- cbind(1, x) + } + + + transforms.bak <- set.transforms(object$transforms) + if (!is.null(pop)) + object <- merge_results(object$results.raw, pop, 2, tol, data = list(x = x, fixed = object$fixed)) + preds <- list() for (i in seq_along(object$results)) { preds[[i]] <- list() @@ -36,24 +183,24 @@ predict.gmjmcmc_merged <- function (object, x, link = function(x) x, quantiles = models <- object$results[[i]]$models[[j]] features <- object$results[[i]]$populations[[j]] model.probs <- object$results[[i]]$model.probs[[j]] - - # Precalculate the features for the new data (c(0,1...) is because precalc features thinks there is an intercept and y col). - x.precalc <- precalc.features(cbind(0, 1, x), features)[, -1] - - yhat <- matrix(0, nrow=nrow(x), ncol=length(models)) + + # Precalculate the features for the new data + x.precalc <- precalc.features(list(x = x, fixed = object$fixed), features)$x + + yhat <- matrix(0, nrow = nrow(x), ncol = length(models)) for (k in seq_along(models)) { # Models which have 0 weight are skipped since they may also be invalid, and would not influence the predictions. if (models[[k]]$crit == -.Machine$double.xmax) next - yhat[, k] <- link(x.precalc[, c(TRUE, models[[k]]$model), drop=FALSE] %*% models[[k]]$coefs) + yhat[, k] <- link(x.precalc[, c(rep(TRUE, object$fixed), models[[k]]$model), drop=FALSE] %*% models[[k]]$coefs) } - + mean.pred <- rowSums(yhat %*% diag(as.numeric(model.probs))) pred.quant <- apply(yhat, 1, weighted.quantiles, weights=model.probs, prob=quantiles) - + preds[[i]][[j]] <- list(mean=mean.pred, quantiles=pred.quant, weight=object$results[[i]]$pop.weights[j]) } } - + aggr <- list() aggr$mean <- 0 * preds[[1]][[1]]$mean aggr$quantiles <- 0 * preds[[1]][[1]]$quantiles @@ -63,42 +210,81 @@ predict.gmjmcmc_merged <- function (object, x, link = function(x) x, quantiles = aggr$quantiles <- aggr$quantiles + preds[[i]][[j]]$quantiles * object$results[[i]]$pop.weights[j] } } - - return(list(aggr=aggr, preds=preds)) + set.transforms(transforms.bak) + return(list(aggr = aggr, preds = preds)) } +#' Predict using a mjmcmc result object. +#' +#' @inheritParams predict.gmjmcmc_merged +#' @return A list containing aggregated predictions. +#' \item{mean}{Mean of aggregated predictions.} +#' \item{quantiles}{Quantiles of aggregated predictions.} +#' +#' @examples +#' result <- mjmcmc( +#' x = matrix(rnorm(600), 100), +#' y = matrix(rnorm(100), 100), +#' loglik.pi = gaussian.loglik) +#' preds <- predict(result, matrix(rnorm(600), 100)) +#' #' @export -predict.mjmcmc <- function (object, x, link = function(x) x, quantiles = c(0.025, 0.5, 0.975), ...) { +predict.mjmcmc <- function (object, x, link = function(x) x, quantiles = c(0.025, 0.5, 0.975), x_train = NULL, ...) { # Select the models and features to predict from at this iteration - models <- c(object$models, object$lo.models)[object$model.probs.idx] - - yhat <- matrix(0, nrow=nrow(x), ncol=length(models)) + if(is.null(x_train)) + x <- impute_x(object, x) + else + x <- impute_x_pred(object, x, x_train) + + + if (object$intercept) { + x <- cbind(1, x) + } + + + models <- object$models[object$model.probs.idx] + + yhat <- matrix(0, nrow = nrow(x), ncol = length(models)) for (k in seq_along(models)) { # Models which have 0 weight are skipped since they may also be invalid, and would not influence the predictions. if (models[[k]]$crit == -.Machine$double.xmax) next - yhat[, k] <- link(x[, c(TRUE, models[[k]]$model), drop=FALSE] %*% models[[k]]$coefs) + yhat[, k] <- link(x[, c(rep(TRUE, object$fixed), models[[k]]$model), drop=FALSE] %*% models[[k]]$coefs) } - + mean.pred <- rowSums(yhat %*% diag(as.numeric(object$model.probs))) pred.quant <- apply(yhat, 1, weighted.quantiles, weights = object$model.probs, prob = quantiles) - + return(list(mean = mean.pred, quantiles = pred.quant)) } +#' Predict using a mjmcmc result object from a parallel run. +#' +#' @inheritParams predict.gmjmcmc_merged +#' @return A list containing aggregated predictions. +#' \item{mean}{Mean of aggregated predictions.} +#' \item{quantiles}{Quantiles of aggregated predictions.} +#' +#' @examples +#' result <- mjmcmc.parallel(runs = 1, +#' cores = 1, +#' x = matrix(rnorm(600), 100), +#' y = matrix(rnorm(100), 100), +#' loglik.pi = gaussian.loglik) +#' preds <- predict(result, matrix(rnorm(600), 100)) +#' #' @export -predict.mjmcmc_parallel <- function (object, x, link = function(x) x, quantiles = c(0.025, 0.5, 0.975), ...) { - max.crits <- numeric() - for (i in seq_along(object)) { - max.crits <- c(max.crits, object[[i]]$best.crit) - } +predict.mjmcmc_parallel <- function (object, x, link = function(x) x, quantiles = c(0.025, 0.5, 0.975), x_train = NULL, ...) { + if(is.null(x_train)) + x <- impute_x(object, x) + else + x <- impute_x_pred(object, x, x_train) + + max.crits <- sapply(object$chains, function (x) x$best.crit) max.crit <- max(max.crits) result.weights <- exp(max.crits - max.crit) / sum(exp(max.crits - max.crit)) - - preds <- list() - for (i in seq_along(object)) { - preds[[i]] <- predict.mjmcmc(object[[i]], x, link, quantiles) - } - + + preds <- lapply(object$chains, predict.mjmcmc,x, link, quantiles) + aggr <- list() aggr$mean <- 0 * preds[[1]]$mean aggr$quantiles <- 0 * preds[[1]]$quantiles @@ -106,14 +292,40 @@ predict.mjmcmc_parallel <- function (object, x, link = function(x) x, quantiles aggr$mean <- aggr$mean + preds[[i]]$mean * result.weights[i] aggr$quantiles <- aggr$quantiles + preds[[i]]$quantiles * result.weights[i] } - + return(list(aggr = aggr, preds = preds)) } +#' Predict using a gmjmcmc result object from a parallel run. +#' +#' @inheritParams predict.gmjmcmc_merged +#' @param ... Additional arguments to pass to merge_results. +#' @return A list containing aggregated predictions and per model predictions. +#' \item{aggr}{Aggregated predictions with mean and quantiles.} +#' \item{preds}{A list of lists containing individual predictions per model per population in object.} +#' +#' @examples +#' result <- gmjmcmc.parallel( +#' runs = 1, +#' cores = 1, +#' x = matrix(rnorm(600), 100), +#' y = matrix(rnorm(100), 100), +#' P = 2, +#' transforms = c("p0", "exp_dbl") +#' ) +#' preds <- predict(result, matrix(rnorm(600), 100)) +#' #' @export -predict.gmjmcmc_parallel <- function (object, x, link = function(x) x, quantiles = c(0.025, 0.5, 0.975), ...) { - merged <- merge_results(object, ...) - predict.gmjmcmc_merged(merged, x, link, quantiles) +predict.gmjmcmc_parallel <- function (object, x, link = function(x) x, quantiles = c(0.025, 0.5, 0.975), x_train = NULL, ...) { + transforms.bak <- set.transforms(object$transforms) + if(is.null(x_train)) + x <- impute_x(object, x) + else + x <- impute_x_pred(object, x, x_train) + merged <- merge_results(object,data = cbind(1, x), ...) + results <- predict.gmjmcmc_merged(merged, x, link, quantiles) + set.transforms(transforms.bak) + return(results) } #' Calculate weighted quantiles @@ -123,13 +335,55 @@ predict.gmjmcmc_parallel <- function (object, x, link = function(x) x, quantiles #' @param prob The probabilities of the quantiles to use #' #' @return Weighted quantiles +#' @noRd weighted.quantiles <- function (values, weights, prob = c(0.025, 0.975)) { ordered <- order(values) P <- cumsum(weights[ordered]) - + iv <- integer(length(prob)) for (i in seq_along(iv)) { iv[i] <- which.max(P >= prob[i]) } {values[ordered]}[iv] } + +impute_x <- function (object, x) { + if (!is.null(attr(object, which = "imputed"))) { + df <- data.frame(x) + na.matr <- data.frame(1 * (is.na(df))) + cm <- colMeans(na.matr) + na.matr <- na.matr[, attr(object, which = "imputed")] + names(na.matr) <- paste0("mis_", names(na.matr)) + for (i in which(cm != 0)){ + med <- median(df[[i]], na.rm = TRUE) + if(is.na(med)) + stop("No data for imputation in test set, provide x_train in predict!") + df[[i]][is.na(df[[i]])] <- med + } + return(as.matrix(data.frame(df,na.matr))) + } + return(as.matrix(x)) +} + + +impute_x_pred <- function (object, x_test, x_train) { + if (!is.null(attr(object, which = "imputed"))) { + df <- data.frame(x_test) + x_train <- data.frame(x_train) + na.matr <- data.frame(1 * (is.na(df))) + cm <- colMeans(na.matr) + na.matr <- na.matr[, attr(object, which = "imputed")] + names(na.matr) <- paste0("mis_", names(na.matr)) + for (i in which(cm != 0)){ + med <- median(x_train[[i]], na.rm = TRUE) + if(is.na(med)) + { + warning("One or more missing in test columns do not have any data in x_train, test set will be used for imputations!") + med <- median(df[[i]], na.rm = TRUE) + } + df[[i]][is.na(df[[i]])] <- med + } + return(as.matrix(data.frame(df,na.matr))) + } + return(as.matrix(x_test)) +} diff --git a/R/proposals.R b/R/proposals.R index 407821ccb7c23722cb4ca4d4372ab69d431a8dd0..e8fd657a41ef218ce322cafa3d88e5358f1276b4 100644 --- a/R/proposals.R +++ b/R/proposals.R @@ -15,15 +15,21 @@ # With neigh.min=neigh.max, we get a fixed neighborhood size (Type 2 and 4) # With probs left out, we get a swap instead of a random change (Type 3 and 4) # Indices tells the sampler which indices it is allowed to sample from -model.proposal.1_4 <- function (model.size, neigh.min, neigh.max, indices, probs=NULL, prob=F) { +model.proposal.1_4 <- function (model.size, neigh.min, neigh.max, indices, probs=NULL, prob=FALSE) { # If no probs, set all to 1 as we are doing a swap + if(model.size < 1) + model.size <- 1 if (is.null(probs)) probs <- rep(1,model.size) + if(length(indices) == 0) + indices <- 1:model.size # Set neighborhood size, random or fixed if (neigh.max == neigh.min) neigh.size <- neigh.min else neigh.size <- sample.int(n = neigh.max - neigh.min, size = 1) + neigh.min - 1 # Select the negihborhood by sampling from the p covariates - neighborhood <- sample2((1:model.size)[indices], size = neigh.size, prob = probs[indices]) - + if(length(indices)>0 & model.size > length(indices)) + neighborhood <- sample2((1:model.size)[indices], size = neigh.size, prob = probs[indices] + 0.000001) + else + neighborhood <- 1 # Sample which variables to change based on the probs vector swaps <- as.logical(rbinom(neigh.size, 1, probs[neighborhood])) swaps <- ind.to.log(neighborhood[swaps], model.size) @@ -44,7 +50,7 @@ model.proposal.1_4.prob <- function (swaps, probs, neigh.size, neigh.min, neigh. } # Uniform addition and deletion of a covariate (Type 5 and 6) -model.proposal.5_6 <- function (model, addition=T, indices, probs=NULL, prob=F) { +model.proposal.5_6 <- function (model, addition=TRUE, indices, probs=NULL, prob=FALSE) { # If no probs, set all to 1 if (is.null(probs)) probs <- rep(1,length(model)) @@ -74,7 +80,7 @@ model.proposal.5_6.prob <- function (model, addition) { } # Function to generate a proposed model given a current one -gen.proposal <- function (model, params, type, indices=NULL, probs=NULL, prob=F) { +gen.proposal <- function (model, params, type, indices=NULL, probs=NULL, prob=FALSE) { # If no indices are selected, allow all if (is.null(indices)) indices <- rep(T, length(model)) if (type < 5) { @@ -89,10 +95,10 @@ gen.proposal <- function (model, params, type, indices=NULL, probs=NULL, prob=F) proposal <- model.proposal.1_4(length(model), params$neigh.min, params$neigh.max, indices, probs, prob) } else if (type == 5) { # Generate a proposal of type 5 (addition of a covariate) - proposal <- model.proposal.5_6(model, addition=T, indices, probs, prob) + proposal <- model.proposal.5_6(model, addition=TRUE, indices, probs, prob) } else if (type == 6) { # Generate a proposal of type 6 (subtraction of a covariate) - proposal <- model.proposal.5_6(model, addition=F, indices, probs, prob) + proposal <- model.proposal.5_6(model, addition=FALSE, indices, probs, prob) } return(proposal) } @@ -111,10 +117,10 @@ prob.proposal <- function (proposal, current, type, params, probs=NULL) { prob <- model.proposal.1_4.prob(swaps, probs, params$neigh.size, params$neigh.min, params$neigh.max) } else if (type == 5) { # Generate a proposal of type 5 (addition of a covariate) - prob <- model.proposal.5_6.prob(current, addition=T) + prob <- model.proposal.5_6.prob(current, addition=TRUE) } else if (type == 6) { # Generate a proposal of type 6 (subtraction of a covariate) - prob <- model.proposal.5_6.prob(current, addition=F) + prob <- model.proposal.5_6.prob(current, addition=FALSE) } return(prob) } diff --git a/R/results.R b/R/results.R index ee81507efe6debc7133f797c03f1495d27173fb1..1ce7b35437fb10911017b01d5e8c3fb31af78e08 100644 --- a/R/results.R +++ b/R/results.R @@ -4,36 +4,67 @@ # Created on: 2021-05-06 #' Merge a list of multiple results from many runs -#' This function will weight the features based on the best mlik in that population +#' This function will weight the features based on the best marginal posterior in that population #' and merge the results together, simplifying by merging equivalent features (having high correlation). #' -#' @param results A list containing multiple results from GMJMCMC. +#' @param results A list containing multiple results from GMJMCMC (Genetically Modified MJMCMC). #' @param populations Which populations should be merged from the results, can be "all", "last" (default) or "best". #' @param complex.measure The complex measure to use when finding the simplest equivalent feature, #' 1=total width, 2=operation count and 3=depth. -#' @param tol The tolerance to use for the correlation when finding equivalent features, default is 0. +#' @param tol The tolerance to use for the correlation when finding equivalent features, default is 0.0000001 #' @param data Data to use when comparing features, default is NULL meaning that mock data will be generated, #' if data is supplied it should be of the same form as is required by gmjmcmc, i.e. with both x, y and an intercept. #' +#' @return An object of class "gmjmcmc_merged" containing the following elements: +#' \item{features}{The features where equivalent features are represented in their simplest form.} +#' \item{marg.probs}{Importance of features.} +#' \item{counts}{Counts of how many versions that were present of each feature.} +#' \item{results}{Results as they were passed to the function.} +#' \item{pop.best}{The population in the results which contained the model with the highest log marginal posterior.} +#' \item{thread.best}{The thread in the results which contained the model with the highest log marginal posterior.} +#' \item{crit.best}{The highest log marginal posterior for any model in the results.} +#' \item{reported}{The highest log marginal likelihood for the reported populations as defined in the populations argument.} +#' \item{rep.pop}{The index of the population which contains reported.} +#' \item{best.log.posteriors}{A matrix where the first column contains the population indices and the second column contains the model with the highest log marginal posterior within that population.} +#' \item{rep.thread}{The index of the thread which contains reported.} +#' +#' @examples +#' result <- gmjmcmc.parallel( +#' runs = 1, +#' cores = 1, +#' y = matrix(rnorm(100), 100),x = matrix(rnorm(600), 100), +#' P = 2, +#' transforms = c("p0", "exp_dbl") +#' ) +#' +#' summary(result) +#' +#' plot(result) +#' +#' merge_results(result$results) +#' #' @export merge_results merge_results <- function (results, populations = NULL, complex.measure = NULL, tol = NULL, data = NULL) { # Default values if (is.null(populations)) - populations <- "last" + populations <-"best" if (is.null(complex.measure)) complex.measure <- 2 if (is.null(tol)) tol <- 0.0000001 - + + # Check and filter results that did not run successfully + results <- filter.results(results) + raw.results <- results res.count <- length(results) - + # Select populations to use res.lengths <- vector("list") for (i in 1:res.count) res.lengths[[i]] <- length(results[[i]]$populations) if (populations == "last") pops.use <- res.lengths else if (populations == "all") pops.use <- lapply(res.lengths, function(x) 1:x) else if (populations == "best") pops.use <- lapply(1:res.count, function(x) which.max(unlist(results[[x]]$best.marg))) - + # Get the population weigths to be able to weight the features pw <- population.weigths(results, pops.use) pop.weights <- pw$weights @@ -43,11 +74,9 @@ merge_results <- function (results, populations = NULL, complex.measure = NULL, pop.best <- 1 thread.best <- 1 for (i in seq_along(results)) { - for (pop in 1:(length(results[[1]]$populations))) - { - bests[pop,i] <- results[[i]]$best.margs[[pop]] - if(results[[i]]$best.margs[[pop]] > crit.best) - { + for (pop in 1:(length(results[[i]]$populations))) { + bests[pop, i] <- results[[i]]$best.margs[[pop]] + if (results[[i]]$best.margs[[pop]] > crit.best) { crit.best <- results[[i]]$best.margs[[pop]] pop.best <- pop thread.best <- i @@ -55,7 +84,6 @@ merge_results <- function (results, populations = NULL, complex.measure = NULL, } } - # Collect all features and their renormalized weighted values features <- vector("list") renorms <- vector("list") @@ -68,49 +96,77 @@ merge_results <- function (results, populations = NULL, complex.measure = NULL, renorms <- append(renorms, pop.weights[weight_idx] * results[[i]]$marg.probs[[pop]]) results[[i]]$pop.weights[pop] <- pop.weights[weight_idx] weight_idx <- weight_idx + 1 - + model.probs <- marginal.probs.renorm(results[[i]]$models[[pop]], "models") results[[i]]$model.probs[[pop]] <- model.probs$probs results[[i]]$models[[pop]] <- results[[i]]$models[[pop]][model.probs$idx] } accept.tot <- results[[i]]$accept.tot best <- results[[i]]$best - results[[i]] <- lapply(results[[i]], function (x) x[pops.use[[i]]]) + for (item in names(results[[i]])) { + if (!(item %in% (c("accept.tot", "best", "transforms", "fixed", "intercept", "ncov")))) { + results[[i]][[item]] <- results[[i]][[item]][pops.use[[i]]] + } + } results[[i]]$accept.tot <- accept.tot results[[i]]$best <- best } renorms <- unlist(renorms) na.feats <- which(is.na(renorms)) if (length(na.feats) != 0) { - cat("Underflow occurred,", length(na.feats), "features removed.\n") + warning("Underflow occurred,", length(na.feats), "features removed.\n") renorms <- renorms[-na.feats] features <- features[-na.feats] } feat.count <- length(features) - + # Get complexity for all features complex <- complex.features(features) - + ## Detect equivalent features # Generate mock data to compare features with - if (is.null(data)) mock.data <- matrix(runif((feat.count+2)^2, -100, 100), ncol=feat.count+2) - else mock.data <- check.data(data) - mock.data.precalc <- precalc.features(mock.data, features)[,-(1:2)] - + uk <- 1 + good.mock <- FALSE + while(!good.mock & uk < 10) + { + uk <- uk + 1 + if (is.null(data)) mock.data <- list(x = matrix(runif((results[[1]]$ncov)^2, -100, 100), ncol = results[[1]]$ncov)) + else + if(is.null(data$x)) mock.data <- list(x = data) else mock.data = data + mock.data$fixed = results[[1]]$fixed + if (results[[1]]$intercept) mock.data$x <- cbind(1, mock.data$x) + + mock.data.precalc <- precalc.features(mock.data, features)$x[ , seq_len(feat.count) + results[[1]]$fixed, drop = FALSE] + + if(min(sapply(1:dim(mock.data.precalc)[2], function(x)sd(mock.data.precalc[,x])))>0) + { + good.mock <- TRUE + break + } + } + if(uk == 10) + warning( + "Constant features detected in merge_results().\n", + " - If not already, provide the 'data' argument in the function call.\n", + " - If the warning persists, one or more features in your dataset are constant (no variation).\n", + "This should not affect results critically, but please:\n", + " * check your input data, or\n", + " * reconsider the chosen nonlinearities/features." + ) # Calculate the correlation to find equivalent features cors <- cor(mock.data.precalc) - + # A map to link equivalent features together, # row 1-3 are the simplest equivalent features based on three different complexity measures # row 4 is the total weighted density of those features - feats.map <- matrix(1:feat.count, 4, feat.count, byrow=T) + feats.map <- matrix(1:feat.count, 4, feat.count, byrow = TRUE) for (i in seq_len(nrow(cors))) { equiv.feats <- which(cors[i, ] >= (1 - tol)) # Compare equivalent features complexity to find most simple - equiv.complex <- list(width=complex$width[equiv.feats], oc=complex$oc[equiv.feats], depth=complex$depth[equiv.feats]) + equiv.complex <- list(width = complex$width[equiv.feats], oc = complex$oc[equiv.feats], depth = complex$depth[equiv.feats]) equiv.simplest <- lapply(equiv.complex, which.min) - feats.map[1:3,equiv.feats] <- c(equiv.feats[equiv.simplest$width], equiv.feats[equiv.simplest$oc], equiv.feats[equiv.simplest$depth]) - feats.map[4,equiv.feats] <- sum(renorms[equiv.feats]) + feats.map[1:3, equiv.feats] <- c(equiv.feats[equiv.simplest$width], equiv.feats[equiv.simplest$oc], equiv.feats[equiv.simplest$depth]) + feats.map[4, equiv.feats] <- sum(renorms[equiv.feats]) } # Select the simplest features based on the specified complexity measure and sort them feats.simplest.ids <- unique(feats.map[complex.measure, ]) @@ -118,12 +174,45 @@ merge_results <- function (results, populations = NULL, complex.measure = NULL, counts <- sapply(feats.simplest.ids, function(x) sum(feats.map[complex.measure,] == x)) feats.simplest <- features[feats.simplest.ids] importance <- feats.map[4, feats.simplest.ids, drop = FALSE] - merged <- list(features = feats.simplest, marg.probs = importance, counts = counts, results = results, pop.best = pop.best, thread.best = thread.best, crit.best = crit.best, - reported = pw$best, rep.pop = pw$pop.best, best.log.posteriors = bests, rep.thread = pw$thread.best) + merged <- list( + features = feats.simplest, + marg.probs = importance, + counts = counts, + results = results, + results.raw = raw.results, + pop.best = pop.best, + thread.best = thread.best, + crit.best = crit.best, + reported = pw$best, + rep.pop = pw$pop.best, + best.log.posteriors = bests, + rep.thread = pw$thread.best, + transforms = results[[1]]$transforms, + fixed = results[[1]]$fixed, + intercept = results[[1]]$intercept + ) attr(merged, "class") <- "gmjmcmc_merged" return(merged) } +filter.results <- function (results) { + res.count <- length(results) + res.converged <- sum(sapply(results, function(x) length(x) > 1)) + + if (res.converged == 0) { + stop(paste0("All chains resulted in an error!", results[[1]],"\n Please debug and restart")) + } + if (res.converged < res.count) { + warning(paste0("Warning! Some chains resulted in an error: ", results[[which(!sapply(results,function(x)length(x)>1))[1]]], "'\n Only ",res.converged, " chains finished! \n Only finished chains will be used further!")) + results <- lapply(results, function (x) { + if (length(x) > 1) return(x) + else return(NULL) + }) + results <- results[sapply(results, function (x) !is.null(x))] + } + return(results) +} + # Function for calculating the weights of different populations based on best mlik population.weigths <- function (results, pops.use) { max.crits <- vector("list") @@ -131,20 +220,17 @@ population.weigths <- function (results, pops.use) { pop.best <- 1 thread.best <- 1 for (i in seq_along(results)) { - for (pop in pops.use[[i]]) - { + for (pop in pops.use[[i]]) { max.crits <- append(max.crits, results[[i]]$best.margs[[pop]]) - if(results[[i]]$best.margs[[pop]] > max.crit) - { + if (results[[i]]$best.margs[[pop]] > max.crit) { max.crit <- results[[i]]$best.margs[[pop]] pop.best <- pop thread.best <- i } } - } max.crits <- unlist(max.crits) - + return(list(weights = exp(max.crits-max.crit) / sum(exp(max.crits-max.crit)), best = max.crit, thread.best = thread.best, pop.best = pop.best)) } @@ -155,134 +241,277 @@ population.weigths <- function (results, pops.use) { #' @param link The link function to use, as a string #' @param round Rounding error for the features in the printed format #' +#' @return A character representation of a model +#' +#' @examples +#' result <- gmjmcmc(y = matrix(rnorm(100), 100), +#' x = matrix(rnorm(600), 100), +#' P = 2, transforms = c("p0", "exp_dbl")) +#' summary(result) +#' plot(result) +#' model.string(c(TRUE, FALSE, TRUE, FALSE, TRUE), result$populations[[1]]) +#' model.string(result$models[[1]][1][[1]]$model, result$populations[[1]]) +#' #' @export model.string model.string <- function (model, features, link = "I", round = 2) { - modelstring <- paste0(sapply(features[model], print.feature, alphas = TRUE, round = round), collapse="+") + modelstring <- paste0(sapply(features[model], print.feature, alphas = TRUE, round = round), collapse = "+") modelfun <- set_alphas(modelstring) modelfun$formula <- paste0(link, "(", modelfun$formula, ")") return(modelfun) } -#' Function to print a quick summary of the results +#' Retrieve the Median Probability Model (MPM) #' -#' @param object The results to use -#' @param pop The population to print for, defaults to last -#' @param tol The tolerance to use as a threshold when reporting the results. -#' @param labels Should the covariates be named, or just referred to as their place in the data.frame. -#' @param ... Not used. +#' This function extracts the Median Probability Model (MPM) from a fitted model object. +#' The MPM includes features with marginal posterior inclusion probabilities greater than 0.5. +#' It constructs the corresponding model matrix and computes the model fit using the specified likelihood. #' -#' @export -summary.gmjmcmc <- function (object, pop = "last", tol = 0.0001, labels = F, ...) { - if (pop == "last") pop <- length(object$models) - else if (pop == "best") pop <- which.max(unlist(object$best.margs)) - feats.strings <- sapply(object$populations[[pop]], FUN = function(x) print.feature(x = x, labels = labels, round = 2)) - - summary_internal( - best = object$best, - marg.probs = object$marg.probs[[pop]], - feats.strings = feats.strings, - best.pop = which.max(unlist(object$best.margs)), - reported = object$best.margs[[pop]], - rep.pop = pop, - tol = tol - ) -} - -#' Function to print a quick summary of the results +#' @param result A fitted model object (e.g., from \code{mjmcmc}, \code{gmjmcmc}, or related classes) containing the summary statistics and marginal probabilities. +#' @param y A numeric vector of response values. For \code{family = "binomial"}, it should contain binary (0/1) responses. +#' @param x A \code{data.frame} of predictor variables. Columns must correspond to features considered during model fitting. +#' @param labels If specified, custom labels of covariates can be used. Default is \code{FALSE}. +#' @param family Character string specifying the model family. Supported options are: +#' \itemize{ +#' \item \code{"gaussian"} (default) - for continuous outcomes. +#' \item \code{"binomial"} - for binary outcomes. +#' \item \code{"custom"} - for user-defined likelihood functions. +#' } +#' If an unsupported family is provided, a warning is issued and the Gaussian likelihood is used by default. +#' @param loglik.pi A function that computes the log-likelihood. Defaults to \code{gaussian.loglik} unless \code{family = "binomial"}, in which case \code{logistic.loglik} is used. for custom family the user must specify the same likelihood that was used in the inference. +#' @param params Parameters of `loglik.pi`, if not specified NULL will be used by default #' -#' @param object The results to use -#' @param tol The tolerance to use as a threshold when reporting the results. -#' @param labels Should the covariates be named, or just referred to as their place in the data.frame. -#' @param ... Not used. +#' @return A \code{bgnlm_model} object containing: +#' \describe{ +#' \item{\code{prob}}{The log marginal likelihood of the MPM.} +#' \item{\code{model}}{A logical vector indicating included features.} +#' \item{\code{crit}}{Criterion label set to \code{"MPM"}.} +#' \item{\code{coefs}}{A named numeric vector of model coefficients, including the intercept.} +#' } #' -#' @export -summary.gmjmcmc_merged <- function (object, tol = 0.0001,labels = F, ...) { - best <- max(sapply(object$results, function (y) y$best)) - feats.strings <- sapply(object$features, FUN = function(x) print.feature(x = x, labels = labels, round = 2)) - summary_internal(best = object$crit.best, feats.strings, object$marg.probs, - best.pop = object$pop.best, thread.best = object$thread.best, - reported = object$reported, rep.pop = object$rep.pop, rep.thread = object$rep.thread, tol = tol) -} - -#' Function to print a quick summary of the results +#' @examples +#' \dontrun{ +#' # Simulate data +#' set.seed(42) +#' x <- data.frame( +#' PlanetaryMassJpt = rnorm(100), +#' RadiusJpt = rnorm(100), +#' PeriodDays = rnorm(100) +#' ) +#' y <- 1 + 0.5 * x$PlanetaryMassJpt - 0.3 * x$RadiusJpt + rnorm(100) #' -#' @param object The results to use -#' @param tol The tolerance to use as a threshold when reporting the results. -#' @param labels Should the covariates be named, or just referred to as their place in the data.frame. -#' @param ... Not used. +#' # Assume 'result' is a fitted object from gmjmcmc or mjmcmc +#' result <- mjmcmc(cbind(y,x)) +#' +#' # Get the MPM +#' mpm_model <- get.mpm.model(result, y, x, family = "gaussian") +#' +#' # Access coefficients +#' mpm_model$coefs +#' } #' #' @export -summary.mjmcmc <- function (object, tol = 0.0001, labels = FALSE, ...) { - return(summary.mjmcmc_parallel(list(object), tol = tol, labels = labels)) +get.mpm.model <- function(result, y, x, labels = F, family = "gaussian", loglik.pi = gaussian.loglik, params = NULL) { + + transforms.bak <- set.transforms(result$transforms) + + if (!family %in% c("custom","binomial","gaussian")) + warning("Unknown family specified. The default gaussian.loglik will be used.") + + if(!labels & length(result$labels)>0) + labels <- result$labels + + if (!is.null(attr(result, which = "imputed"))) + x <- impute_x(result,x) + + if (family == "binomial") + loglik.pi <- logistic.loglik + + if (is(result, "mjmcmc_parallel")) { + models <- unlist(lapply(result$chains, function (x) x$models), recursive = FALSE) + marg.probs <- marginal.probs.renorm(models)$probs + features <- result$chains[[1]]$populations + } else if (is(result, "gmjmcmc")) { + best_pop <- which.max(unlist(result$best.margs)) + marg.probs <- result$marg.probs[[best_pop]] + features <- result$populations[[best_pop]] + } else if (is(result, "gmjmcmc_merged")) { + marg.probs <- result$marg.probs + features <- result$features + }else + { + marg.probs <- result$marg.probs + features <- result$populations + } + features <- features[marg.probs > 0.5] + + if (result$intercept) { + x <- cbind(1, x) + } + precalc <- precalc.features(list(x = x, y = y, fixed = result$fixed), features) + + coefs <- loglik.pi(y = y, x = precalc$x, model = rep(TRUE, length(features) + result$fixed), complex = list(oc = 0), mlpost_params = params)$coefs + + coefs[is.na(coefs)] <- 0 + + names(coefs) <- c(names(coefs)[seq_len(result$fixed)], sapply(features, print.feature,labels = labels)) + + + model <- structure(list( + coefs = coefs, + features = features, + fixed = result$fixed, + intercept = result$intercept, + needs.precalc = FALSE + ), class = "bgnlm_model") + + set.transforms(transforms.bak) + + attr(model, which = "imputed") <- attr(result, which = "imputed") + + return(model) } -#' Function to print a quick summary of the results + +#' Extract the Best Model from MJMCMC or GMJMCMC Results #' -#' @param object The results to use -#' @param tol The tolerance to use as a threshold when reporting the results. -#' @param labels Should the covariates be named, or just referred to as their place in the data.frame. -#' @param ... Not used. +#' This function retrieves the best model from the results of MJMCMC, MJMCMC parallel, GMJMCMC, or GMJMCMC merged runs +#' based on the maximum criterion value (\code{crit}). The returned list includes the model probability, selected features, +#' criterion value, intercept parameter, and named coefficients. +#' +#' @param result An object of class \code{"mjmcmc"}, \code{"mjmcmc_parallel"}, \code{"gmjmcmc"}, or \code{"gmjmcmc_merged"}, +#' containing the results from the corresponding model search algorithms. +#' @param labels Logical; if \code{TRUE}, uses labeled feature names when naming the model coefficients. Default is \code{FALSE}. +#' +#' @return A list containing the details of the best model: +#' \describe{ +#' \item{\code{prob}}{A numeric value representing the model's probability.} +#' \item{\code{model}}{A logical vector indicating which features are included in the best model.} +#' \item{\code{crit}}{The criterion value used for model selection (e.g., marginal likelihood or posterior probability).} +#' \item{\code{alpha}}{The intercept parameter of the best model.} +#' \item{\code{coefs}}{A named numeric vector of model coefficients, including the intercept and selected features.} +#' } +#' +#' @details +#' The function identifies the best model by selecting the one with the highest \code{crit} value. Selection logic depends on the class of the \code{result} object: +#' \describe{ +#' \item{\code{"mjmcmc"}}{Selects the top model from a single MJMCMC run.} +#' \item{\code{"mjmcmc_parallel"}}{Identifies the best chain, then selects the best model from that chain.} +#' \item{\code{"gmjmcmc"}}{Selects the best population and model within that population.} +#' \item{\code{"gmjmcmc_merged"}}{Finds the best chain and population before extracting the top model.} +#' } +#' +#' @examples +#' result <- gmjmcmc(x = matrix(rnorm(600), 100), +#' y = matrix(rnorm(100), 100), +#' P = 2, transforms = c("p0", "exp_dbl")) +#' get.best.model(result) #' #' @export -summary.mjmcmc_parallel <- function (object, tol = 0.0001, labels = FALSE, ...) { - # Get features as strings for printing - feats.strings <- sapply(object[[1]]$populations, FUN = function(x) print.feature(x = x, labels = labels, round = 2)) - # Get marginal posterior of features - models <- unlist(lapply(object, function (x) x$models), recursive = FALSE) - marg.probs <- marginal.probs.renorm(models)$probs - best <- max(sapply(object, function (x) x$best)) - return(summary_internal(best, feats.strings, marg.probs, tol = tol)) -} - -summary_internal <- function (best, feats.strings, marg.probs, tol = 0.0001, best.pop = NULL,reported = NULL, rep.pop = NULL, rep.thread = NULL, thread.best = NULL) { - # Print the final distribution - keep <- which(marg.probs[1, ] > tol) - cat(" Importance | Feature\n") - print.dist(marg.probs[keep], feats.strings[keep], -1) - # Print the best log marginal posterior - if(length(best.pop) > 0){ - - if(length(thread.best) > 0) - { - cat("\nBest population:", best.pop, " thread:", thread.best, " log marginal posterior:", best,"\n") - cat("Report population:", rep.pop," thread:", rep.thread, " log marginal posterior:", reported,"\n") - - }else{ - cat("\nBest population:", best.pop, " log marginal posterior:", best,"\n") - cat("Report population:", rep.pop, " log marginal posterior:", reported,"\n") - } - }else - { - cat("\nBest log marginal posterior: ", best,"\n") +get.best.model <- function(result, labels = FALSE) { + if (is(result,"mjmcmc")) { + mod <- get.best.model.mjmcmc(result, labels) + attr(mod, which = "imputed") <- attr(result, which = "imputed") + return(mod) } - cat("\n") - feats.strings <- feats.strings[keep] - marg.probs <- marg.probs[1,keep] + if (is(result,"mjmcmc_parallel")) { + if (length(labels) == 1 && labels[1] == FALSE && length(result[[1]]$labels) > 0) { + labels <- result[[1]]$labels + } + best.chain <- which.max(sapply(result$chains, function (x) x$best.crit)) + mod <- get.best.model.mjmcmc(result$chains[[best.chain]], labels) + attr(mod, which = "imputed") <- attr(result, which = "imputed") + return(mod) + } - ord.marg <- order(marg.probs, decreasing = T) + if (is(result,"gmjmcmc")) { + mod <- get.best.model.gmjmcmc(result, labels) + attr(mod, which = "imputed") <- attr(result, which = "imputed") + return(mod) + } + if (is(result,"gmjmcmc_merged")) { + + if (length(labels) == 1 && labels[1] == FALSE && length(result$results.raw[[1]]$labels) > 0) { + labels <- result$results.raw[[1]]$labels + } + best.chain <- which.max(sapply(result$results, function(x) x$best)) + mod <- get.best.model.gmjmcmc(result$results.raw[[best.chain]], labels) + attr(mod, which = "imputed") <- attr(result, which = "imputed") + return(mod) + } +} + +get.best.model.gmjmcmc <- function (result, labels) { + transforms.bak <- set.transforms(result$transforms) + if (length(labels) == 1 && labels[1] == FALSE && length(result$labels) > 0) { + labels = result$labels + } - return(data.frame(feats.strings = feats.strings[ord.marg], marg.probs = marg.probs[ord.marg])) + best.pop.id <- which.max(sapply(result$best.margs,function(x)x)) + best.mod.id <- which.max(sapply(result$models[[best.pop.id]],function(x)x$crit)) + ret <- result$models[[best.pop.id]][[best.mod.id]] + ret$intercept <- result$intercept + ret$fixed <- result$fixed + coefnames <- sapply(result$populations[[best.pop.id]], print.feature, labels = labels)[ret$model] + if (result$intercept) coefnames <- c("Intercept", coefnames) + names(ret$coefs) <- coefnames + ret$needs.precalc <- FALSE + class(ret) = "bgnlm_model" + set.transforms(transforms.bak) + attr(ret, which = "imputed") <- attr(result, which = "imputed") + return(ret) +} + +get.best.model.mjmcmc <- function (result, labels) { + if (length(labels) == 1 && labels[1] == FALSE && length(result$labels) > 0 ) { + labels = result$labels + } + best.mod.id <- which.max(sapply(result$models,function(x)x$crit)) + ret <- result$models[[best.mod.id]] + coefnames <- sapply(result$populations, print.feature, labels = labels)[ret$model] + if (result$intercept) coefnames <- c("Intercept", coefnames) + names(ret$coefs) <- coefnames + ret$needs.precalc <- FALSE + class(ret) = "bgnlm_model" + return(ret) } -#' Function to get a character respresentation of a list of features -#' A list or a population of features in a character representation +#' Function to get a character representation of a list of features #' #' @param x A list of feature objects #' @param round Rounding precision for parameters of the features +#' +#' @return A matrix of character representations of the features of a model. +#' +#' @examples +#' result <- gmjmcmc(y = matrix(rnorm(100), 100), +#' x = matrix(rnorm(600), 100), +#' P = 2, +#' transforms = c("p0", "exp_dbl")) +#' string.population(result$populations[[1]]) +#' #' @export string.population <- function(x, round = 2) { cbind(sapply(x, print.feature, round = round)) } -#' Function to get a character respresentation of a list of models -#' A list of models in a character representation +#' Function to get a character representation of a list of models #' #' @param features A list of feature objects on which the models are build #' @param models A list of model objects #' @param round Rounding precision for parameters of the features #' @param link The link function to use, as a string +#' +#' @return A matrix of character representations of a list of models. +#' +#' @examples +#' result <- gmjmcmc(y = matrix(rnorm(100), 100), +#' x = matrix(rnorm(600), 100), +#' P = 2, +#' transforms = c("p0", "exp_dbl")) +#' string.population.models(result$populations[[2]], result$models[[2]]) +#' #' @export string.population.models <- function(features, models, round = 2, link = "I") { cbind(sapply(seq_along(models), FUN = function(x) model.string(features = features, model = (models[[x]]$model), round = round, link = "I"))) @@ -294,10 +523,30 @@ string.population.models <- function(features, models, round = 2, link = "I") { #' @param x The results to use #' @param count The number of features to plot, defaults to all #' @param pop The population to plot, defaults to last +#' @param tol The tolerance to use for the correlation when finding equivalent features, default is 0.0000001 +#' @param data Data to merge on, important if pre-filtering was used #' @param ... Not used. #' -#' @export -plot.gmjmcmc <- function (x, count = "all", pop = "last", ...) { +#' @return No return value, just creates a plot +#' +#' @examples +#' result <- gmjmcmc(y = matrix(rnorm(100), 100), +#' x = matrix(rnorm(600), 100), +#' P = 2, +#' transforms = c("p0", "exp_dbl")) +#' plot(result) +#' +#' +#' @export +plot.gmjmcmc <- function (x, count = "all", pop = "best", tol = 0.0000001, data = NULL, ...) { + transforms.bak <- set.transforms(x$transforms) + if (pop != "last") { + results <- list() + results[[1]] <- x + x <- merge_results(results, pop, 2, 0.0000001, data = data) + return(marg.prob.plot(sapply(x$features, print), x$marg.probs, count = count)) + } + if (pop == "last") pop <- length(x$populations) if (is.null(x$populations)) { pops <- x$features @@ -307,6 +556,8 @@ plot.gmjmcmc <- function (x, count = "all", pop = "last", ...) { marg.probs <- x$marg.probs[[pop]] } plot.mjmcmc(list(populations = pops, marg.probs = marg.probs), count) + set.transforms(transforms.bak) + return("done") } #' Function to plot the results, works both for results from gmjmcmc and @@ -316,8 +567,18 @@ plot.gmjmcmc <- function (x, count = "all", pop = "last", ...) { #' @param count The number of features to plot, defaults to all #' @param ... Not used. #' -#' @export +#' @return No return value, just creates a plot +#' +#' @examples +#' result <- mjmcmc( +#' y = matrix(rnorm(100), 100), +#' x = matrix(rnorm(600), 100), +#' loglik.pi = gaussian.loglik) +#' plot(result) +#' +#' @export plot.mjmcmc <- function (x, count = "all", ...) { + transforms.bak <- set.transforms(x$transforms) ## Get features as strings for printing and marginal posteriors # If this is a merged results the structure is one way if (is.null(x$populations)) { @@ -329,8 +590,10 @@ plot.mjmcmc <- function (x, count = "all", ...) { feats.strings <- sapply(x$populations, print) marg.probs <- x$marg.probs } - + marg.prob.plot(feats.strings, marg.probs, count) + set.transforms(transforms.bak) + return("done") } marg.prob.plot <- function (feats.strings, marg.probs, count = "all", ...) { @@ -338,28 +601,38 @@ marg.prob.plot <- function (feats.strings, marg.probs, count = "all", ...) { feats.strings <- feats.strings[order(marg.probs)] marg.probs <- sort(marg.probs) tot <- length(marg.probs) - if (count=="all") count <- tot - y <- barplot(marg.probs[(tot - count + 1):tot], horiz = T, xlab = "Marginal probability", ylab = "Feature") + if (count == "all") count <- tot + y <- barplot(marg.probs[(tot - count + 1):tot], horiz = TRUE, xlab = "Marginal probability", ylab = "Feature") text((max(marg.probs[(tot - count + 1):tot]) / 2), y, feats.strings[(tot - count + 1):tot]) } #' Plot a mjmcmc_parallel run #' @inheritParams plot.mjmcmc -#' @export +#' @return No return value, just creates a plot +#' +#' @examples +#' result <- mjmcmc.parallel(runs = 1, +#' cores = 1, +#' y = matrix(rnorm(100), 100), +#' x = matrix(rnorm(600), 100), +#' loglik.pi = gaussian.loglik) +#' plot(result) +#' +#' @export plot.mjmcmc_parallel <- function (x, count = "all", ...) { - merged <- merge.mjmcmc_parallel(x) + merged <- merge_mjmcmc_parallel(x) marg.prob.plot(merged$features, merged$marg.probs, count) } -merge.mjmcmc_parallel <- function (x) { +merge_mjmcmc_parallel <- function (x) { run.weights <- run.weigths(x) - marg.probs <- x[[1]]$marg.probs * run.weights[1] - for (i in seq_along(x[-1])) { - marg.probs <- marg.probs + x[[i]]$marg.probs * run.weights[i] + marg.probs <- x$chains[[1]]$marg.probs * run.weights[1] + for (i in seq_along(x[-c(1, (-1:0 + length(x)))])) { + marg.probs <- marg.probs + x$chains[[i]]$marg.probs * run.weights[i] } return(structure( list( - features = sapply(x[[1]]$populations, print), + features = sapply(x$chains[[1]]$populations, print), marg.probs = marg.probs, results = x ), @@ -367,15 +640,75 @@ merge.mjmcmc_parallel <- function (x) { )) } + run.weigths <- function (results) { - best.crits <- sapply(results, function (x) x$best.crit) + best.crits <- sapply(results$chains, function (x) x$best.crit) max.crit <- max(best.crits) return(exp(best.crits - max.crit) / sum(exp(best.crits - max.crit))) } #' Plot a gmjmcmc_merged run #' @inheritParams plot.gmjmcmc +#' @return No return value, just creates a plot +#' +#' @examples +#' result <- gmjmcmc.parallel( +#' runs = 1, +#' cores = 1, +#' y = matrix(rnorm(100), 100), +#' x = matrix(rnorm(600), 100), +#' P = 2, +#' transforms = c("p0", "exp_dbl") +#' ) +#' plot(result) +#' +#' @export +plot.gmjmcmc_merged <- function (x, count = "all", pop = NULL,tol = 0.0000001, data = NULL, ...) { + transforms.bak <- set.transforms(x$transforms) + if (!is.null(pop)) { + x <- merge_results(x$results.raw, pop, 2, 0.0000001, data = data) + } + + marg.prob.plot(sapply(x$features[x$marg.probs > tol], print), x$marg.probs[x$marg.probs > tol], count = count) + set.transforms(transforms.bak) + return("done") +} + + +#' Compute effects for specified in labels covariates using a fitted model. +#' +#' This function computes model averaged effects for specified covariates using a fitted model object. +#' The effects are expected change in the BMA linear predictor having an increase of the corresponding covariate by one unit, while other covariates are fixed to 0. +#' Users can provide custom labels and specify quantiles for the computation of effects. +#' +#' @param object A fitted model object, typically the result of a regression or predictive modeling. +#' @param labels A vector of labels for which effects are to be computed. +#' @param quantiles A numeric vector specifying the quantiles to be calculated. Default is c(0.025, 0.5, 0.975). +#' +#' @return A matrix of treatment effects for the specified labels, with rows corresponding to labels and columns to quantiles. +#' +#' @examples +#' +#' data <- data.frame(matrix(rnorm(600), 100)) +#' result <- mjmcmc.parallel(runs = 2, +#' cores = 1, +#' y = matrix(rnorm(100), 100), +#' x = data, +#' loglik.pi = gaussian.loglik) +#' compute_effects(result,labels = names(data)) +#' +#' @seealso \code{\link{predict}} #' @export -plot.gmjmcmc_merged <- function (x, count = "all", ...) { - marg.prob.plot(sapply(x$features, print), x$marg.probs, count = count) +compute_effects <- function(object, labels, quantiles = c(0.025, 0.5, 0.975)) { + effects <- rbind(0, diag(length(labels))) + preds.eff <- predict(object = object, x = as.matrix(effects), quantiles = quantiles) + if (length(preds.eff$aggr) > 0) + preds.eff <- t(preds.eff$aggr$quantiles) + else + preds.eff <- t(preds.eff$quantiles) + preds.eff[2:(length(labels) + 1), ] <- preds.eff[2:(length(labels) + 1), ] - preds.eff[1, ] + + summ <- data.frame(cbind(c("intercept", labels), round(preds.eff, 4))) + names(summ) <- c("Covariate", paste0("quant_", quantiles)) + return(summ) } diff --git a/R/sanger-data.R b/R/sanger-data.R new file mode 100644 index 0000000000000000000000000000000000000000..3d29af7d2164421a5b9b045d42b344107072005b --- /dev/null +++ b/R/sanger-data.R @@ -0,0 +1,27 @@ +#' Gene expression data lymphoblastoid cell lines of all 210 unrelated HapMap +#' individuals from four populations +#' +#' A 210 times 3221 matrix with indviduals along the rows and expression data along the columns +#' +#' The first column corresponds to column number 24266 (with name GI_6005726-S) in the original data. +#' Column names give the name of the variables, row names the "name" of the individuals. +#' This is a subset of SangerData where the 3220 last rows are select among all original rows following the same +#' pre-processing procedure as in (section 1.6.1). See also the file Read_sanger_data.R +#' +#' +#' @docType data +#' @keywords datasets +#' @name SangerData2 +#' @usage data(SangerData2) +#' @format A data frame with 210 rows and 3221 variables +#' @source Dataset downloaded from +#' \url{https://ftp.sanger.ac.uk/pub/genevar/} +#' +#' References: +#' +#' Stranger, BE et al (2007): Relative impact of nucleotide and copy number variation on gene expression phenotypes +#' Science, 2007•science.org +#' +#' Bogdan et al (2020): Handbook of Multiple Comparisons, \url{https://arxiv.org/pdf/2011.12154} +#' +NULL \ No newline at end of file diff --git a/R/summary.R b/R/summary.R new file mode 100644 index 0000000000000000000000000000000000000000..2dbfff174f39fc5aa85252bf97aee182ebe8d22e --- /dev/null +++ b/R/summary.R @@ -0,0 +1,239 @@ +#' Function to print a quick summary of the results +#' +#' @param object The results to use +#' @param pop The population to print for, defaults to last +#' @param tol The tolerance to use as a threshold when reporting the results. +#' @param labels Should the covariates be named, or just referred to as their place in the data.frame. +#' @param effects Quantiles for posterior modes of the effects across models to be reported, if either effects are NULL or if labels are NULL, no effects are reported. +#' @param data Data to merge on, important if pre-filtering was used +#' @param verbose If the summary should be printed to the console or just returned, defaults to TRUE +#' @param ... Not used. +#' +#' @return A data frame containing the following columns: +#' \item{feats.strings}{Character representation of the features ordered by marginal probabilities.} +#' \item{marg.probs}{Marginal probabilities corresponding to the ordered feature strings.} +#' +#' @examples +#' result <- gmjmcmc(y = matrix(rnorm(100), 100), +#' x = matrix(rnorm(600), 100), +#' P = 2, +#' transforms = c("p0", "exp_dbl")) +#' summary(result, pop = "best") +#' +#' @export +summary.gmjmcmc <- function (object, pop = "best", tol = 0.0001, labels = FALSE, effects = NULL, data = NULL, verbose = TRUE, ...) { + transforms.bak <- set.transforms(object$transforms) + if (length(labels) == 1 && labels[1] == FALSE && length(object$labels) > 0) { + labels = object$labels + } + if (pop == "all") { + results <- list() + results[[1]] <- object + merged <- merge_results(results, pop, 2, 0.0000001, data = data) + + best <- max(sapply(merged$results, function (y) y$best)) + feats.strings <- sapply(merged$features, FUN = function(x) print.feature(x = x, labels = labels, round = 2)) + + if (!is.null(effects) & !is.null(labels)) { + effects <- compute_effects(merged,labels = labels, quantiles = effects) + } + + return(summary_internal( + best = merged$crit.best, + feats.strings, + merged$marg.probs, + effects = effects, + best.pop = merged$pop.best, + thread.best = merged$thread.best, + reported = merged$reported, + rep.pop = merged$rep.pop, + rep.thread = merged$rep.thread, + tol = tol, + verbose = verbose + )) + } + + if (pop == "last") pop <- length(object$models) + else if (pop == "best") pop <- which.max(unlist(object$best.margs)) + feats.strings <- sapply(object$populations[[pop]], FUN = function(x) print.feature(x = x, labels = labels, round = 2)) + + if (!is.null(effects) & !is.null(labels)) { + effects <- compute_effects(object, labels = labels, quantiles = effects) + } + + obj <- summary_internal( + best = object$best, + marg.probs = object$marg.probs[[pop]], + effects = effects, + feats.strings = feats.strings, + best.pop = which.max(unlist(object$best.margs)), + reported = object$best.margs[[pop]], + rep.pop = pop, + tol = tol, + verbose = verbose + ) + set.transforms(transforms.bak) + return(obj) +} + + +#' Function to print a quick summary of the results +#' +#' @param object The results to use +#' @param tol The tolerance to use as a threshold when reporting the results. +#' @param labels Should the covariates be named, or just referred to as their place in the data.frame. +#' @param effects Quantiles for posterior modes of the effects across models to be reported, if either effects are NULL or if labels are NULL, no effects are reported. +#' @param pop If null same as in merge.options for running parallel gmjmcmc otherwise results will be re-merged according to pop that can be "all", "last", "best" +#' @param data Data to merge on, important if pre-filtering was used +#' @param verbose If the summary should be printed to the console or just returned, defaults to TRUE +#' @param ... Not used. +#' +#' @return A data frame containing the following columns: +#' \item{feats.strings}{Character representation of the features ordered by marginal probabilities.} +#' \item{marg.probs}{Marginal probabilities corresponding to the ordered feature strings.} +#' +#' @examples +#' result <- gmjmcmc.parallel( +#' runs = 1, +#' cores = 1, +#' y = matrix(rnorm(100), 100), +#' x = matrix(rnorm(600), 100), +#' P = 2, +#' transforms = c("p0", "exp_dbl") +#' ) +#' summary(result) +#' +#' @export +summary.gmjmcmc_merged <- function (object, tol = 0.0001, labels = FALSE, effects = NULL, pop = NULL, data = NULL, verbose = TRUE, ...) { + transforms.bak <- set.transforms(object$transforms) + if (length(labels) == 1 && labels[1] == FALSE && length(object$results.raw[[1]]$labels) > 0) { + labels = object$results.raw[[1]]$labels + } + if (!is.null(pop)) { + object <- merge_results(object$results.raw, populations = pop, complex.measure = 2, tol = 0.0000001, data = data) + } + + best <- max(sapply(object$results, function (y) y$best)) + feats.strings <- sapply(object$features, FUN = function(x) print.feature(x = x, labels = labels, round = 2)) + + if (!is.null(effects) & !is.null(labels)) { + effects <- compute_effects(object,labels = labels, quantiles = effects) + } + + obj <- summary_internal( + best = object$crit.best, + feats.strings = feats.strings, + marg.probs = object$marg.probs, + effects = effects, + best.pop = object$pop.best, + thread.best = object$thread.best, + reported = object$reported, + rep.pop = object$rep.pop, + rep.thread = object$rep.thread, + tol = tol, + verbose = verbose + ) + set.transforms(transforms.bak) + return(obj) +} + +#' Function to print a quick summary of the results +#' +#' @param object The results to use +#' @param tol The tolerance to use as a threshold when reporting the results. +#' @param labels Should the covariates be named, or just referred to as their place in the data.frame. +#' @param effects Quantiles for posterior modes of the effects across models to be reported, if either effects are NULL or if labels are NULL, no effects are reported. +#' @param verbose If the summary should be printed to the console or just returned, defaults to TRUE +#' @param ... Not used. +#' +#' @return A data frame containing the following columns: +#' \item{feats.strings}{Character representation of the covariates ordered by marginal probabilities.} +#' \item{marg.probs}{Marginal probabilities corresponding to the ordered feature strings.} +#' +#' @examples +#' result <- mjmcmc(y = matrix(rnorm(100), 100), +#' x = matrix(rnorm(600), 100), +#' loglik.pi = gaussian.loglik) +#' summary(result) +#' +#' @export +summary.mjmcmc <- function (object, tol = 0.0001, labels = FALSE, effects = NULL, verbose = TRUE, ...) { + return(summary.mjmcmc_parallel( + list(chains = list(object), fixed = object$fixed, intercept = object$intercept), + tol = tol, + labels = labels, + effects = effects, + verbose = verbose + )) +} + +#' Function to print a quick summary of the results +#' +#' @param object The results to use +#' @param tol The tolerance to use as a threshold when reporting the results. +#' @param labels Should the covariates be named, or just referred to as their place in the data.frame. +#' @param effects Quantiles for posterior modes of the effects across models to be reported, if either effects are NULL or if labels are NULL, no effects are reported. +#' @param verbose If the summary should be printed to the console or just returned, defaults to TRUE +#' @param ... Not used. +#' +#' @return A data frame containing the following columns: +#' \item{feats.strings}{Character representation of the covariates ordered by marginal probabilities.} +#' \item{marg.probs}{Marginal probabilities corresponding to the ordered feature strings.} +#' +#' @examples +#' result <- mjmcmc.parallel(runs = 1, +#' cores = 1, +#' y = matrix(rnorm(100), 100), +#' x = matrix(rnorm(600), 100), +#' loglik.pi = gaussian.loglik) +#' summary(result) +#' +#' @export +summary.mjmcmc_parallel <- function (object, tol = 0.0001, labels = FALSE, effects = NULL, verbose = TRUE, ...) { + # Get features as strings for printing + if (length(labels) == 1 && labels[1] == FALSE && length(object$chains[[1]]$labels) > 0) { + labels = object$chains[[1]]$labels + } + feats.strings <- sapply(object$chains[[1]]$populations, FUN = function(x) print.feature(x = x, labels = labels, round = 2)) + # Get marginal posterior of features + + models <- unlist(lapply(object$chains, function (x) x$models), recursive = FALSE) + marg.probs <- marginal.probs.renorm(models)$probs + best <- max(sapply(object$chains, function (x) x$best)) + if (!is.null(effects) & !is.null(labels)) { + effects <- compute_effects(object$chains[[1]], labels = labels, quantiles = effects) + } + return(summary_internal(best, feats.strings, marg.probs, effects, tol = tol, verbose = verbose)) +} + +summary_internal <- function (best, feats.strings, marg.probs, effects = NULL, tol = 0.0001, best.pop = NULL, reported = NULL, rep.pop = NULL, rep.thread = NULL, thread.best = NULL, verbose = TRUE) { + keep <- which(marg.probs[1, ] > tol) + + if (verbose) { + # Print the best log marginal posterior + if (length(best.pop) > 0) { + if (length(thread.best) > 0) { + cat("\nBest population:", best.pop, " thread:", thread.best, " log marginal posterior:", best,"\n") + if(best.pop!=rep.pop) + cat("Report population:", rep.pop, " thread:", rep.thread, " log marginal posterior:", reported,"\n") + } else { + cat("\nBest population:", best.pop, " log marginal posterior:", best,"\n") + if(best.pop!=rep.pop) + cat("Report population:", rep.pop, " log marginal posterior:", reported,"\n") + } + } else { + cat("\nBest log marginal posterior: ", best,"\n") + } + cat("\n") + } + + feats.strings <- feats.strings[keep] + marg.probs <- marg.probs[1, keep] + ord.marg <- order(marg.probs, decreasing = TRUE) + + if (!is.null(effects)) { + return(list(PIP = data.frame(feats.strings = feats.strings[ord.marg], marg.probs = marg.probs[ord.marg]), EFF = effects)) + } + + return(data.frame(feats.strings = feats.strings[ord.marg], marg.probs = marg.probs[ord.marg])) +} diff --git a/README.md b/README.md index d5f8ab7f75b0e1fbc0cc694430288e2bb2b76840..362a8358326c8a94eca17158f9d12e61621997f7 100644 --- a/README.md +++ b/README.md @@ -1,15 +1,22 @@ -# GMJMCMC +[![](https://img.shields.io/badge/lifecycle-experimental-orange.svg)](https://lifecycle.r-lib.org/articles/stages.html#experimental) +[![](https://img.shields.io/github/last-commit/jonlachmann/GMJMCMC.svg)](https://github.com/jonlachmann/GMJMCMC/commits/data-inputs) +[![](https://img.shields.io/github/languages/code-size/jonlachmann/GMJMCMC.svg)](https://github.com/jonlachmann/GMJMCMC) +[![R build status](https://github.com/jonlachmann/GMJMCMC/workflows/R-CMD-check/badge.svg)](https://github.com/jonlachmann/GMJMCMC/actions) +[![codecov](https://codecov.io/gh/jonlachmann/GMJMCMC/branch/data-inputs/graph/badge.svg)](https://codecov.io/gh/jonlachmann/GMJMCMC) +[![License: GPL](https://img.shields.io/badge/license-GPL-blue.svg)](https://cran.r-project.org/web/licenses/GPL) -The `GMJMCMC` package provides functions to estimate Bayesian Generalized nonlinear models (BGNLMs) through a Genetically Modified Mode Jumping MCMC algorithm. +# FBMS - Flexible Bayesian Model Selection + +The `FBMS` package provides functions to estimate Bayesian Generalized nonlinear models (BGNLMs) through a Genetically Modified Mode Jumping MCMC algorithm. # Installation and getting started -To install and load the package, just run +To install and load the development version of the package, just run ``` library(devtools) -install_github("jonlachmann/GMJMCMC", force=T, build_vignettes=T) -library(GMJMCMC) +install_github("jonlachmann/GMJMCMC@data-inputs", force=T, build_vignettes=T) +library(FBMS) ``` With the package loaded, a vignette that shows how to run the package is available by running ``` -vignette("GMJMCMC-guide") +vignette("FBMS-guide") ``` diff --git a/data/SangerData2.rda b/data/SangerData2.rda new file mode 100644 index 0000000000000000000000000000000000000000..f72f1e53c763fef3b8ee440e43a16821a609d7b3 Binary files /dev/null and b/data/SangerData2.rda differ diff --git a/data/abalone.rda b/data/abalone.rda new file mode 100644 index 0000000000000000000000000000000000000000..9d8706962c907dc9c9ee27f506360a33b989fa5b Binary files /dev/null and b/data/abalone.rda differ diff --git a/data/exoplanet.RData b/data/exoplanet.RData deleted file mode 100644 index 61e57f59b42321a44afa9e85da0978deb8db4a46..0000000000000000000000000000000000000000 Binary files a/data/exoplanet.RData and /dev/null differ diff --git a/data/exoplanet.rda b/data/exoplanet.rda new file mode 100644 index 0000000000000000000000000000000000000000..d43b20e3c036c346cba3e95ea49658d1b0b3a010 Binary files /dev/null and b/data/exoplanet.rda differ diff --git a/man/FBMS-package.Rd b/man/FBMS-package.Rd new file mode 100644 index 0000000000000000000000000000000000000000..a13ef62c81443d53af07b4b0b50561839f94e8b5 --- /dev/null +++ b/man/FBMS-package.Rd @@ -0,0 +1,45 @@ +\docType{package} + +\name{FBMS-package} +\alias{FBMS-package} +\alias{FBMS} + +\title{ +\packageTitle{FBMS} +} +\description{ +\packageDescription{FBMS} +} +\author{ + \strong{Maintainer}: Jon Lachmann \email{jon@lachmann.nu} + + Authors: + \itemize{ + \item Jon Lachmann \email{jon@lachmann.nu} + \item Aliaksandr Hubin \email{aliaksah@math.uio.no} + } + + Other contributors: + \itemize{ + \item Florian Frommlet \email{florian.frommlet@meduniwien.ac.at} [contributor] + \item Geir Storvik \email{geirs@math.uio.no} [contributor] + } +} + +\references{ + Lachmann, J., Storvik, G., Frommlet, F., & Hubin, A. (2022). + A subsampling approach for Bayesian model selection. + International Journal of Approximate Reasoning, 151, 33-63. Elsevier. + + Hubin, A., Storvik, G., & Frommlet, F. (2021). + Flexible Bayesian Nonlinear Model Configuration. + Journal of Artificial Intelligence Research, 72, 901-942. + + Hubin, A., Frommlet, F., & Storvik, G. (2021). + Reversible Genetically Modified MJMCMC. + Under review in EYSM 2021. + + Hubin, A., & Storvik, G. (2018). + Mode jumping MCMC for Bayesian variable selection in GLMM. + Computational Statistics & Data Analysis, 127, 281-297. Elsevier. +} diff --git a/man/GMJMCMC-package.Rd b/man/GMJMCMC-package.Rd deleted file mode 100644 index e57491584d3eceba201b9ea508e6a61cdf449b8a..0000000000000000000000000000000000000000 --- a/man/GMJMCMC-package.Rd +++ /dev/null @@ -1,31 +0,0 @@ -\name{GMJMCMC-package} -\alias{GMJMCMC-package} -\alias{GMJMCMC} -\docType{package} -\title{ -\packageTitle{GMJMCMC} -} -\description{ -\packageDescription{GMJMCMC} -} -\details{ - -The DESCRIPTION file: -\packageDESCRIPTION{GMJMCMC} -\packageIndices{GMJMCMC} - -} -\author{ -\packageAuthor{GMJMCMC} - -Maintainer: \packageMaintainer{GMJMCMC} -} -\references{ - -} -\keyword{ package } -\seealso{ -} -\examples{ -# simple examples of the most important functions -} diff --git a/man/SangerData2.Rd b/man/SangerData2.Rd new file mode 100644 index 0000000000000000000000000000000000000000..ffc57a056b5180a4cd39aec4bd41f47a7a1b45f2 --- /dev/null +++ b/man/SangerData2.Rd @@ -0,0 +1,34 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/sanger-data.R +\docType{data} +\name{SangerData2} +\alias{SangerData2} +\title{Gene expression data lymphoblastoid cell lines of all 210 unrelated HapMap +individuals from four populations} +\format{ +A data frame with 210 rows and 3221 variables +} +\source{ +Dataset downloaded from +\url{https://ftp.sanger.ac.uk/pub/genevar/} + +References: + +Stranger, BE et al (2007): Relative impact of nucleotide and copy number variation on gene expression phenotypes +Science, 2007•science.org + +Bogdan et al (2020): Handbook of Multiple Comparisons, \url{https://arxiv.org/pdf/2011.12154} +} +\usage{ +data(SangerData2) +} +\description{ +A 210 times 3221 matrix with indviduals along the rows and expression data along the columns +} +\details{ +The first column corresponds to column number 24266 (with name GI_6005726-S) in the original data. +Column names give the name of the variables, row names the "name" of the individuals. +This is a subset of SangerData where the 3220 last rows are select among all original rows following the same +pre-processing procedure as in (section 1.6.1). See also the file Read_sanger_data.R +} +\keyword{datasets} diff --git a/man/abalone.Rd b/man/abalone.Rd new file mode 100644 index 0000000000000000000000000000000000000000..c056c94147d064974232956da637fb9e65020543 --- /dev/null +++ b/man/abalone.Rd @@ -0,0 +1,38 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/abalone-data.R +\docType{data} +\name{abalone} +\alias{abalone} +\title{Physical measurements of 4177 abalones, a species of sea snail.} +\format{ +A data frame with 4177 observations on the following 9 variables. +\describe{ +\item{Diameter}{Diameter Perpendicular to length, continuous} +\item{Height}{Height with with meat in shell, continuous.} +\item{Length}{Longest shell measurement, continuous} +\item{Rings}{+1.5 gives the age in years, integer} +\item{Sex}{Sex of the abalone, \code{F} is female, \code{M} male, and \code{I} infant, categorical.} +\item{Weight_S}{Grams after being dried, continuous.} +\item{Weight_Sh}{Grams weight of meat, continuous.} +\item{Weight_V}{Grams gut weight (after bleeding), continuous.} +\item{Weight_W}{Grams whole abalone, continuous.} } +} +\source{ +Dua, D. and Graff, C. (2019). UCI Machine Learning Repository +\url{https://archive.ics.uci.edu/ml/}. Irvine, CA: University of California, +School of Information and Computer Science. +} +\description{ +\%\% ~~ A concise (1-5 lines) description of the dataset. ~~ +} +\details{ +See the web page \url{https://archive.ics.uci.edu/ml/datasets/Abalone} for +more information about the data set. +} +\examples{ + +data(abalone) +## maybe str(abalone) ; plot(abalone) ... + +} +\keyword{datasets} diff --git a/man/alpha_1.Rd b/man/alpha_1.Rd deleted file mode 100644 index 600c71c921caa20c428d8a1e07b980e63568659d..0000000000000000000000000000000000000000 --- a/man/alpha_1.Rd +++ /dev/null @@ -1,16 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/alpha_generation.R -\name{alpha_1} -\alias{alpha_1} -\title{Alpha generator using strategy 1 as per Hubin et. al. -TODO: This is just a placeholder.} -\usage{ -alpha_1(feature) -} -\arguments{ -\item{feature}{The feature to generate alphas for} -} -\description{ -Alpha generator using strategy 1 as per Hubin et. al. -TODO: This is just a placeholder. -} diff --git a/man/alpha_2.Rd b/man/alpha_2.Rd deleted file mode 100644 index 0d3ef93e45684a127d4f03c8d8bc5f0fed426c75..0000000000000000000000000000000000000000 --- a/man/alpha_2.Rd +++ /dev/null @@ -1,16 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/alpha_generation.R -\name{alpha_2} -\alias{alpha_2} -\title{Alpha generator using strategy 2 as per Hubin et. al. -TODO: This is just a placeholder.} -\usage{ -alpha_2(feature) -} -\arguments{ -\item{feature}{The feature to generate alphas for} -} -\description{ -Alpha generator using strategy 2 as per Hubin et. al. -TODO: This is just a placeholder. -} diff --git a/man/alpha_3.Rd b/man/alpha_3.Rd deleted file mode 100644 index d063d8bf479bf0528e03548fc9912dcc555c6454..0000000000000000000000000000000000000000 --- a/man/alpha_3.Rd +++ /dev/null @@ -1,18 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/alpha_generation.R -\name{alpha_3} -\alias{alpha_3} -\title{Alpha generator using strategy 3 as per Hubin et. al.} -\usage{ -alpha_3(feature, data, loglik) -} -\arguments{ -\item{feature}{The feature to generate alphas for} - -\item{data}{The dataset used} - -\item{loglik}{log likelihood function to use} -} -\description{ -Alpha generator using strategy 3 as per Hubin et. al. -} diff --git a/man/to35.Rd b/man/arcsinh.Rd similarity index 59% rename from man/to35.Rd rename to man/arcsinh.Rd index a4d8ce0ff34288af05d5fb5917a1d1be7b7c9665..4f8f173887bf8209e1594591555b783c221d4b8f 100644 --- a/man/to35.Rd +++ b/man/arcsinh.Rd @@ -1,17 +1,21 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/nonlinear_functions.R -\name{to35} -\alias{to35} -\title{To 3.5 power} +\name{arcsinh} +\alias{arcsinh} +\title{arcsinh transform} \usage{ -to35(x) +arcsinh(x) } \arguments{ \item{x}{The vector of values} } \value{ -x^(3.5) +arcsinh(x) } \description{ -To 3.5 power +arcsinh transform +} +\examples{ +arcsinh(2) + } diff --git a/man/compute_effects.Rd b/man/compute_effects.Rd new file mode 100644 index 0000000000000000000000000000000000000000..5212b266afe24ceeb6246e27bb2420f9cfd080b2 --- /dev/null +++ b/man/compute_effects.Rd @@ -0,0 +1,37 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/results.R +\name{compute_effects} +\alias{compute_effects} +\title{Compute effects for specified in labels covariates using a fitted model.} +\usage{ +compute_effects(object, labels, quantiles = c(0.025, 0.5, 0.975)) +} +\arguments{ +\item{object}{A fitted model object, typically the result of a regression or predictive modeling.} + +\item{labels}{A vector of labels for which effects are to be computed.} + +\item{quantiles}{A numeric vector specifying the quantiles to be calculated. Default is c(0.025, 0.5, 0.975).} +} +\value{ +A matrix of treatment effects for the specified labels, with rows corresponding to labels and columns to quantiles. +} +\description{ +This function computes model averaged effects for specified covariates using a fitted model object. +The effects are expected change in the BMA linear predictor having an increase of the corresponding covariate by one unit, while other covariates are fixed to 0. +Users can provide custom labels and specify quantiles for the computation of effects. +} +\examples{ + +data <- data.frame(matrix(rnorm(600), 100)) +result <- mjmcmc.parallel(runs = 2, +cores = 1, +y = matrix(rnorm(100), 100), +x = data, +loglik.pi = gaussian.loglik) +compute_effects(result,labels = names(data)) + +} +\seealso{ +\code{\link{predict}} +} diff --git a/man/cos.rad.Rd b/man/cos_deg.Rd similarity index 80% rename from man/cos.rad.Rd rename to man/cos_deg.Rd index 3d69cbbcf7451f6dc30cf2d222e9253638c3156c..5daa57dae5d9aaf56f439fe17e63675e479e0688 100644 --- a/man/cos.rad.Rd +++ b/man/cos_deg.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/nonlinear_functions.R -\name{cos.rad} -\alias{cos.rad} +\name{cos_deg} +\alias{cos_deg} \title{Cosine function for degrees} \usage{ -\method{cos}{rad}(x) +cos_deg(x) } \arguments{ \item{x}{The vector of values in degrees} @@ -15,3 +15,7 @@ The cosine of x \description{ Cosine function for degrees } +\examples{ +cos_deg(0) + +} diff --git a/man/create.feature.Rd b/man/create.feature.Rd deleted file mode 100644 index 85a657d5398dd32dda7e8d91f0829690626eab22..0000000000000000000000000000000000000000 --- a/man/create.feature.Rd +++ /dev/null @@ -1,20 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/feature.R -\name{create.feature} -\alias{create.feature} -\title{Create method for "feature" class} -\usage{ -create.feature(transform, features, trans.priors, alphas = NULL) -} -\arguments{ -\item{transform}{A numeric denoting the transform type} - -\item{features}{A list of features to include} - -\item{trans.priors}{A vector of prior inclusion penalties for the different transformations.} - -\item{alphas}{A numeric vector denoting the alphas to use} -} -\description{ -Create method for "feature" class -} diff --git a/man/diagn_plot.Rd b/man/diagn_plot.Rd new file mode 100644 index 0000000000000000000000000000000000000000..05904f62de80392d08dd7f9bcda2be6861856b63 --- /dev/null +++ b/man/diagn_plot.Rd @@ -0,0 +1,45 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/diagnostics.R +\name{diagn_plot} +\alias{diagn_plot} +\title{Plot convergence of best/median/mean/other summary log posteriors in time} +\usage{ +diagn_plot( + res, + FUN = median, + conf = 0.95, + burnin = 0, + window = 5, + ylim = NULL, + ... +) +} +\arguments{ +\item{res}{Object corresponding gmjmcmc output} + +\item{FUN}{The summary statistics to check convergence} + +\item{conf}{Which confidence intervals to plot} + +\item{burnin}{How many first populations to skip} + +\item{window}{Sliding window for computing the standard deviation} + +\item{ylim}{Limits for the plotting range; if unspecified, min and max of confidence intervals will be used} + +\item{...}{Additional graphical parameters passed to plot and lines functions, e.g. col, lwd, lty, main, xlab, ylab, ylim} +} +\value{ +A list of summary statistics for checking convergence with given confidence intervals +} +\description{ +Plot convergence of best/median/mean/other summary log posteriors in time +} +\examples{ +result <- gmjmcmc(y = matrix(rnorm(100), 100), + x = matrix(rnorm(600), 100), + P = 2, + transforms = c("p0", "exp_dbl")) +diagnstats <- diagn_plot(result) + +} diff --git a/man/erf.Rd b/man/erf.Rd index dd8c854f2210ec70bdb5f98db341cfe3e6103929..da0488e8f71260e574d0d4f23be25618a4a97e03 100644 --- a/man/erf.Rd +++ b/man/erf.Rd @@ -15,3 +15,7 @@ erf(x) \description{ erf function } +\examples{ +erf(2) + +} diff --git a/man/exoplanet.Rd b/man/exoplanet.Rd index 6deb963746fc6ecab0f14fd9671866e7a5613d7b..45dd4a7eee6ac07afbc57fae5a2f264250811149 100644 --- a/man/exoplanet.Rd +++ b/man/exoplanet.Rd @@ -29,17 +29,16 @@ Data fields include planet and host star attributes. The variables are as follows: \itemize{ -\item TypeFlag: Flag indicating the type of data -\item PlanetaryMassJpt: Mass of the planetary object in Jupiter masses -\item RadiusJpt: Radius of the planetary object in Jupiter radii -\item PeriodDays: Orbital period of the planetary object in days -\item SemiMajorAxisAU: Semi-major axis of the planetary object's orbit in astronomical units -\item Eccentricity: Eccentricity of the planetary object's orbit -\item HostStarMassSlrMass: Mass of the host star in solar masses -\item HostStarRadiusSlrRad: Radius of the host star in solar radii -\item HostStarMetallicity: Metallicity of the host star -\item HostStarTempK: Effective temperature of the host star in Kelvin -\item PlanetaryDensJpt: Density of the planetary object up to a constant +\item semimajoraxis: Semi-major axis of the planetary object's orbit in astronomical units +\item mass: Mass of the planetary object in Jupiter masses +\item radius: Radius of the planetary object in Jupiter radii +\item period: Orbital period of the planetary object in days +\item eccentricity: Eccentricity of the planetary object's orbit +\item hoststar_mass: Mass of the host star in solar masses +\item hoststar_radius: Radius of the host star in solar radii +\item hoststar_metallicity: Metallicity of the host star +\item hoststar_temperature: Effective temperature of the host star in Kelvin +\item binaryflag: Flag indicating the type of planetary system } } \keyword{datasets} diff --git a/man/exp.dbl.Rd b/man/exp_dbl.Rd similarity index 79% rename from man/exp.dbl.Rd rename to man/exp_dbl.Rd index 2b8e1e24943f31edc615f1f0b0ec882868783c7d..62ee81162a5eb1f2accdc89c2bde7b28a07e249b 100644 --- a/man/exp.dbl.Rd +++ b/man/exp_dbl.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/nonlinear_functions.R -\name{exp.dbl} -\alias{exp.dbl} +\name{exp_dbl} +\alias{exp_dbl} \title{Double exponential function} \usage{ -\method{exp}{dbl}(x) +exp_dbl(x) } \arguments{ \item{x}{The vector of values} @@ -15,3 +15,7 @@ e^(-abs(x)) \description{ Double exponential function } +\examples{ +exp_dbl(2) + +} diff --git a/man/fbms.Rd b/man/fbms.Rd new file mode 100644 index 0000000000000000000000000000000000000000..6a861ed944943b6702eee0c517a792e7dbd76583 --- /dev/null +++ b/man/fbms.Rd @@ -0,0 +1,100 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fbms.R +\name{fbms} +\alias{fbms} +\title{Fit a BGNLM model using Genetically Modified Mode Jumping Markov Chain Monte Carlo (MCMC) sampling. +Or Fit a BGLM model using Modified Mode Jumping Markov Chain Monte Carlo (MCMC) sampling.} +\usage{ +fbms( + formula = NULL, + family = "gaussian", + beta_prior = list(type = "g-prior"), + model_prior = NULL, + extra_params = NULL, + data = NULL, + impute = FALSE, + loglik.pi = NULL, + method = "mjmcmc", + verbose = TRUE, + ... +) +} +\arguments{ +\item{formula}{A formula object specifying the model structure. Default is NULL.} + +\item{family}{The distribution family of the response variable. Currently supports "gaussian", "binomial", "poisson", "gamma", and "custom". Default is "gaussian".} + +\item{beta_prior}{Type of prior as a string (default: "g-prior" with a = max(n, p^2)). Possible values include: +- "beta.prime": Beta-prime prior (GLM/Gaussian, no additional args) +- "CH": Compound Hypergeometric prior (GLM/Gaussian, requires \code{a}, \code{b}, optionally \code{s}) +- "EB-local": Empirical Bayes local prior (GLM/Gaussian, requires \code{a} for Gaussian) +- "EB-global": Empirical Bayes local prior (Gaussian, requires \code{a} for Gaussian) +- "g-prior": Zellner's g-prior (GLM/Gaussian, requires \code{g}) +- "hyper-g": Hyper-g prior (GLM/Gaussian, requires \code{a}) +- "hyper-g-n": Hyper-g/n prior (GLM/Gaussian, requires \code{a}) +- "tCCH": Truncated Compound Hypergeometric prior (GLM/Gaussian, requires \code{a}, \code{b}, \code{s}, \code{rho}, \code{v}, \code{k}) +- "intrinsic": Intrinsic prior (GLM/Gaussian, no additional args) +- "TG": Truncated Gamma prior (GLM/Gamma, requires \code{a}, \code{s}) +- "Jeffreys": Jeffreys prior (GLM/Gaussian, no additional args) +- "uniform": Uniform prior (GLM/Gaussian, no additional args) +- "benchmark": Benchmark prior (Gaussian/GLM, no additional args) +- "ZS-adapted": Zellner-Siow adapted prior (Gaussian TCCH, no additional args) +- "robust": Robust prior (Gaussian/GLM, no additional args) +- "Jeffreys-BIC": Jeffreys prior with BIC approximation of marginal likelihood (Gaussian/GLM) +- "ZS-null": Zellner-Siow null prior (Gaussian, requires \code{a}) +- "ZS-full": Zellner-Siow full prior (Gaussian, requires \code{a}) +- "hyper-g-laplace": Hyper-g Laplace prior (Gaussian, requires \code{a}) +- "AIC": AIC prior from BAS (Gaussian, requires penalty \code{a}) +- "BIC": BIC prior from BAS (Gaussian/GLM) +- "JZS": Jeffreys-Zellner-Siow prior (Gaussian, requires \code{a}) +\itemize{ +\item r: Model complexity penalty (default: 1/n) +\item g: Tuning parameter for g-prior (default: max(n, p^2)) +\item a, b, s, v, rho, k: Hyperparameters for various priors +\item n: Sample size for some priors (default: length(y)) +\item var: Variance assumption for Gaussian models ("known" or "unknown", default: "unknown") +\item laplace: Logical for Laplace approximation in GLM only (default: FALSE) +}} + +\item{model_prior}{a list with parameters of model priors, by default r should be provided} + +\item{extra_params}{extra parameters to be passed to the loglik.pi function} + +\item{data}{A data frame or matrix containing the data to be used for model fitting. If the outcome variable is in the first column of the data frame, the formula argument in fbms can be omitted, provided that all other columns are intended to serve as input covariates.} + +\item{impute}{TRUE means imputation combined with adding a dummy column with indicators of imputed values, FALSE (default) means only full data is used.} + +\item{loglik.pi}{Custom function to compute the logarithm of the posterior mode based on logarithm of marginal likelihood and logarithm of prior functions (needs specification only used if family = "custom")} + +\item{method}{Which fitting algorithm should be used, currently implemented options include "gmjmcmc", "gmjmcmc.parallel", "mjmcmc" and "mjmcmc.parallel" with "mjmcmc" being the default and 'mjmcmc' means that only linear models will be estimated} + +\item{verbose}{If TRUE, print detailed progress information during the fitting process. Default is TRUE.} + +\item{...}{Additional parameters to be passed to the underlying method.} +} +\value{ +An object containing the results of the fitted model and MCMC sampling. +} +\description{ +This function fits a model using the relevant MCMC sampling. The user can specify the formula, +family, data, transforms, and other parameters to customize the model. +} +\examples{ +# Fit a Gaussian multivariate time series model +fbms_result <- fbms( + X1 ~ ., + family = "gaussian", + method = "gmjmcmc.parallel", + data = data.frame(matrix(rnorm(600), 100)), + transforms = c("sin","cos"), + P = 10, + runs = 1, + cores = 1 +) +summary(fbms_result) + + +} +\seealso{ +\code{\link{mjmcmc}}, \code{\link{gmjmcmc}}, \code{\link{gmjmcmc.parallel}} +} diff --git a/man/fbms.mlik.master.Rd b/man/fbms.mlik.master.Rd new file mode 100644 index 0000000000000000000000000000000000000000..36c90cbc40e0d87e7e497c2c49ff465bc6c65a9b --- /dev/null +++ b/man/fbms.mlik.master.Rd @@ -0,0 +1,79 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/likelihoods.R +\name{fbms.mlik.master} +\alias{fbms.mlik.master} +\title{Master Log Marginal Likelihood Function} +\usage{ +fbms.mlik.master( + y, + x, + model, + complex, + mlpost_params = list(family = "gaussian", beta_prior = list(type = "g-prior"), r = + NULL) +) +} +\arguments{ +\item{y}{A numeric vector containing the dependent variable.} + +\item{x}{A matrix containing the precalculated features (independent variables).} + +\item{model}{A logical vector indicating which variables to include in the model.} + +\item{complex}{A list of complexity measures for the features.} + +\item{mlpost_params}{A list of parameters controlling the model family, prior, and tuning parameters. +Key elements include: +\itemize{ +\item family: "binomial", "poisson", "gamma" (all three referred to as GLM below), or "gaussian" (default: "gaussian") +\item prior_beta: Type of prior as a string (default: "g-prior"). Possible values include: +\itemize{ +\item "beta.prime": Beta-prime prior (GLM/Gaussian, no additional args) +\item "CH": Compound Hypergeometric prior (GLM/Gaussian, requires \code{a}, \code{b}, optionally \code{s}) +\item "EB-local": Empirical Bayes local prior (GLM/Gaussian, requires \code{a} for Gaussian) +\item "EB-global": Empirical Bayes local prior (Gaussian, requires \code{a} for Gaussian) +\item "g-prior": Zellner's g-prior (GLM/Gaussian, requires \code{g}) +\item "hyper-g": Hyper-g prior (GLM/Gaussian, requires \code{a}) +\item "hyper-g-n": Hyper-g/n prior (GLM/Gaussian, requires \code{a}) +\item "tCCH": Truncated Compound Hypergeometric prior (GLM/Gaussian, requires \code{a}, \code{b}, \code{s}, \code{rho}, \code{v}, \code{k}) +\item "intrinsic": Intrinsic prior (GLM/Gaussian, no additional args) +\item "TG": Truncated Gamma prior (GLM/Gamma, requires \code{a}, \code{s}) +\item "Jeffreys": Jeffreys prior (GLM/Gaussian, no additional args) +\item "uniform": Uniform prior (GLM/Gaussian, no additional args) +\item "benchmark": Benchmark prior (Gaussian/GLM, no additional args) +\item "ZS-adapted": Zellner-Siow adapted prior (Gaussian TCCH, no additional args) +\item "robust": Robust prior (Gaussian/GLM, no additional args) +\item "Jeffreys-BIC": Jeffreys prior with BIC approximation of marginal likelihood (Gaussian/GLM) +\item "ZS-null": Zellner-Siow null prior (Gaussian, requires \code{a}) +\item "ZS-full": Zellner-Siow full prior (Gaussian, requires \code{a}) +\item "hyper-g-laplace": Hyper-g Laplace prior (Gaussian, requires \code{a}) +\item "AIC": AIC prior from BAS (Gaussian, requires penalty \code{a}) +\item "BIC": BIC prior from BAS (Gaussian/GLM) +\item "JZS": Jeffreys-Zellner-Siow prior (Gaussian, requires \code{a}) +} +\item r: Model complexity penalty (default: 1/n) +\item a: Tuning parameter for g-prior (default: max(n, p^2)) +\item a, b, s, v, rho, k: Hyperparameters for various priors +\item n: Sample size for some priors (default: length(y)) +\item var: Variance assumption for Gaussian models ("known" or "unknown", default: "unknown") +\item laplace: Logical for Laplace approximation in GLM only (default: FALSE) +}} +} +\value{ +A list with elements: +\item{crit}{Log marginal likelihood combined with the log prior.} +\item{coefs}{Posterior mode of the coefficients.} +} +\description{ +This function serves as a unified interface to compute the log marginal likelihood +for different regression models and priors by calling specific log likelihood functions. +} +\examples{ +fbms.mlik.master(y = rnorm(100), +x = matrix(rnorm(100)), +c(TRUE,TRUE), +list(oc = 1), +mlpost_params = list(family = "gaussian", beta_prior = list(type = "g-prior", a = 2), + r = exp(-0.5))) + +} diff --git a/man/gauss.Rd b/man/gauss.Rd deleted file mode 100644 index 944da4fdba205e7926818b7aa57646d0f4542a13..0000000000000000000000000000000000000000 --- a/man/gauss.Rd +++ /dev/null @@ -1,17 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/nonlinear_functions.R -\name{gauss} -\alias{gauss} -\title{Gaussian function} -\usage{ -gauss(x) -} -\arguments{ -\item{x}{The vector of values} -} -\value{ -e^(-x^2) -} -\description{ -Gaussian function -} diff --git a/man/gaussian.loglik.Rd b/man/gaussian.loglik.Rd index 24ad6f841f776c21b88d07bafd87a1c22d3ef9a6..5ec3268e7c2efd30f5a576c1b619aefef7638e15 100644 --- a/man/gaussian.loglik.Rd +++ b/man/gaussian.loglik.Rd @@ -2,9 +2,9 @@ % Please edit documentation in R/likelihoods.R \name{gaussian.loglik} \alias{gaussian.loglik} -\title{Log likelihood function for gaussian regression with a prior p(m)=r*sum(total_width).} +\title{Log likelihood function for gaussian regression with a Jeffreys prior and BIC approximation of MLIK with both known and unknown variance of the responses} \usage{ -gaussian.loglik(y, x, model, complex, params) +gaussian.loglik(y, x, model, complex, mlpost_params) } \arguments{ \item{y}{A vector containing the dependent variable} @@ -15,8 +15,16 @@ gaussian.loglik(y, x, model, complex, params) \item{complex}{A list of complexity measures for the features} -\item{params}{A list of parameters for the log likelihood, supplied by the user} +\item{mlpost_params}{A list of parameters for the log likelihood, supplied by the user} +} +\value{ +A list with the log marginal likelihood combined with the log prior (crit) and the posterior mode of the coefficients (coefs). } \description{ -Log likelihood function for gaussian regression with a prior p(m)=r*sum(total_width). +Log likelihood function for gaussian regression with a Jeffreys prior and BIC approximation of MLIK with both known and unknown variance of the responses +} +\examples{ +gaussian.loglik(rnorm(100), matrix(rnorm(100)), TRUE, list(oc = 1), NULL) + + } diff --git a/man/gaussian.loglik.alpha.Rd b/man/gaussian.loglik.alpha.Rd index b63c87d5a7c24a4de399e72f098a8d29a393ed1f..0ccabfa9a00f7fbda2dd7c58dcc818e970f687ad 100644 --- a/man/gaussian.loglik.alpha.Rd +++ b/man/gaussian.loglik.alpha.Rd @@ -14,10 +14,18 @@ gaussian.loglik.alpha(a, data, mu_func) \item{data}{The data to be used for calculation} \item{mu_func}{The function linking the mean to the covariates, -as a string with the alphas as a\link{i}.} +as a string with the alphas as a[i].} +} +\value{ +A numeric with the log likelihood. } \description{ Log likelihood function for gaussian regression for alpha calculation This function is just the bare likelihood function Note that it only gives a proportional value and is equivalent to least squares } +\examples{ +\dontrun{ +gaussian.loglik.alpha(my_alpha,my_data,my_mu) +} +} diff --git a/man/gaussian.loglik.bic.irlssgd.Rd b/man/gaussian.loglik.bic.irlssgd.Rd deleted file mode 100644 index b7f8ddd4427273e5eccee650e861cb90c8261dc9..0000000000000000000000000000000000000000 --- a/man/gaussian.loglik.bic.irlssgd.Rd +++ /dev/null @@ -1,28 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/likelihoods.R -\name{gaussian.loglik.bic.irlssgd} -\alias{gaussian.loglik.bic.irlssgd} -\title{Log likelihood function for gaussian regression with a prior p(m)=r*sum(total_width), using subsampling.} -\usage{ -gaussian.loglik.bic.irlssgd( - y, - x, - model, - complex, - params = list(r = 1, subs = 0.5) -) -} -\arguments{ -\item{y}{A vector containing the dependent variable} - -\item{x}{The matrix containing the precalculated features} - -\item{model}{The model to estimate as a logical vector} - -\item{complex}{A list of complexity measures for the features} - -\item{params}{A list of parameters for the log likelihood, supplied by the user} -} -\description{ -Log likelihood function for gaussian regression with a prior p(m)=r*sum(total_width), using subsampling. -} diff --git a/man/linear.g.prior.loglik.Rd b/man/gaussian.loglik.g.Rd similarity index 54% rename from man/linear.g.prior.loglik.Rd rename to man/gaussian.loglik.g.Rd index ccd65f2b6a391207393c367308d0889290ca8a66..6e7c2d84cf088e8f6bec26b99538b31dc5f08d9b 100644 --- a/man/linear.g.prior.loglik.Rd +++ b/man/gaussian.loglik.g.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/likelihoods.R -\name{linear.g.prior.loglik} -\alias{linear.g.prior.loglik} +\name{gaussian.loglik.g} +\alias{gaussian.loglik.g} \title{Log likelihood function for linear regression using Zellners g-prior} \usage{ -linear.g.prior.loglik(y, x, model, complex, params = list(g = 4)) +gaussian.loglik.g(y, x, model, complex, mlpost_params = NULL) } \arguments{ \item{y}{A vector containing the dependent variable} @@ -15,8 +15,15 @@ linear.g.prior.loglik(y, x, model, complex, params = list(g = 4)) \item{complex}{A list of complexity measures for the features} -\item{params}{A list of parameters for the log likelihood, supplied by the user} +\item{mlpost_params}{A list of parameters for the log likelihood, supplied by the user} +} +\value{ +A list with the log marginal likelihood combined with the log prior (crit) and the posterior mode of the coefficients (coefs). } \description{ Log likelihood function for linear regression using Zellners g-prior } +\examples{ +gaussian.loglik.g(rnorm(100), matrix(rnorm(100)), TRUE, list(oc=1)) + +} diff --git a/man/gaussian_tcch_log_likelihood.Rd b/man/gaussian_tcch_log_likelihood.Rd new file mode 100644 index 0000000000000000000000000000000000000000..d14ebfe55548339f5bdf2c8608d64245b53efd15 --- /dev/null +++ b/man/gaussian_tcch_log_likelihood.Rd @@ -0,0 +1,37 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/likelihoods.R +\name{gaussian_tcch_log_likelihood} +\alias{gaussian_tcch_log_likelihood} +\title{Log likelihood function for Gaussian regression with parameter priors from BAS package} +\usage{ +gaussian_tcch_log_likelihood( + y, + x, + model, + complex, + mlpost_params = list(r = exp(-0.5), beta_prior = list(type = "intrinsic")) +) +} +\arguments{ +\item{y}{A numeric vector containing the dependent variable.} + +\item{x}{A matrix containing the independent variables, including an intercept column.} + +\item{model}{A logical vector indicating which variables to include in the model.} + +\item{complex}{A list containing complexity measures for the features.} + +\item{mlpost_params}{A list of parameters for the log likelihood, specifying the tuning parameters of beta priors.} +} +\value{ +A list with elements: +\item{crit}{Log marginal likelihood combined with the log prior.} +\item{coefs}{Posterior mode of the coefficients.} +} +\description{ +This function computes the marginal likelihood of a Gaussian regression model under different priors. +} +\examples{ +gaussian_tcch_log_likelihood(rnorm(100), matrix(rnorm(100)), c(TRUE), list(oc=1)) + +} diff --git a/man/gelu.Rd b/man/gelu.Rd index 61ce3516d43128b5e471133055b59956beb29267..87458fe4cf7682e95d94985eef9e681c9b0f89f1 100644 --- a/man/gelu.Rd +++ b/man/gelu.Rd @@ -15,3 +15,7 @@ x*pnorm(x) \description{ GELU function } +\examples{ +gelu(2) + +} diff --git a/man/gen.params.gmjmcmc.Rd b/man/gen.params.gmjmcmc.Rd index d47b75db99610eb9f11188c2ca474531cd155e2d..611c7470670b4528b923dc16569f13d8a3422750 100644 --- a/man/gen.params.gmjmcmc.Rd +++ b/man/gen.params.gmjmcmc.Rd @@ -2,13 +2,109 @@ % Please edit documentation in R/arguments.R \name{gen.params.gmjmcmc} \alias{gen.params.gmjmcmc} -\title{Generate a parameter list for GMJMCMC} +\title{Generate a parameter list for GMJMCMC (Genetically Modified MJMCMC)} \usage{ -gen.params.gmjmcmc(data) +gen.params.gmjmcmc(ncov) } \arguments{ -\item{data}{The dataset that will be used in the algorithm} +\item{ncov}{The number of covariates in the dataset that will be used in the algorithm} +} +\value{ +A list of parameters for controlling GMJMCMC behavior: } \description{ -Generate a parameter list for GMJMCMC +This function generates the full list of parameters required for the Generalized Mode Jumping Markov Chain Monte Carlo (GMJMCMC) algorithm, building upon the parameters from \code{gen.params.mjmcmc}. The generated parameter list includes feature generation settings, population control parameters, and optimization controls for the search process. +} +\section{Feature Generation Parameters (\code{feat})}{ + +\describe{ +\item{\code{feat$D}}{Maximum feature depth, default \code{5}. Limits the number of recursive feature transformations. For fractional polynomials, it is recommended to set \code{D = 1}.} +\item{\code{feat$L}}{Maximum number of features per model, default \code{15}. Increase for complex models.} +\item{\code{feat$alpha}}{Strategy for generating $alpha$ parameters in non-linear projections: +\describe{ +\item{\code{"unit"}}{(Default) Sets all components to 1.} +\item{\code{"deep"}}{Optimizes $alpha$ across all feature layers.} +\item{\code{"random"}}{Samples $alpha$ from the prior for a fully Bayesian approach.} +}} +\item{\code{feat$pop.max}}{Maximum feature population size per iteration. Defaults to \code{min(100, as.integer(1.5 * p))}, where \code{p} is the number of covariates.} +\item{\code{feat$keep.org}}{Logical flag; if \code{TRUE}, original covariates remain in every population (default \code{FALSE}).} +\item{\code{feat$prel.filter}}{Threshold for pre-filtering covariates before the first population generation. Default \code{0} disables filtering.} +\item{\code{feat$prel.select}}{Indices of covariates to include initially. Default \code{NULL} includes all.} +\item{\code{feat$keep.min}}{Minimum proportion of features to retain during population updates. Default \code{0.8}.} +\item{\code{feat$eps}}{Threshold for feature inclusion probability during generation. Default \code{0.05}.} +\item{\code{feat$check.col}}{Logical; if \code{TRUE} (default), checks for collinearity during feature generation.} +\item{\code{feat$max.proj.size}}{Maximum number of existing features used to construct a new one. Default \code{15}.} +} +} + +\section{Scaling Option}{ + +\describe{ +\item{\code{rescale.large}}{Logical flag for rescaling large data values for numerical stability. Default \code{FALSE}.} +} +} + +\section{MJMCMC Parameters}{ + +\describe{ +\item{\code{burn_in}}{The burn-in period for the MJMCMC algorithm, which is set to 100 iterations by default.} + +\item{\code{mh}}{A list containing parameters for the regular Metropolis-Hastings (MH) kernel: +\describe{ +\item{\code{neigh.size}}{The size of the neighborhood for MH proposals with fixed proposal size, default set to 1.} +\item{\code{neigh.min}}{The minimum neighborhood size for random proposal size, default set to 1.} +\item{\code{neigh.max}}{The maximum neighborhood size for random proposal size, default set to 2.} +} +} + +\item{\code{large}}{A list containing parameters for the large jump kernel: +\describe{ +\item{\code{neigh.size}}{The size of the neighborhood for large jump proposals with fixed neighborhood size, default set to the smaller of \code{0.35 * p} and \code{35}, where \eqn{p} is the number of covariates.} +\item{\code{neigh.min}}{The minimum neighborhood size for large jumps with random size of the neighborhood, default set to the smaller of \code{0.25 * p} and \code{25}.} +\item{\code{neigh.max}}{The maximum neighborhood size for large jumps with random size of the neighborhood, default set to the smaller of \code{0.45 * p} and \code{45}.} +} +} + +\item{\code{random}}{A list containing a parameter for the randomization kernel: +\describe{ +\item{\code{prob}}{The small probability of changing the component around the mode, default set to 0.01.} +} +} + +\item{\code{sa}}{A list containing parameters for the simulated annealing kernel: +\describe{ +\item{\code{probs}}{A numeric vector of length 6 specifying the probabilities for different types of proposals in the simulated annealing algorithm.} +\item{\code{neigh.size}}{The size of the neighborhood for the simulated annealing proposals, default set to 1.} +\item{\code{neigh.min}}{The minimum neighborhood size, default set to 1.} +\item{\code{neigh.max}}{The maximum neighborhood size, default set to 2.} +\item{\code{t.init}}{The initial temperature for simulated annealing, default set to 10.} +\item{\code{t.min}}{The minimum temperature for simulated annealing, default set to 0.0001.} +\item{\code{dt}}{The temperature decrement factor, default set to 3.} +\item{\code{M}}{The number of iterations in the simulated annealing process, default set to 12.} +} +} + +\item{\code{greedy}}{A list containing parameters for the greedy algorithm: +\describe{ +\item{\code{probs}}{A numeric vector of length 6 specifying the probabilities for different types of proposals in the greedy algorithm.} +\item{\code{neigh.size}}{The size of the neighborhood for greedy algorithm proposals, set to 1.} +\item{\code{neigh.min}}{The minimum neighborhood size for greedy proposals, set to 1.} +\item{\code{neigh.max}}{The maximum neighborhood size for greedy proposals, set to 2.} +\item{\code{steps}}{The number of steps for the greedy algorithm, set to 20.} +\item{\code{tries}}{The number of tries for the greedy algorithm, set to 3.} +} +} + +\item{\code{loglik}}{A list to store log-likelihood values, which is by default empty.} +} +} + +\examples{ +data <- data.frame(y = rnorm(100), x1 = rnorm(100), x2 = rnorm(100)) +params <- gen.params.gmjmcmc(ncol(data) - 1) +str(params) + +} +\seealso{ +\code{\link{gen.params.mjmcmc}}, \code{\link{gmjmcmc}} } diff --git a/man/gen.params.mjmcmc.Rd b/man/gen.params.mjmcmc.Rd index eb0acc0837f99d1d4ae72c29dcf8b7b941db9c8f..67f217b22bba71fa326b118e622a7a89e237916b 100644 --- a/man/gen.params.mjmcmc.Rd +++ b/man/gen.params.mjmcmc.Rd @@ -2,21 +2,78 @@ % Please edit documentation in R/arguments.R \name{gen.params.mjmcmc} \alias{gen.params.mjmcmc} -\title{Generate a parameter list for MJMCMC} +\title{Generate a parameter list for MJMCMC (Mode Jumping MCMC)} \usage{ -gen.params.mjmcmc(data) +gen.params.mjmcmc(ncov) } \arguments{ -\item{data}{The dataset that will be used in the algorithm} +\item{ncov}{The number of covariates in the dataset that will be used in the algorithm} } \value{ -A list of parameters to use when running the MJMCMC algorithm. +A list of parameters to use when running the mjmcmc function. -TODO: WRITE MORE +The list contains the following elements: -Note that the $loglik item is an empty list, which is passed to the log likelihood function of the model, +\describe{ +\item{\code{burn_in}}{The burn-in period for the MJMCMC algorithm, which is set to 100 iterations by default.} + +\item{\code{mh}}{A list containing parameters for the regular Metropolis-Hastings (MH) kernel: +\describe{ +\item{\code{neigh.size}}{The size of the neighborhood for MH proposals with fixed proposal size, default set to 1.} +\item{\code{neigh.min}}{The minimum neighborhood size for random proposal size, default set to 1.} +\item{\code{neigh.max}}{The maximum neighborhood size for random proposal size, default set to 2.} +} +} + +\item{\code{large}}{A list containing parameters for the large jump kernel: +\describe{ +\item{\code{neigh.size}}{The size of the neighborhood for large jump proposals with fixed neighborhood size, default set to the smaller of 0.35 \eqn{\times p} and 35, where \eqn{p} is the number of covariates.} +\item{\code{neigh.min}}{The minimum neighborhood size for large jumps with random size of the neighborhood, default set to the smaller of 0.25 \eqn{\times p} and 25.} +\item{\code{neigh.max}}{The maximum neighborhood size for large jumps with random size of the neighborhood, default set to the smaller of 0.45 \eqn{\times p} and 45.} +} +} + +\item{\code{random}}{A list containing a parameter for the randomization kernel: +\describe{ +\item{\code{prob}}{The small probability of changing the component around the mode, default set to 0.01.} +} +} + +\item{\code{sa}}{A list containing parameters for the simulated annealing kernel: +\describe{ +\item{\code{probs}}{A numeric vector of length 6 specifying the probabilities for different types of proposals in the simulated annealing algorithm.} +\item{\code{neigh.size}}{The size of the neighborhood for the simulated annealing proposals, default set to 1.} +\item{\code{neigh.min}}{The minimum neighborhood size, default set to 1.} +\item{\code{neigh.max}}{The maximum neighborhood size, default set to 2.} +\item{\code{t.init}}{The initial temperature for simulated annealing, default set to 10.} +\item{\code{t.min}}{The minimum temperature for simulated annealing, default set to 0.0001.} +\item{\code{dt}}{The temperature decrement factor, default set to 3.} +\item{\code{M}}{The number of iterations in the simulated annealing process, default set to 12.} +} +} + +\item{\code{greedy}}{A list containing parameters for the greedy algorithm: +\describe{ +\item{\code{probs}}{A numeric vector of length 6 specifying the probabilities for different types of proposals in the greedy algorithm.} +\item{\code{neigh.size}}{The size of the neighborhood for greedy algorithm proposals, set to 1.} +\item{\code{neigh.min}}{The minimum neighborhood size for greedy proposals, set to 1.} +\item{\code{neigh.max}}{The maximum neighborhood size for greedy proposals, set to 2.} +\item{\code{steps}}{The number of steps for the greedy algorithm, set to 20.} +\item{\code{tries}}{The number of tries for the greedy algorithm, set to 3.} +} +} + +\item{\code{loglik}}{A list to store log-likelihood values, which is by default empty.} +} + +Note that the \verb{$loglik} item is an empty list, which is passed to the log likelihood function of the model, intended to store parameters that the estimator function should use. } \description{ -Generate a parameter list for MJMCMC +Generate a parameter list for MJMCMC (Mode Jumping MCMC) +} +\examples{ +gen.params.mjmcmc(matrix(rnorm(600), 100)) + + } diff --git a/man/gen.probs.gmjmcmc.Rd b/man/gen.probs.gmjmcmc.Rd index 732444e6fd8ddf16a9068ffbb54a4322c70db54e..333c9106a7f13a08484e3dda0852cbecf951630f 100644 --- a/man/gen.probs.gmjmcmc.Rd +++ b/man/gen.probs.gmjmcmc.Rd @@ -2,13 +2,66 @@ % Please edit documentation in R/arguments.R \name{gen.probs.gmjmcmc} \alias{gen.probs.gmjmcmc} -\title{Generate a probability list for GMJMCMC} +\title{Generate a probability list for GMJMCMC (Genetically Modified MJMCMC)} \usage{ gen.probs.gmjmcmc(transforms) } \arguments{ \item{transforms}{A list of the transformations used (to get the count).} } +\value{ +A named list with eight elements: +\describe{ +\item{\code{large}}{The probability of a large jump kernel in the MJMCMC algorithm. +With this probability, a large jump proposal will be made; otherwise, a local +Metropolis-Hastings proposal will be used. One needs to consider good mixing +around and between modes when specifying this parameter.} + +\item{\code{large.kern}}{A numeric vector of length 4 specifying the probabilities +for different types of large jump kernels. +The four components correspond to: +\enumerate{ +\item Random change with random neighborhood size +\item Random change with fixed neighborhood size +\item Swap with random neighborhood size +\item Swap with fixed neighborhood size +} +These probabilities will be automatically normalized if they do not sum to 1.} + +\item{\code{localopt.kern}}{A numeric vector of length 2 specifying the probabilities +for different local optimization methods during large jumps. The first value represents +the probability of using simulated annealing, while the second corresponds to the +greedy optimizer. These probabilities will be normalized if needed.} + +\item{\code{random.kern}}{A numeric vector of length 2 specifying the probabilities +of first two randomization kernels applied after local optimization. These correspond +to the same kernel types as in \code{large.kern} but are used for local proposals +where type and 2 only are allowed.} + +\item{\code{mh}}{A numeric vector specifying the probabilities of different standard Metropolis-Hastings kernels, where the first four as the same as for other kernels, while fifths and sixes components are uniform addition/deletion of a covariate.} + +\item{\code{filter}}{A numeric value controlling the filtering of features +with low posterior probabilities in the current population. Features with +posterior probabilities below this threshold will be removed with a probability +proportional to \eqn{1 - P(\text{feature} \mid \text{population})}.} + +\item{\code{gen}}{A numeric vector of length 4 specifying the probabilities of different +feature generation operators. These determine how new nonlinear features are introduced. +The first entry gives the probability for an interaction, followed by modification, +nonlinear projection, and a mutation operator, which reintroduces discarded features. +If these probabilities do not sum to 1, they are automatically normalized.} + +\item{\code{trans}}{A numeric vector of length equal to the number of elements in \code{transforms}, +specifying the probabilities of selecting each nonlinear transformation from \eqn{\mathcal{G}}. +By default, a uniform distribution is assigned, but this can be modified by providing a specific +\code{transforms} argument.} +} +} \description{ -Generate a probability list for GMJMCMC +Generate a probability list for GMJMCMC (Genetically Modified MJMCMC) +} +\examples{ +gen.probs.gmjmcmc(c("p0", "exp_dbl")) + + } diff --git a/man/gen.probs.mjmcmc.Rd b/man/gen.probs.mjmcmc.Rd index 7a103c881d41fa0a784dc04a129ab6f479594f3f..f21bf3db8cade78df3eb347d3b378ae757ead5c1 100644 --- a/man/gen.probs.mjmcmc.Rd +++ b/man/gen.probs.mjmcmc.Rd @@ -2,10 +2,31 @@ % Please edit documentation in R/arguments.R \name{gen.probs.mjmcmc} \alias{gen.probs.mjmcmc} -\title{Generate a probability list for MJMCMC} +\title{Generate a probability list for MJMCMC (Mode Jumping MCMC)} \usage{ gen.probs.mjmcmc() } +\value{ +A named list with five elements: +\describe{ +\item{\code{large}}{A numeric value representing the probability of making a large jump. If a large jump is not made, a local MH (Metropolis-Hastings) proposal is used instead.} +\item{\code{large.kern}}{A numeric vector of length 4 specifying the probabilities for different types of large jump kernels. The four components correspond to: +\enumerate{ +\item Random change with random neighborhood size +\item Random change with fixed neighborhood size +\item Swap with random neighborhood size +\item Swap with fixed neighborhood size +} +These probabilities will be automatically normalized if they do not sum to 1.} +\item{\code{localopt.kern}}{A numeric vector of length 2 specifying the probabilities for different local optimization methods during large jumps. The first value represents the probability of using simulated annealing, while the second corresponds to the greedy optimizer. These probabilities will be normalized if needed.} +\item{\code{random.kern}}{A numeric vector of length 2 specifying the probabilities of different randomization kernels applied after local optimization of type one or two. These correspond to the first two kernel types as in \code{large.kern} but are used for local proposals with different neighborhood sizes.} +\item{\code{mh}}{A numeric vector specifying the probabilities of different standard Metropolis-Hastings kernels, where the first four as the same as for other kernels, while fifths and sixes components are uniform addition/deletion of a covariate.} +} +} \description{ -Generate a probability list for MJMCMC +Generate a probability list for MJMCMC (Mode Jumping MCMC) +} +\examples{ +gen.probs.mjmcmc() + } diff --git a/man/get.best.model.Rd b/man/get.best.model.Rd new file mode 100644 index 0000000000000000000000000000000000000000..9b564e519b9825dcccb0e6e7d905c8902e413d43 --- /dev/null +++ b/man/get.best.model.Rd @@ -0,0 +1,45 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/results.R +\name{get.best.model} +\alias{get.best.model} +\title{Extract the Best Model from MJMCMC or GMJMCMC Results} +\usage{ +get.best.model(result, labels = FALSE) +} +\arguments{ +\item{result}{An object of class \code{"mjmcmc"}, \code{"mjmcmc_parallel"}, \code{"gmjmcmc"}, or \code{"gmjmcmc_merged"}, +containing the results from the corresponding model search algorithms.} + +\item{labels}{Logical; if \code{TRUE}, uses labeled feature names when naming the model coefficients. Default is \code{FALSE}.} +} +\value{ +A list containing the details of the best model: +\describe{ +\item{\code{prob}}{A numeric value representing the model's probability.} +\item{\code{model}}{A logical vector indicating which features are included in the best model.} +\item{\code{crit}}{The criterion value used for model selection (e.g., marginal likelihood or posterior probability).} +\item{\code{alpha}}{The intercept parameter of the best model.} +\item{\code{coefs}}{A named numeric vector of model coefficients, including the intercept and selected features.} +} +} +\description{ +This function retrieves the best model from the results of MJMCMC, MJMCMC parallel, GMJMCMC, or GMJMCMC merged runs +based on the maximum criterion value (\code{crit}). The returned list includes the model probability, selected features, +criterion value, intercept parameter, and named coefficients. +} +\details{ +The function identifies the best model by selecting the one with the highest \code{crit} value. Selection logic depends on the class of the \code{result} object: +\describe{ +\item{\code{"mjmcmc"}}{Selects the top model from a single MJMCMC run.} +\item{\code{"mjmcmc_parallel"}}{Identifies the best chain, then selects the best model from that chain.} +\item{\code{"gmjmcmc"}}{Selects the best population and model within that population.} +\item{\code{"gmjmcmc_merged"}}{Finds the best chain and population before extracting the top model.} +} +} +\examples{ +result <- gmjmcmc(x = matrix(rnorm(600), 100), +y = matrix(rnorm(100), 100), +P = 2, transforms = c("p0", "exp_dbl")) +get.best.model(result) + +} diff --git a/man/get.mpm.model.Rd b/man/get.mpm.model.Rd new file mode 100644 index 0000000000000000000000000000000000000000..75891275abd200215b76b662010fb60f2d50735f --- /dev/null +++ b/man/get.mpm.model.Rd @@ -0,0 +1,73 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/results.R +\name{get.mpm.model} +\alias{get.mpm.model} +\title{Retrieve the Median Probability Model (MPM)} +\usage{ +get.mpm.model( + result, + y, + x, + labels = F, + family = "gaussian", + loglik.pi = gaussian.loglik, + params = NULL +) +} +\arguments{ +\item{result}{A fitted model object (e.g., from \code{mjmcmc}, \code{gmjmcmc}, or related classes) containing the summary statistics and marginal probabilities.} + +\item{y}{A numeric vector of response values. For \code{family = "binomial"}, it should contain binary (0/1) responses.} + +\item{x}{A \code{data.frame} of predictor variables. Columns must correspond to features considered during model fitting.} + +\item{labels}{If specified, custom labels of covariates can be used. Default is \code{FALSE}.} + +\item{family}{Character string specifying the model family. Supported options are: +\itemize{ +\item \code{"gaussian"} (default) - for continuous outcomes. +\item \code{"binomial"} - for binary outcomes. +\item \code{"custom"} - for user-defined likelihood functions. +} +If an unsupported family is provided, a warning is issued and the Gaussian likelihood is used by default.} + +\item{loglik.pi}{A function that computes the log-likelihood. Defaults to \code{gaussian.loglik} unless \code{family = "binomial"}, in which case \code{logistic.loglik} is used. for custom family the user must specify the same likelihood that was used in the inference.} + +\item{params}{Parameters of \code{loglik.pi}, if not specified NULL will be used by default} +} +\value{ +A \code{bgnlm_model} object containing: +\describe{ +\item{\code{prob}}{The log marginal likelihood of the MPM.} +\item{\code{model}}{A logical vector indicating included features.} +\item{\code{crit}}{Criterion label set to \code{"MPM"}.} +\item{\code{coefs}}{A named numeric vector of model coefficients, including the intercept.} +} +} +\description{ +This function extracts the Median Probability Model (MPM) from a fitted model object. +The MPM includes features with marginal posterior inclusion probabilities greater than 0.5. +It constructs the corresponding model matrix and computes the model fit using the specified likelihood. +} +\examples{ +\dontrun{ +# Simulate data +set.seed(42) +x <- data.frame( + PlanetaryMassJpt = rnorm(100), + RadiusJpt = rnorm(100), + PeriodDays = rnorm(100) +) +y <- 1 + 0.5 * x$PlanetaryMassJpt - 0.3 * x$RadiusJpt + rnorm(100) + +# Assume 'result' is a fitted object from gmjmcmc or mjmcmc +result <- mjmcmc(cbind(y,x)) + +# Get the MPM +mpm_model <- get.mpm.model(result, y, x, family = "gaussian") + +# Access coefficients +mpm_model$coefs +} + +} diff --git a/man/glm.loglik.Rd b/man/glm.loglik.Rd new file mode 100644 index 0000000000000000000000000000000000000000..24fd1ba89aaa6cb2b233c2cba27523416fef67e9 --- /dev/null +++ b/man/glm.loglik.Rd @@ -0,0 +1,40 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/likelihoods.R +\name{glm.loglik} +\alias{glm.loglik} +\title{Log likelihood function for glm regression with a Jeffreys parameter prior and BIC approximations of the posterior +This function is created as an example of how to create an estimator that is used +to calculate the marginal likelihood of a model.} +\usage{ +glm.loglik( + y, + x, + model, + complex, + mlpost_params = list(r = exp(-0.5), family = "Gamma") +) +} +\arguments{ +\item{y}{A vector containing the dependent variable} + +\item{x}{The matrix containing the precalculated features} + +\item{model}{The model to estimate as a logical vector} + +\item{complex}{A list of complexity measures for the features} + +\item{mlpost_params}{A list of parameters for the log likelihood, supplied by the user, family must be specified} +} +\value{ +A list with the log marginal likelihood combined with the log prior (crit) and the posterior mode of the coefficients (coefs). +} +\description{ +Log likelihood function for glm regression with a Jeffreys parameter prior and BIC approximations of the posterior +This function is created as an example of how to create an estimator that is used +to calculate the marginal likelihood of a model. +} +\examples{ +glm.loglik(abs(rnorm(100))+1, matrix(rnorm(100)), TRUE, list(oc = 1)) + + +} diff --git a/man/glm.logpost.bas.Rd b/man/glm.logpost.bas.Rd new file mode 100644 index 0000000000000000000000000000000000000000..8a58fcd7595153adab13e8becfc19f44cc7db43f --- /dev/null +++ b/man/glm.logpost.bas.Rd @@ -0,0 +1,43 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/likelihoods.R +\name{glm.logpost.bas} +\alias{glm.logpost.bas} +\title{Log likelihood function for glm regression with parameter priors from BAS package +This function is created as an example of how to create an estimator that is used +to calculate the marginal likelihood of a model.} +\usage{ +glm.logpost.bas( + y, + x, + model, + complex, + mlpost_params = list(r = NULL, family = "binomial", beta_prior = Jeffreys(), laplace = + FALSE) +) +} +\arguments{ +\item{y}{A vector containing the dependent variable} + +\item{x}{The matrix containing the precalculated features} + +\item{model}{The model to estimate as a logical vector} + +\item{complex}{A list of complexity measures for the features} + +\item{mlpost_params}{A list of parameters for the log likelihood, supplied by the user, important to specify the tuning parameters of beta priors and family that BAS uses in glm models} +} +\value{ +A list with the log marginal likelihood combined with the log prior (crit) and the posterior mode of the coefficients (coefs). +} +\description{ +Log likelihood function for glm regression with parameter priors from BAS package +This function is created as an example of how to create an estimator that is used +to calculate the marginal likelihood of a model. +} +\examples{ +glm.logpost.bas(as.integer(rnorm(100) > 0), +cbind(1, matrix(rnorm(100))), +c(TRUE, TRUE), +list(oc = 1)) + +} diff --git a/man/gmjmcmc.Rd b/man/gmjmcmc.Rd index d2ef28d9fddcd06a1e6fdb8c10c19592c6f39327..1ec1a0eb1d2b4cd152bd776e28d50881d9ce293d 100644 --- a/man/gmjmcmc.Rd +++ b/man/gmjmcmc.Rd @@ -2,49 +2,87 @@ % Please edit documentation in R/gmjmcmc.R \name{gmjmcmc} \alias{gmjmcmc} -\title{Main algorithm for GMJMCMC -TODO: More documentation - borrow from https://github.com/aliaksah/EMJMCMC2016/blob/master/man/EMJMCMC.Rd if applicable.} +\title{Main algorithm for GMJMCMC (Genetically Modified MJMCMC)} \usage{ gmjmcmc( - data, - loglik.pi = gaussian.loglik, - loglik.alpha = gaussian.loglik.alpha, + x, + y, transforms, P = 10, - N.init = 100, - N.final = 100, + N = 100, + N.final = NULL, probs = NULL, params = NULL, - sub = FALSE + loglik.pi = NULL, + loglik.alpha = gaussian.loglik.alpha, + mlpost_params = list(family = "gaussian", beta_prior = list(type = "g-prior")), + intercept = TRUE, + fixed = 0, + sub = FALSE, + verbose = TRUE ) } \arguments{ -\item{data}{A matrix containing the data to use in the algorithm, -first column should be the dependent variable, second should be the intercept -and the rest of the columns should be the independent variables.} +\item{x}{matrix containing the design matrix with data to use in the algorithm} + +\item{y}{response variable} + +\item{transforms}{A character vector including the names of the non-linear functions to be used by the modification and the projection operator.} + +\item{P}{The number of population iterations for GMJMCMC. The default value is P = 10, which was used in our initial example for illustrative purposes. However, a larger value, such as P = 50, is typically more appropriate for most practical applications.} -\item{loglik.pi}{The (log) density to explore} +\item{N}{The number of MJMCMC iterations per population. +The default value is N = 100; however, for real applications, a larger value such as N = 1000 or higher is often preferable.} -\item{loglik.alpha}{The likelihood function to use for alpha calculation} +\item{N.final}{The number of MJMCMC iterations performed for the final population. Per default one has N.final = N, but for practical applications, a much larger value (e.g., N.final = 1000) is recommended. Increasing N.final is particularly important if predictions and inferences are based solely on the last population.} -\item{transforms}{A Character vector including the names of the non-linear functions to be used by the modification -and the projection operator.} +\item{probs}{A list of various probability vectors used by GMJMCMC, generated by \code{gen.probs.gmjmcmc}. +The key component \code{probs.gen} defines probabilities of different operators in the feature generation process. +Defaults typically favor interactions and modifications (0.4 each) over projections and mutations (0.1 each) to encourage interpretable nonlinear features.} -\item{P}{The number of generations for GMJMCMC. -The default value is $P = 10$. -A larger value like $P = 50$ might be more realistic for more complicated examples where one expects a lot of non-linear structures.} +\item{params}{A list of various parameter vectors used by GMJMCMC, generated by \code{gen.params.gmjmcmc}.} -\item{N.init}{The number of iterations per population (total iterations = (T-1)*N.init+N.final)} +\item{loglik.pi}{A function specifying the marginal log-posterior of the model up to a constant, including the logarithm of the model prior: +\eqn{\log p(M|Y) = \text{const} + \log p(Y|M) + \log p(M)}. +Typically assumes a Gaussian model with Zellner'swith \eqn{g = max(n,p^2) by default}.} -\item{N.final}{The number of iterations for the final population (total iterations = (T-1)*N.init+N.final)} +\item{loglik.alpha}{Relevant only if the non-linear projection features depend on parameters \eqn{\alpha}. +If \eqn{\alpha} is estimated, this argument specifies the corresponding marginal log-likelihood. +The default method sets all \eqn{\alpha} to 1 (fastest, but sometimes suboptimal). +Alternative estimation strategies ("deep" and "random") are implemented in \pkg{FBMS}.} -\item{probs}{A list of the various probability vectors to use} +\item{mlpost_params}{All parameters for the estimator function loglik.pi} -\item{params}{A list of the various parameters for all the parts of the algorithm} +\item{intercept}{Logical. Whether to include an intercept in the design matrix. Default is \code{TRUE}. No variable selection is performed on the intercept.} -\item{sub}{An indicator that if the likelihood is inexact and should be improved each model visit (EXPERIMENTAL!)} +\item{fixed}{Integer specifying the number of leading columns in the design matrix to always include in the model. Default is 0.} + +\item{sub}{Logical. If \code{TRUE}, uses subsampling or a stochastic approximation approach to the likelihood rather than the full likelihood. Default is \code{FALSE}.} + +\item{verbose}{Logical. Whether to print messages during execution. Default is \code{TRUE} for \code{gmjmcmc} and \code{FALSE} for the parallel version.} +} +\value{ +A list containing the following elements: +\item{models}{All models per population.} +\item{mc.models}{All models accepted by mjmcmc per population.} +\item{populations}{All features per population.} +\item{marg.probs}{Marginal feature probabilities per population.} +\item{model.probs}{Marginal feature probabilities per population.} +\item{model.probs.idx}{Marginal feature probabilities per population.} +\item{best.margs}{Best marginal model probability per population.} +\item{accept}{Acceptance rate per population.} +\item{accept.tot}{Overall acceptance rate.} +\item{best}{Best marginal model probability throughout the run, represented as the maximum value in \code{unlist(best.margs)}.} } \description{ -Main algorithm for GMJMCMC -TODO: More documentation - borrow from https://github.com/aliaksah/EMJMCMC2016/blob/master/man/EMJMCMC.Rd if applicable. +Main algorithm for GMJMCMC (Genetically Modified MJMCMC) +} +\examples{ +result <- gmjmcmc(y = matrix(rnorm(100), 100), +x = matrix(rnorm(600), 100), +P = 2, +transform = c("p0", "exp_dbl")) +summary(result) +plot(result) + } diff --git a/man/gmjmcmc.iact.Rd b/man/gmjmcmc.iact.Rd deleted file mode 100644 index 0edb79971338abeb716e3f3d4c79f5d6721a62ff..0000000000000000000000000000000000000000 --- a/man/gmjmcmc.iact.Rd +++ /dev/null @@ -1,14 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/diagnostics.R -\name{gmjmcmc.iact} -\alias{gmjmcmc.iact} -\title{Integrated Auto-Correlation Time} -\usage{ -gmjmcmc.iact(x) -} -\arguments{ -\item{x}{A matrix where each row is a model} -} -\description{ -Integrated Auto-Correlation Time -} diff --git a/man/gmjmcmc.parallel.Rd b/man/gmjmcmc.parallel.Rd index e5ac00f34e49a5df27ddf5f447467d32d698cfcc..f05094e2650a2b65ba551ee4d403d785a22ad2ed 100644 --- a/man/gmjmcmc.parallel.Rd +++ b/man/gmjmcmc.parallel.Rd @@ -2,42 +2,63 @@ % Please edit documentation in R/parallel.R \name{gmjmcmc.parallel} \alias{gmjmcmc.parallel} -\title{Run multiple gmjmcmc runs in parallel returning a list of all results.} +\title{Run multiple gmjmcmc (Genetically Modified MJMCMC) runs in parallel returning a list of all results.} \usage{ gmjmcmc.parallel( - runs, + x, + y, + loglik.pi = NULL, + mlpost_params = list(family = "gaussian", beta_prior = list(type = "g-prior")), + loglik.alpha = gaussian.loglik.alpha, + transforms, + runs = 2, cores = getOption("mc.cores", 2L), + verbose = FALSE, merge.options = list(populations = "best", complex.measure = 2, tol = 1e-07), - data, - loglik.pi = gaussian.loglik, - loglik.alpha = gaussian.loglik.alpha(), - transforms, ... ) } \arguments{ -\item{runs}{The number of runs to run} - -\item{cores}{The number of cores to run on} +\item{x}{matrix containing the design matrix with data to use in the algorithm} -\item{merge.options}{A list of options to pass to the \code{\link[=merge_results]{merge_results()}} function run after the} - -\item{data}{A matrix containing the data to use in the algorithm, -first column should be the dependent variable, second should be the intercept -and the rest of the columns should be the independent variables.} +\item{y}{response variable} \item{loglik.pi}{The (log) density to explore} +\item{mlpost_params}{parameters for the estimator function loglik.pi} + \item{loglik.alpha}{The likelihood function to use for alpha calculation} -\item{transforms}{A Character vector including the names of the non-linear functions to be used by the modification -and the projection operator.} +\item{transforms}{A Character vector including the names of the non-linear functions to be used by the modification} + +\item{runs}{The number of runs to run} + +\item{cores}{The number of cores to run on} + +\item{verbose}{A logical denoting if messages should be printed} -\item{...}{Further params passed to mjmcmc.} +\item{merge.options}{A list of options to pass to the \code{\link[=merge_results]{merge_results()}} function run after the run} + +\item{...}{Further parameters passed to mjmcmc.} } \value{ Results from multiple gmjmcmc runs } \description{ -Run multiple gmjmcmc runs in parallel returning a list of all results. +Run multiple gmjmcmc (Genetically Modified MJMCMC) runs in parallel returning a list of all results. +} +\examples{ +result <- gmjmcmc.parallel( + runs = 1, + cores = 1, + loglik.pi = NULL, + y = matrix(rnorm(100), 100), + x = matrix(rnorm(600), 100), + transforms = c("p0", "exp_dbl") +) + +summary(result) + +plot(result) + } diff --git a/man/gmjmcmc.transition.Rd b/man/gmjmcmc.transition.Rd deleted file mode 100644 index 5fe093613af7159f45895ce3026a54b544b93e13..0000000000000000000000000000000000000000 --- a/man/gmjmcmc.transition.Rd +++ /dev/null @@ -1,43 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/gmjmcmc.R -\name{gmjmcmc.transition} -\alias{gmjmcmc.transition} -\title{Subalgorithm for generating a new population of features in GMJMCMC} -\usage{ -gmjmcmc.transition( - S.t, - F.0, - data, - loglik.alpha, - marg.probs.F.0, - marg.probs, - labels, - probs, - params -) -} -\arguments{ -\item{S.t}{The current population of features} - -\item{F.0}{The initial population of features, i.e. the bare covariates} - -\item{data}{The data used in the model, here we use it to generate alphas for new features} - -\item{loglik.alpha}{The log likelihood function to optimize the alphas for} - -\item{marg.probs.F.0}{The marginal inclusion probabilities of the initial population of features} - -\item{marg.probs}{The marginal inclusion probabilities of the current features} - -\item{labels}{Variable labels for printing} - -\item{probs}{A list of the various probability vectors to use} - -\item{params}{A list of the various parameters for all the parts of the algorithm} -} -\value{ -The updated population of features, that becomes S.t+1 -} -\description{ -Subalgorithm for generating a new population of features in GMJMCMC -} diff --git a/man/hs.Rd b/man/hs.Rd index f63fa66b31b689f44f0563b9211f758f03f48ed4..8177dd8e088e29e98e81874dacac454de0a56870 100644 --- a/man/hs.Rd +++ b/man/hs.Rd @@ -15,3 +15,7 @@ as.integer(x>0) \description{ heavy side function } +\examples{ +hs(2) + +} diff --git a/man/lm.logpost.bas.Rd b/man/lm.logpost.bas.Rd new file mode 100644 index 0000000000000000000000000000000000000000..5852817e432f6e84ead0daee1597727f7f4f2d13 --- /dev/null +++ b/man/lm.logpost.bas.Rd @@ -0,0 +1,40 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/likelihoods.R +\name{lm.logpost.bas} +\alias{lm.logpost.bas} +\title{Log likelihood function for Gaussian regression with parameter priors from BAS package +This function is created as an example of how to create an estimator that is used +to calculate the marginal likelihood of a model.} +\usage{ +lm.logpost.bas( + y, + x, + model, + complex, + mlpost_params = list(r = exp(-0.5), beta_prior = list(method = 1)) +) +} +\arguments{ +\item{y}{A vector containing the dependent variable} + +\item{x}{The matrix containing the precalculated features} + +\item{model}{The model to estimate as a logical vector} + +\item{complex}{A list of complexity measures for the features} + +\item{mlpost_params}{A list of parameters for the log likelihood, supplied by the user, important to specify the tuning parameters of beta priors where the corresponding integers as prior_beta must be provided "g-prior" = 0, "hyper-g" = 1, "EB-local" = 2, "BIC" = 3, "ZS-null" = 4, "ZS-full" = 5, "hyper-g-laplace" = 6, "AIC" = 7, "EB-global" = 2, "hyper-g-n" = 8, "JZS" = 9 and in Gaussian models} +} +\value{ +A list with the log marginal likelihood combined with the log prior (crit) and the posterior mode of the coefficients (coefs). +} +\description{ +Log likelihood function for Gaussian regression with parameter priors from BAS package +This function is created as an example of how to create an estimator that is used +to calculate the marginal likelihood of a model. +} +\examples{ +lm.logpost.bas(rnorm(100), cbind(1,matrix(rnorm(100))), c(TRUE,TRUE), list(oc = 1)) + + +} diff --git a/man/log_prior.Rd b/man/log_prior.Rd new file mode 100644 index 0000000000000000000000000000000000000000..8e185cef7e244f4f85b8c7dfa211ba318a7996d4 --- /dev/null +++ b/man/log_prior.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/likelihoods.R +\name{log_prior} +\alias{log_prior} +\title{Log model prior function} +\usage{ +log_prior(mlpost_params, complex) +} +\arguments{ +\item{mlpost_params}{list of passed parameters of the likelihood in GMJMCMC} + +\item{complex}{list of complexity measures of the features included into the model} +} +\value{ +A numeric with the log model prior. +} +\description{ +Log model prior function +} +\examples{ +log_prior(mlpost_params = list(r=2), complex = list(oc = 2)) + +} diff --git a/man/logistic.loglik.Rd b/man/logistic.loglik.Rd index 69a581f0c6ed4e836d1a9d8f6bff7914bc8b85f6..8ff2791c8c64ec902c08fc02ff4804513d416502 100644 --- a/man/logistic.loglik.Rd +++ b/man/logistic.loglik.Rd @@ -2,11 +2,11 @@ % Please edit documentation in R/likelihoods.R \name{logistic.loglik} \alias{logistic.loglik} -\title{Log likelihood function for logistic regression with a prior p(m)=sum(total_width) +\title{Log likelihood function for logistic regression with a Jeffreys parameter prior and BIC approximations of the posterior This function is created as an example of how to create an estimator that is used to calculate the marginal likelihood of a model.} \usage{ -logistic.loglik(y, x, model, complex, params = list(r = 1)) +logistic.loglik(y, x, model, complex, mlpost_params = list(r = exp(-0.5))) } \arguments{ \item{y}{A vector containing the dependent variable} @@ -17,10 +17,18 @@ logistic.loglik(y, x, model, complex, params = list(r = 1)) \item{complex}{A list of complexity measures for the features} -\item{params}{A list of parameters for the log likelihood, supplied by the user} +\item{mlpost_params}{A list of parameters for the log likelihood, supplied by the user} +} +\value{ +A list with the log marginal likelihood combined with the log prior (crit) and the posterior mode of the coefficients (coefs). } \description{ -Log likelihood function for logistic regression with a prior p(m)=sum(total_width) +Log likelihood function for logistic regression with a Jeffreys parameter prior and BIC approximations of the posterior This function is created as an example of how to create an estimator that is used to calculate the marginal likelihood of a model. } +\examples{ +logistic.loglik(as.integer(rnorm(100) > 0), matrix(rnorm(100)), TRUE, list(oc = 1)) + + +} diff --git a/man/logistic.loglik.ala.Rd b/man/logistic.loglik.ala.Rd new file mode 100644 index 0000000000000000000000000000000000000000..fd1cdcf89a26655336f2b69aa93ab9c24268d008 --- /dev/null +++ b/man/logistic.loglik.ala.Rd @@ -0,0 +1,34 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/likelihoods.R +\name{logistic.loglik.ala} +\alias{logistic.loglik.ala} +\title{Log likelihood function for logistic regression with an approximate Laplace approximations used +This function is created as an example of how to create an estimator that is used +to calculate the marginal likelihood of a model.} +\usage{ +logistic.loglik.ala(y, x, model, complex, mlpost_params = list(r = exp(-0.5))) +} +\arguments{ +\item{y}{A vector containing the dependent variable} + +\item{x}{The matrix containing the precalculated features} + +\item{model}{The model to estimate as a logical vector} + +\item{complex}{A list of complexity measures for the features} + +\item{mlpost_params}{A list of parameters for the log likelihood, supplied by the user} +} +\value{ +A list with the log marginal likelihood combined with the log prior (crit) and the posterior mode of the coefficients (coefs). +} +\description{ +Log likelihood function for logistic regression with an approximate Laplace approximations used +This function is created as an example of how to create an estimator that is used +to calculate the marginal likelihood of a model. +} +\examples{ +logistic.loglik.ala(as.integer(rnorm(100) > 0), matrix(rnorm(100)), TRUE, list(oc = 1)) + + +} diff --git a/man/logistic.loglik.alpha.Rd b/man/logistic.loglik.alpha.Rd index 9f1987404a42613f4a6c64cd0cbc9cff74449fb1..feaf241c9b8ea15db35e6984295ceb6e3bfcbffa 100644 --- a/man/logistic.loglik.alpha.Rd +++ b/man/logistic.loglik.alpha.Rd @@ -13,7 +13,10 @@ logistic.loglik.alpha(a, data, mu_func) \item{data}{The data to be used for calculation} \item{mu_func}{The function linking the mean to the covariates, -as a string with the alphas as a\link{i}.} +as a string with the alphas as a[i].} +} +\value{ +A numeric with the log likelihood. } \description{ Log likelihood function for logistic regression for alpha calculation diff --git a/man/marginal.probs.Rd b/man/marginal.probs.Rd index 6a7dd7220e5ca1f495f74fd470a72c2c9288124b..cf927ecd2dc5366d1493bf33f92cbcdd17d1b296 100644 --- a/man/marginal.probs.Rd +++ b/man/marginal.probs.Rd @@ -9,6 +9,17 @@ marginal.probs(models) \arguments{ \item{models}{The list of models to use.} } +\value{ +A numeric vector of marginal model probabilities based on relative frequencies of model visits in MCMC. +} \description{ Function for calculating marginal inclusion probabilities of features given a list of models } +\examples{ +result <- gmjmcmc(x = matrix(rnorm(600), 100), +y = matrix(rnorm(100), 100), +P = 2, +transforms = c("p0", "exp_dbl")) +marginal.probs(result$models[[1]]) + +} diff --git a/man/marginal.probs.renorm.Rd b/man/marginal.probs.renorm.Rd deleted file mode 100644 index be55d847ffab9e5d7c76c1af7ee537f033533f9f..0000000000000000000000000000000000000000 --- a/man/marginal.probs.renorm.Rd +++ /dev/null @@ -1,16 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/gmjmcmc_support.R -\name{marginal.probs.renorm} -\alias{marginal.probs.renorm} -\title{Function for calculating feature importance through renormalized model estimates} -\usage{ -marginal.probs.renorm(models, type = "features") -} -\arguments{ -\item{models}{The models to use.} - -\item{type}{Select which probabilities are of interest, features or models} -} -\description{ -Function for calculating feature importance through renormalized model estimates -} diff --git a/man/merge_results.Rd b/man/merge_results.Rd index 182dc4b8b4705100134870aa770fd313e57d80a3..32c10f606cfbb0c9880ad10d1371c36ea9b8ad82 100644 --- a/man/merge_results.Rd +++ b/man/merge_results.Rd @@ -3,7 +3,7 @@ \name{merge_results} \alias{merge_results} \title{Merge a list of multiple results from many runs -This function will weight the features based on the best mlik in that population +This function will weight the features based on the best marginal posterior in that population and merge the results together, simplifying by merging equivalent features (having high correlation).} \usage{ merge_results( @@ -15,20 +15,50 @@ merge_results( ) } \arguments{ -\item{results}{A list containing multiple results from GMJMCMC.} +\item{results}{A list containing multiple results from GMJMCMC (Genetically Modified MJMCMC).} \item{populations}{Which populations should be merged from the results, can be "all", "last" (default) or "best".} \item{complex.measure}{The complex measure to use when finding the simplest equivalent feature, 1=total width, 2=operation count and 3=depth.} -\item{tol}{The tolerance to use for the correlation when finding equivalent features, default is 0.} +\item{tol}{The tolerance to use for the correlation when finding equivalent features, default is 0.0000001} \item{data}{Data to use when comparing features, default is NULL meaning that mock data will be generated, if data is supplied it should be of the same form as is required by gmjmcmc, i.e. with both x, y and an intercept.} } +\value{ +An object of class "gmjmcmc_merged" containing the following elements: +\item{features}{The features where equivalent features are represented in their simplest form.} +\item{marg.probs}{Importance of features.} +\item{counts}{Counts of how many versions that were present of each feature.} +\item{results}{Results as they were passed to the function.} +\item{pop.best}{The population in the results which contained the model with the highest log marginal posterior.} +\item{thread.best}{The thread in the results which contained the model with the highest log marginal posterior.} +\item{crit.best}{The highest log marginal posterior for any model in the results.} +\item{reported}{The highest log marginal likelihood for the reported populations as defined in the populations argument.} +\item{rep.pop}{The index of the population which contains reported.} +\item{best.log.posteriors}{A matrix where the first column contains the population indices and the second column contains the model with the highest log marginal posterior within that population.} +\item{rep.thread}{The index of the thread which contains reported.} +} \description{ Merge a list of multiple results from many runs -This function will weight the features based on the best mlik in that population +This function will weight the features based on the best marginal posterior in that population and merge the results together, simplifying by merging equivalent features (having high correlation). } +\examples{ +result <- gmjmcmc.parallel( + runs = 1, + cores = 1, + y = matrix(rnorm(100), 100),x = matrix(rnorm(600), 100), + P = 2, + transforms = c("p0", "exp_dbl") +) + +summary(result) + +plot(result) + +merge_results(result$results) + +} diff --git a/man/mjmcmc.Rd b/man/mjmcmc.Rd index 29e3867e946ac57b945c5eaff65da1ad8a56ffac..fb95e0e5ed81fc494964b1b2bf914addadd81604 100644 --- a/man/mjmcmc.Rd +++ b/man/mjmcmc.Rd @@ -2,25 +2,67 @@ % Please edit documentation in R/mjmcmc.R \name{mjmcmc} \alias{mjmcmc} -\title{Main algorithm for MJMCMC} +\title{Main algorithm for MJMCMC (Genetically Modified MJMCMC)} \usage{ -mjmcmc(data, loglik.pi, N = 100, probs = NULL, params = NULL, sub = FALSE) +mjmcmc( + x, + y, + N = 1000, + probs = NULL, + params = NULL, + loglik.pi = NULL, + mlpost_params = list(family = "gaussian", beta_prior = list(type = "g-prior")), + intercept = TRUE, + fixed = 0, + sub = FALSE, + verbose = TRUE +) } \arguments{ -\item{data}{A matrix containing the data to use in the algorithm, -first column should be the dependent variable, second should be the intercept -and the rest of the columns should be the independent variables.} +\item{x}{matrix containing the design matrix with data to use in the algorithm,} -\item{loglik.pi}{The (log) density to explore} +\item{y}{response variable} -\item{N}{The number of iterations to run for} +\item{N}{The number of MJMCMC iterations to run for (default 100)} -\item{probs}{A list of the various probability vectors to use} +\item{probs}{A list of various probability vectors used by GMJMCMC, generated by \code{gen.probs.mjmcmc}.} -\item{params}{A list of the various parameters for all the parts of the algorithm} +\item{params}{A list of various parameter vectors used by MJMCMC, generated by \code{gen.params.mjmcmc}.} -\item{sub}{An indicator that if the likelihood is inexact and should be improved each model visit (EXPERIMENTAL!)} +\item{loglik.pi}{A function specifying the marginal log-posterior of the model up to a constant, including the logarithm of the model prior: +\eqn{\log p(M|Y) = \text{const} + \log p(Y|M) + \log p(M)}. +Typically assumes a Gaussian model with Zellner's g prior with \eqn{g = max(n,p^2) by default}.} + +\item{mlpost_params}{All parameters for the estimator function loglik.pi} + +\item{intercept}{Logical. Whether to include an intercept in the design matrix. Default is \code{TRUE}. No variable selection is performed on the intercept.} + +\item{fixed}{Integer specifying the number of leading columns in the design matrix to always include in the model. Default is 0.} + +\item{sub}{Logical. If \code{TRUE}, uses subsampling or a stochastic approximation approach to the likelihood rather than the full likelihood. Default is \code{FALSE}.} + +\item{verbose}{Logical. Whether to print messages during execution. Default is \code{TRUE} for \code{gmjmcmc} and \code{FALSE} for the parallel version.} +} +\value{ +A list containing the following elements: +\item{models}{All visited models in both mjmcmc and local optimization.} +\item{accept}{Average acceptance rate of the chain.} +\item{mc.models}{All models visited during mjmcmc iterations.} +\item{best.crit}{The highest log marginal probability of the visited models.} +\item{marg.probs}{Marginal probabilities of the features.} +\item{model.probs}{Marginal probabilities of all of the visited models.} +\item{model.probs.idx}{Indices of unique visited models.} +\item{populations}{The covariates represented as a list of features.} } \description{ -Main algorithm for MJMCMC +Main algorithm for MJMCMC (Genetically Modified MJMCMC) +} +\examples{ +result <- mjmcmc( +y = matrix(rnorm(100), 100), +x = matrix(rnorm(600), 100), +loglik.pi = gaussian.loglik) +summary(result) +plot(result) + } diff --git a/man/mjmcmc.loop.Rd b/man/mjmcmc.loop.Rd deleted file mode 100644 index 734ab3df2f3296e6bd025673da6409657873a5a1..0000000000000000000000000000000000000000 --- a/man/mjmcmc.loop.Rd +++ /dev/null @@ -1,32 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mjmcmc.R -\name{mjmcmc.loop} -\alias{mjmcmc.loop} -\title{The main loop for the MJMCMC algorithm, used in both MJMCMC and GMJMCMC} -\usage{ -mjmcmc.loop(data, complex, loglik.pi, model.cur, N, probs, params, sub = F) -} -\arguments{ -\item{data}{The data to use} - -\item{complex}{The complexity measures of the data} - -\item{loglik.pi}{The (log) density to explore} - -\item{model.cur}{The model to start the loop at} - -\item{N}{The number of iterations to run for} - -\item{probs}{A list of the various probability vectors to use} - -\item{params}{A list of the various parameters for all the parts of the algorithm} - -\item{sub}{An indicator that if the likelihood is inexact and should be improved each model visit (EXPERIMENTAL!)} -} -\value{ -A list containing the visited models, the models visited during local optimisation, -the acceptance count and the best critical value encountered. -} -\description{ -The main loop for the MJMCMC algorithm, used in both MJMCMC and GMJMCMC -} diff --git a/man/mjmcmc.parallel.Rd b/man/mjmcmc.parallel.Rd index f683dfd360177dff11bca81422818beb528c7738..f25fab99e9c93bc3c0bc24289c4e4ab8583b2428 100644 --- a/man/mjmcmc.parallel.Rd +++ b/man/mjmcmc.parallel.Rd @@ -4,14 +4,14 @@ \alias{mjmcmc.parallel} \title{Run multiple mjmcmc runs in parallel, merging the results before returning.} \usage{ -mjmcmc.parallel(runs, cores = getOption("mc.cores", 2L), ...) +mjmcmc.parallel(runs = 2, cores = getOption("mc.cores", 2L), ...) } \arguments{ \item{runs}{The number of runs to run} \item{cores}{The number of cores to run on} -\item{...}{Further params passed to mjmcmc.} +\item{...}{Further parameters passed to mjmcmc.} } \value{ Merged results from multiple mjmcmc runs @@ -19,3 +19,13 @@ Merged results from multiple mjmcmc runs \description{ Run multiple mjmcmc runs in parallel, merging the results before returning. } +\examples{ +result <- mjmcmc.parallel(runs = 1, +cores = 1, +loglik.pi = FBMS::gaussian.loglik, +y = matrix(rnorm(100), 100), +x = matrix(rnorm(600), 100)) +summary(result) +plot(result) + +} diff --git a/man/mjmcmc.prop.Rd b/man/mjmcmc.prop.Rd deleted file mode 100644 index 70b45593f3f6dfdcb7261a368d2d1959d8b2a791..0000000000000000000000000000000000000000 --- a/man/mjmcmc.prop.Rd +++ /dev/null @@ -1,37 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mjmcmc.R -\name{mjmcmc.prop} -\alias{mjmcmc.prop} -\title{Subalgorithm for generating a proposal and acceptance probability in (G)MJMCMC} -\usage{ -mjmcmc.prop( - data, - loglik.pi, - model.cur, - complex, - pip_estimate, - probs, - params, - visited.models = NULL -) -} -\arguments{ -\item{data}{The data to use in the algorithm} - -\item{loglik.pi}{The the (log) density to explore} - -\item{model.cur}{The current model to make the proposal respective to} - -\item{complex}{The complexity measures used when evaluating the marginal likelihood} - -\item{pip_estimate}{The current posterior inclusion probability estimate, used for proposals} - -\item{probs}{A list of the various probability vectors to use} - -\item{params}{A list of the various parameters for all the parts of the algorithm} - -\item{visited.models}{A list of the previously visited models to use when subsampling and avoiding recalculation} -} -\description{ -Subalgorithm for generating a proposal and acceptance probability in (G)MJMCMC -} diff --git a/man/model.string.Rd b/man/model.string.Rd index 67be8ad565718a1b6e081d26b0865d8b8bc2c6fd..d2769d1c34e4efce2d4d72fe50d2e47a55fc2478 100644 --- a/man/model.string.Rd +++ b/man/model.string.Rd @@ -15,6 +15,19 @@ model.string(model, features, link = "I", round = 2) \item{round}{Rounding error for the features in the printed format} } +\value{ +A character representation of a model +} \description{ Function to generate a function string for a model consisting of features } +\examples{ +result <- gmjmcmc(y = matrix(rnorm(100), 100), +x = matrix(rnorm(600), 100), +P = 2, transforms = c("p0", "exp_dbl")) +summary(result) +plot(result) +model.string(c(TRUE, FALSE, TRUE, FALSE, TRUE), result$populations[[1]]) +model.string(result$models[[1]][1][[1]]$model, result$populations[[1]]) + +} diff --git a/man/ngelu.Rd b/man/ngelu.Rd index bb5c88e752a6f86e684802fe75a353a236037114..dd40fde7b3fa35805f4614e9126beb92afe82f66 100644 --- a/man/ngelu.Rd +++ b/man/ngelu.Rd @@ -15,3 +15,7 @@ ngelu(x) \description{ Negative GELU function } +\examples{ +ngelu(2) + +} diff --git a/man/nhs.Rd b/man/nhs.Rd index 93d87af55ef930b0325c65f78698fa5769580f34..38f55b824bf3e4820714591dde93d61a95eb79b3 100644 --- a/man/nhs.Rd +++ b/man/nhs.Rd @@ -15,3 +15,7 @@ as.integer(x<0) \description{ negative heavy side function } +\examples{ +nhs(2) + +} diff --git a/man/not.Rd b/man/not.Rd index 6754bd1b97e79f0a4f6ed123ecdfef8a9cf9ac86..2b64fdab237c9ef8d03e3fd81561ea4d13ec1f15 100644 --- a/man/not.Rd +++ b/man/not.Rd @@ -15,3 +15,7 @@ not(x) \description{ not x } +\examples{ +not(TRUE) + +} diff --git a/man/nrelu.Rd b/man/nrelu.Rd index 040332843d96b656e2147d85dd4fb2a57cfeb44b..c5c67ef6f812e5283c338dd15ae581c401119621 100644 --- a/man/nrelu.Rd +++ b/man/nrelu.Rd @@ -4,20 +4,18 @@ \alias{nrelu} \title{negative ReLu function} \usage{ -nrelu(x) - nrelu(x) } \arguments{ \item{x}{The vector of values} } \value{ -max(x,0) - max(-x,0) } \description{ negative ReLu function +} +\examples{ +nrelu(2) -negative ReLu function } diff --git a/man/p0.Rd b/man/p0.Rd index ceb4e29898b6ce2f0589eb88d8afa9c14ee20b92..7e8ee101f555fe5a18deed01217aad36dbc0113a 100644 --- a/man/p0.Rd +++ b/man/p0.Rd @@ -15,3 +15,7 @@ log(abs(x) + .Machine$double.eps) \description{ p0 polynomial term } +\examples{ +p0(2) + +} diff --git a/man/p05.Rd b/man/p05.Rd index 9dcaad850c4f917d7dd2071b69762c013f6c15eb..015f509147a46c5ae9ea17d0e25e5dca76ded520 100644 --- a/man/p05.Rd +++ b/man/p05.Rd @@ -15,3 +15,7 @@ p05(x) \description{ p05 polynomial term } +\examples{ +p05(2) + +} diff --git a/man/p0p0.Rd b/man/p0p0.Rd index bc2a1535a64db2d3ead682308d6ff25bb0f629d4..2feca7821e631f70c74471b76ef3eac908eb3a7d 100644 --- a/man/p0p0.Rd +++ b/man/p0p0.Rd @@ -15,3 +15,7 @@ p0(x)*p0(x) \description{ p0p0 polynomial term } +\examples{ +p0p0(2) + +} diff --git a/man/p0p05.Rd b/man/p0p05.Rd index af225daef49909428d0d2c8342e28688f38a7967..a112bf286d25ca5c7ebd71f24f85e6014cc5a940 100644 --- a/man/p0p05.Rd +++ b/man/p0p05.Rd @@ -15,3 +15,7 @@ p0(x)*(abs(x)+.Machine$double.eps)^(0.5) \description{ p0p05 polynomial term } +\examples{ +p0p05(2) + +} diff --git a/man/p0p1.Rd b/man/p0p1.Rd index cdbfe797f15e81f058ea82ba7e6c65a3a7ef9509..6cdf4a876965dcee0aea27dae342002b66bba6e7 100644 --- a/man/p0p1.Rd +++ b/man/p0p1.Rd @@ -15,3 +15,7 @@ p0(x)*x \description{ p0p1 polynomial term } +\examples{ +p0p1(2) + +} diff --git a/man/p0p2.Rd b/man/p0p2.Rd index 10b00aca519d2a2e98b94a82480fa97b918789c9..941878aabe81d73f395e95d072b9b2c6cd10be93 100644 --- a/man/p0p2.Rd +++ b/man/p0p2.Rd @@ -15,3 +15,7 @@ p0(x)*x^(2) \description{ p0p2 polynomial term } +\examples{ +p0p2(2) + +} diff --git a/man/p0p3.Rd b/man/p0p3.Rd index 49c5037cc2a53a74b880913ac2640ac78d89caa6..812a1081f7c5a86783d473687f78198b1668fbd1 100644 --- a/man/p0p3.Rd +++ b/man/p0p3.Rd @@ -15,3 +15,7 @@ p0(x)*x^(3) \description{ p0p3 polynomial term } +\examples{ +p0p3(2) + +} diff --git a/man/p0pm05.Rd b/man/p0pm05.Rd index 0b08fb93070bbf04d9dcc1b80977c84f15773cf4..35c2510cf4db7cfd9737a60bab55f254f61c87fd 100644 --- a/man/p0pm05.Rd +++ b/man/p0pm05.Rd @@ -15,3 +15,7 @@ p0(x)\emph{sign(x)}(abs(x)+.Machine$double.eps)^(-0.5) \description{ p0pm05 polynomial term } +\examples{ +p0pm05(2) + +} diff --git a/man/p0pm1.Rd b/man/p0pm1.Rd index f27275e50a7ab3b00b6a78b69e88d7a774cb061d..ccc2230dfa2c6273cbe0e9ae683a9347d57fc60b 100644 --- a/man/p0pm1.Rd +++ b/man/p0pm1.Rd @@ -15,3 +15,7 @@ p0(x)*(x+.Machine$double.eps)^(-1) \description{ p0pm1 polynomial terms } +\examples{ +p0pm1(2) + +} diff --git a/man/p0pm2.Rd b/man/p0pm2.Rd index bab5edadc3c3e89c2f81a598de0d8aeb52e4cacc..d1daba14667e9efc25c205a8c491c459bc1a6e25 100644 --- a/man/p0pm2.Rd +++ b/man/p0pm2.Rd @@ -15,3 +15,7 @@ p0(x)\emph{sign(x)}(abs(x)+.Machine$double.eps)^(-2) \description{ p0pm2 polynomial term } +\examples{ +p0pm2(2) + +} diff --git a/man/p2.Rd b/man/p2.Rd index b25d140396039d8a53786a1d5ad15c7e76ccca31..c93781cf78c721f94cd147a64650b7792331ee7a 100644 --- a/man/p2.Rd +++ b/man/p2.Rd @@ -15,3 +15,7 @@ x^(2) \description{ p2 polynomial term } +\examples{ +p2(2) + +} diff --git a/man/p3.Rd b/man/p3.Rd index e5e0a78ebdd9ea17cf0c6f1d1e7b8133e7e7c338..0765d7a865f98b200ef85113b62e2980d4f19174 100644 --- a/man/p3.Rd +++ b/man/p3.Rd @@ -15,3 +15,7 @@ x^(3) \description{ p3 polynomial term } +\examples{ +p3(2) + +} diff --git a/man/plot.diagn.Rd b/man/plot.diagn.Rd deleted file mode 100644 index e3708a747bd6ad23f4ef2155c8b4ce98c19bb215..0000000000000000000000000000000000000000 --- a/man/plot.diagn.Rd +++ /dev/null @@ -1,25 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/diagnostics.R -\name{plot.diagn} -\alias{plot.diagn} -\title{Plot convergence of best/median/mean/other summary log posteriors in time} -\usage{ -\method{plot}{diagn}(res, FUN = median, conf = 0.95, burnin = 6, window = 5) -} -\arguments{ -\item{res}{Object corresponding gmjmcmc output} - -\item{FUN}{The summary statistics to check convergence} - -\item{conf}{which confidence intervals to plot} - -\item{burnin}{how many first populations to skip} - -\item{window}{sliding window for computing the standard deviation} -} -\value{ -summary statistics with given confidence intervals -} -\description{ -Plot convergence of best/median/mean/other summary log posteriors in time -} diff --git a/man/plot.gmjmcmc.Rd b/man/plot.gmjmcmc.Rd index 792750fdacd341c55262b85342cd8f948683feeb..8e0e88cca03bc15bcdd212a8181b6f00e0133881 100644 --- a/man/plot.gmjmcmc.Rd +++ b/man/plot.gmjmcmc.Rd @@ -5,7 +5,7 @@ \title{Function to plot the results, works both for results from gmjmcmc and merged results from merge.results} \usage{ -\method{plot}{gmjmcmc}(x, count = "all", pop = "last", ...) +\method{plot}{gmjmcmc}(x, count = "all", pop = "best", tol = 1e-07, data = NULL, ...) } \arguments{ \item{x}{The results to use} @@ -14,9 +14,25 @@ merged results from merge.results} \item{pop}{The population to plot, defaults to last} +\item{tol}{The tolerance to use for the correlation when finding equivalent features, default is 0.0000001} + +\item{data}{Data to merge on, important if pre-filtering was used} + \item{...}{Not used.} } +\value{ +No return value, just creates a plot +} \description{ Function to plot the results, works both for results from gmjmcmc and merged results from merge.results } +\examples{ +result <- gmjmcmc(y = matrix(rnorm(100), 100), +x = matrix(rnorm(600), 100), +P = 2, +transforms = c("p0", "exp_dbl")) +plot(result) + + +} diff --git a/man/plot.gmjmcmc_merged.Rd b/man/plot.gmjmcmc_merged.Rd index 3e4620a3503e6d32ef8b127ffc10fb7ade60e9a7..717fa76efb24f49d694fe47745966bddea7b1592 100644 --- a/man/plot.gmjmcmc_merged.Rd +++ b/man/plot.gmjmcmc_merged.Rd @@ -4,15 +4,36 @@ \alias{plot.gmjmcmc_merged} \title{Plot a gmjmcmc_merged run} \usage{ -\method{plot}{gmjmcmc_merged}(x, count = "all", ...) +\method{plot}{gmjmcmc_merged}(x, count = "all", pop = NULL, tol = 1e-07, data = NULL, ...) } \arguments{ \item{x}{The results to use} \item{count}{The number of features to plot, defaults to all} +\item{pop}{The population to plot, defaults to last} + +\item{tol}{The tolerance to use for the correlation when finding equivalent features, default is 0.0000001} + +\item{data}{Data to merge on, important if pre-filtering was used} + \item{...}{Not used.} } +\value{ +No return value, just creates a plot +} \description{ Plot a gmjmcmc_merged run } +\examples{ +result <- gmjmcmc.parallel( + runs = 1, + cores = 1, + y = matrix(rnorm(100), 100), + x = matrix(rnorm(600), 100), + P = 2, + transforms = c("p0", "exp_dbl") +) +plot(result) + +} diff --git a/man/plot.mjmcmc.Rd b/man/plot.mjmcmc.Rd index 6ee09c7792b25a27f1bcfc609ff553ca25a35d41..413cbcfb10e0efd6010169172cfeff1c0d881b8f 100644 --- a/man/plot.mjmcmc.Rd +++ b/man/plot.mjmcmc.Rd @@ -14,7 +14,18 @@ merged results from merge.results} \item{...}{Not used.} } +\value{ +No return value, just creates a plot +} \description{ Function to plot the results, works both for results from gmjmcmc and merged results from merge.results } +\examples{ +result <- mjmcmc( +y = matrix(rnorm(100), 100), +x = matrix(rnorm(600), 100), +loglik.pi = gaussian.loglik) +plot(result) + +} diff --git a/man/plot.mjmcmc_parallel.Rd b/man/plot.mjmcmc_parallel.Rd index 844dac1168319c28edc72be25f8eea3dcceb767c..0d9cafcf0511587e8d4741aaeb4593271770af3f 100644 --- a/man/plot.mjmcmc_parallel.Rd +++ b/man/plot.mjmcmc_parallel.Rd @@ -13,6 +13,18 @@ \item{...}{Not used.} } +\value{ +No return value, just creates a plot +} \description{ Plot a mjmcmc_parallel run } +\examples{ +result <- mjmcmc.parallel(runs = 1, +cores = 1, +y = matrix(rnorm(100), 100), +x = matrix(rnorm(600), 100), +loglik.pi = gaussian.loglik) +plot(result) + +} diff --git a/man/pm05.Rd b/man/pm05.Rd index 5fa201f74bbb8d1419ddbf5c0be7b90ad281d554..548e35981cb490142c7d7f97cd584b6cddcc8759 100644 --- a/man/pm05.Rd +++ b/man/pm05.Rd @@ -15,3 +15,7 @@ pm05(x) \description{ pm05 polynomial term } +\examples{ +pm05(2) + +} diff --git a/man/pm1.Rd b/man/pm1.Rd index d7b4aba2cb2323a53d08e2a629ad2c33cc405a4a..d58d4130fe0f31c12a9925bdff549114224c58d4 100644 --- a/man/pm1.Rd +++ b/man/pm1.Rd @@ -15,3 +15,7 @@ sign(x)*(abs(x)+.Machine$double.eps)^(-1) \description{ pm1 polynomial term } +\examples{ +pm1(2) + +} diff --git a/man/pm2.Rd b/man/pm2.Rd index d269314a4adf97a210c8db6ef8088507482d7550..397219a2b3c5686fee513469ff0016fdba953098 100644 --- a/man/pm2.Rd +++ b/man/pm2.Rd @@ -15,3 +15,7 @@ sign(x)*(abs(x)+.Machine$double.eps)^(-2) \description{ pm2 polynomial term } +\examples{ +pm2(2) + +} diff --git a/man/predict.bgnlm_model.Rd b/man/predict.bgnlm_model.Rd new file mode 100644 index 0000000000000000000000000000000000000000..3dd123ac1d7a284bfe186d98e347533a76ca9026 --- /dev/null +++ b/man/predict.bgnlm_model.Rd @@ -0,0 +1,58 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/predict.R +\name{predict.bgnlm_model} +\alias{predict.bgnlm_model} +\title{Predict responses from a BGNLM model} +\usage{ +\method{predict}{bgnlm_model}( + object, + x, + link = function(x) { + x + }, + x_train = NULL, + ... +) +} +\arguments{ +\item{object}{A fitted \code{bgnlm_model} object obtained from the BGNLM fitting procedure. +It should contain the estimated coefficients in \code{model$coefs}.} + +\item{x}{A \code{data.frame} containing the new data for which predictions are to be made. +The variables in \code{x} must match the features used in the model.} + +\item{link}{A link function to apply to the linear predictor. +By default, it is the identity function \code{function(x)\{x\}}, +but it can be any function such as \code{plogis} for logistic regression models.} + +\item{x_train}{Training design matrix to be provided when imputations are to be made from them} + +\item{...}{Additional arguments to pass to prediction function.} +} +\value{ +A numeric vector of predicted values for the given data \code{x}. +These predictions are calculated as \eqn{\hat{y} = \text{link}(X \beta)}, +where \eqn{X} is the design matrix and \eqn{\beta} are the model coefficients. +} +\description{ +This function generates predictions from a fitted \code{bgnlm_model} object given a new dataset. +} +\examples{ +\dontrun{ +# Example with simulated data +set.seed(123) +x_train <- data.frame(PlanetaryMassJpt = rnorm(100), RadiusJpt = rnorm(100)) +model <- list( + coefs = c(Intercept = -0.5, PlanetaryMassJpt = 0.2, RadiusJpt = -0.1), + class = "bgnlm_model" +) +class(model) <- "bgnlm_model" + +# New data for prediction +x_new <- data.frame(PlanetaryMassJpt = c(0.1, -0.3), RadiusJpt = c(0.2, -0.1)) + +# Predict using the identity link (default) +preds <- predict.bgnlm_model(model, x_new) +} + +} diff --git a/man/predict.gmjmcmc.2.Rd b/man/predict.gmjmcmc.2.Rd deleted file mode 100644 index 465726d8e5782d9a8f2bc249343fca8049783ce0..0000000000000000000000000000000000000000 --- a/man/predict.gmjmcmc.2.Rd +++ /dev/null @@ -1,33 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/predict.R -\name{predict.gmjmcmc.2} -\alias{predict.gmjmcmc.2} -\title{New idea for a more streamlined function... -Produces slightly different results from the fun above since this is using all lo.models too.} -\usage{ -\method{predict}{gmjmcmc.2}( - object, - x, - link = function(x) x, - quantiles = c(0.025, 0.5, 0.975), - pop = 1, - ... -) -} -\arguments{ -\item{object}{The model to use.} - -\item{x}{The new data to use for the prediction, a matrix where each row is an observation.} - -\item{link}{The link function to use} - -\item{quantiles}{The quantiles to calculate credible intervals for the posterior moddes (in model space).} - -\item{pop}{The population to use.} - -\item{...}{Not used.} -} -\description{ -New idea for a more streamlined function... -Produces slightly different results from the fun above since this is using all lo.models too. -} diff --git a/man/predict.gmjmcmc.Rd b/man/predict.gmjmcmc.Rd new file mode 100644 index 0000000000000000000000000000000000000000..c0626127cf257a50df3835dfb3a17146a2b5e4a3 --- /dev/null +++ b/man/predict.gmjmcmc.Rd @@ -0,0 +1,53 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/predict.R +\name{predict.gmjmcmc} +\alias{predict.gmjmcmc} +\title{Predict using a gmjmcmc result object.} +\usage{ +\method{predict}{gmjmcmc}( + object, + x, + link = function(x) x, + quantiles = c(0.025, 0.5, 0.975), + pop = NULL, + tol = 1e-07, + x_train = NULL, + ... +) +} +\arguments{ +\item{object}{The model to use.} + +\item{x}{The new data to use for the prediction, a matrix where each row is an observation.} + +\item{link}{The link function to use} + +\item{quantiles}{The quantiles to calculate credible intervals for the posterior modes (in model space).} + +\item{pop}{The population to plot, defaults to last} + +\item{tol}{The tolerance to use for the correlation when finding equivalent features, default is 0.0000001} + +\item{x_train}{Training design matrix to be provided when imputations are to be made from them} + +\item{...}{Not used.} +} +\value{ +A list containing aggregated predictions and per model predictions. +\item{aggr}{Aggregated predictions with mean and quantiles.} +\item{preds}{A list of lists containing individual predictions per model per population in object.} +} +\description{ +Predict using a gmjmcmc result object. +} +\examples{ +result <- gmjmcmc( + x = matrix(rnorm(600), 100), + y = matrix(rnorm(100), 100), + P = 2, + transforms = c("p0", "exp_dbl") +) +preds <- predict(result, matrix(rnorm(600), 100)) + + +} diff --git a/man/predict.gmjmcmc_merged.Rd b/man/predict.gmjmcmc_merged.Rd index 1408f87a42ae5188863b433dee054f15ae3b0c0a..2d8a093b442da40e72ed0ac2b1c1fca1aa5fd723 100644 --- a/man/predict.gmjmcmc_merged.Rd +++ b/man/predict.gmjmcmc_merged.Rd @@ -2,9 +2,18 @@ % Please edit documentation in R/predict.R \name{predict.gmjmcmc_merged} \alias{predict.gmjmcmc_merged} -\title{Predict using a BGNLM model.} +\title{Predict using a merged gmjmcmc result object.} \usage{ -\method{predict}{gmjmcmc_merged}(object, x, link = function(x) x, quantiles = c(0.025, 0.5, 0.975), ...) +\method{predict}{gmjmcmc_merged}( + object, + x, + link = function(x) x, + quantiles = c(0.025, 0.5, 0.975), + pop = NULL, + tol = 1e-07, + x_train = NULL, + ... +) } \arguments{ \item{object}{The model to use.} @@ -13,10 +22,33 @@ \item{link}{The link function to use} -\item{quantiles}{The quantiles to calculate credible intervals for the posterior moddes (in model space).} +\item{quantiles}{The quantiles to calculate credible intervals for the posterior modes (in model space).} + +\item{pop}{The population to plot, defaults to last} + +\item{tol}{The tolerance to use for the correlation when finding equivalent features, default is 0.0000001} + +\item{x_train}{Training design matrix to be provided when imputations are to be made from them} \item{...}{Not used.} } +\value{ +A list containing aggregated predictions and per model predictions. +\item{aggr}{Aggregated predictions with mean and quantiles.} +\item{preds}{A list of lists containing individual predictions per model per population in object.} +} \description{ -Predict using a BGNLM model. +Predict using a merged gmjmcmc result object. +} +\examples{ +result <- gmjmcmc.parallel( + runs = 1, + cores = 1, + x = matrix(rnorm(600), 100), + y = matrix(rnorm(100), 100), + P = 2, + transforms = c("p0", "exp_dbl") +) +preds <- predict(result, matrix(rnorm(600), 100)) + } diff --git a/man/predict.gmjmcmc_parallel.Rd b/man/predict.gmjmcmc_parallel.Rd new file mode 100644 index 0000000000000000000000000000000000000000..dbda433148c121cf76071b6c118df1e2d0826075 --- /dev/null +++ b/man/predict.gmjmcmc_parallel.Rd @@ -0,0 +1,48 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/predict.R +\name{predict.gmjmcmc_parallel} +\alias{predict.gmjmcmc_parallel} +\title{Predict using a gmjmcmc result object from a parallel run.} +\usage{ +\method{predict}{gmjmcmc_parallel}( + object, + x, + link = function(x) x, + quantiles = c(0.025, 0.5, 0.975), + x_train = NULL, + ... +) +} +\arguments{ +\item{object}{The model to use.} + +\item{x}{The new data to use for the prediction, a matrix where each row is an observation.} + +\item{link}{The link function to use} + +\item{quantiles}{The quantiles to calculate credible intervals for the posterior modes (in model space).} + +\item{x_train}{Training design matrix to be provided when imputations are to be made from them} + +\item{...}{Additional arguments to pass to merge_results.} +} +\value{ +A list containing aggregated predictions and per model predictions. +\item{aggr}{Aggregated predictions with mean and quantiles.} +\item{preds}{A list of lists containing individual predictions per model per population in object.} +} +\description{ +Predict using a gmjmcmc result object from a parallel run. +} +\examples{ +result <- gmjmcmc.parallel( + runs = 1, + cores = 1, + x = matrix(rnorm(600), 100), + y = matrix(rnorm(100), 100), + P = 2, + transforms = c("p0", "exp_dbl") +) +preds <- predict(result, matrix(rnorm(600), 100)) + +} diff --git a/man/predict.mjmcmc.Rd b/man/predict.mjmcmc.Rd new file mode 100644 index 0000000000000000000000000000000000000000..f18b763fc0ad61f3b4488d278e47ccb62e381ae8 --- /dev/null +++ b/man/predict.mjmcmc.Rd @@ -0,0 +1,44 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/predict.R +\name{predict.mjmcmc} +\alias{predict.mjmcmc} +\title{Predict using a mjmcmc result object.} +\usage{ +\method{predict}{mjmcmc}( + object, + x, + link = function(x) x, + quantiles = c(0.025, 0.5, 0.975), + x_train = NULL, + ... +) +} +\arguments{ +\item{object}{The model to use.} + +\item{x}{The new data to use for the prediction, a matrix where each row is an observation.} + +\item{link}{The link function to use} + +\item{quantiles}{The quantiles to calculate credible intervals for the posterior modes (in model space).} + +\item{x_train}{Training design matrix to be provided when imputations are to be made from them} + +\item{...}{Not used.} +} +\value{ +A list containing aggregated predictions. +\item{mean}{Mean of aggregated predictions.} +\item{quantiles}{Quantiles of aggregated predictions.} +} +\description{ +Predict using a mjmcmc result object. +} +\examples{ +result <- mjmcmc( +x = matrix(rnorm(600), 100), +y = matrix(rnorm(100), 100), +loglik.pi = gaussian.loglik) +preds <- predict(result, matrix(rnorm(600), 100)) + +} diff --git a/man/predict.mjmcmc_parallel.Rd b/man/predict.mjmcmc_parallel.Rd new file mode 100644 index 0000000000000000000000000000000000000000..568673e2dd04cc92987d9ea223edb77f195fa47a --- /dev/null +++ b/man/predict.mjmcmc_parallel.Rd @@ -0,0 +1,45 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/predict.R +\name{predict.mjmcmc_parallel} +\alias{predict.mjmcmc_parallel} +\title{Predict using a mjmcmc result object from a parallel run.} +\usage{ +\method{predict}{mjmcmc_parallel}( + object, + x, + link = function(x) x, + quantiles = c(0.025, 0.5, 0.975), + x_train = NULL, + ... +) +} +\arguments{ +\item{object}{The model to use.} + +\item{x}{The new data to use for the prediction, a matrix where each row is an observation.} + +\item{link}{The link function to use} + +\item{quantiles}{The quantiles to calculate credible intervals for the posterior modes (in model space).} + +\item{x_train}{Training design matrix to be provided when imputations are to be made from them} + +\item{...}{Not used.} +} +\value{ +A list containing aggregated predictions. +\item{mean}{Mean of aggregated predictions.} +\item{quantiles}{Quantiles of aggregated predictions.} +} +\description{ +Predict using a mjmcmc result object from a parallel run. +} +\examples{ +result <- mjmcmc.parallel(runs = 1, +cores = 1, +x = matrix(rnorm(600), 100), +y = matrix(rnorm(100), 100), +loglik.pi = gaussian.loglik) +preds <- predict(result, matrix(rnorm(600), 100)) + +} diff --git a/man/print.feature.Rd b/man/print.feature.Rd index 7731aab89659738cc860001dd9f825153d58d484..4ad803c214a05310d271bb77d95fc8e09e3562c2 100644 --- a/man/print.feature.Rd +++ b/man/print.feature.Rd @@ -4,13 +4,23 @@ \alias{print.feature} \title{Print method for "feature" class} \usage{ -\method{print}{feature}(x, dataset = FALSE, alphas = FALSE, labels = FALSE, round = FALSE, ...) +\method{print}{feature}( + x, + dataset = FALSE, + fixed = 0, + alphas = FALSE, + labels = FALSE, + round = FALSE, + ... +) } \arguments{ \item{x}{An object of class "feature"} \item{dataset}{Set the regular covariates as columns in a dataset} +\item{fixed}{How many of the first columns in dataset are fixed and do not contribute to variable selection} + \item{alphas}{Print a "?" instead of actual alphas to prepare the output for alpha estimation} \item{labels}{Should the covariates be named, or just referred to as their place in the data.frame.} @@ -19,6 +29,17 @@ \item{...}{Not used.} } +\value{ +String representation of a feature +} \description{ Print method for "feature" class } +\examples{ +result <- gmjmcmc(x = matrix(rnorm(600), 100), +y = matrix(rnorm(100), 100), +P = 2, +transforms = c("p0", "exp_dbl")) +print(result$populations[[1]][1]) + +} diff --git a/man/relu.Rd b/man/relu.Rd index 8229a82ebf25ab745cf661f03f1b5266fb316c07..4096fa98db8988e5b2c31f382a2256b086cb9025 100644 --- a/man/relu.Rd +++ b/man/relu.Rd @@ -15,3 +15,7 @@ max(x,0) \description{ ReLu function } +\examples{ +relu(2) + +} diff --git a/man/rmclapply.Rd b/man/rmclapply.Rd new file mode 100644 index 0000000000000000000000000000000000000000..57b10f3b47d13779f6b58116c59efbfe48310142 --- /dev/null +++ b/man/rmclapply.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/parallel.R +\name{rmclapply} +\alias{rmclapply} +\title{rmclapply: Cross-platform mclapply/forking hack for Windows} +\usage{ +rmclapply(runs, args, fun, mc.cores = NULL) +} +\arguments{ +\item{runs}{The runs to run} + +\item{args}{The arguments to pass to fun} + +\item{fun}{The function to run} + +\item{mc.cores}{Number of cores to use for parallel processing. Defaults to \code{detectCores()}.} +} +\value{ +A list of results, with one element for each element of \code{X}. +} +\description{ +This function applies a function in parallel to a list or vector (\code{X}) using multiple cores. +On Linux/macOS, it uses \code{mclapply}, while on Windows it uses a hackish version of parallelism. +The Windows version is based on \code{parLapply} to mimic forking following Nathan VanHoudnos. +} diff --git a/man/set.transforms.Rd b/man/set.transforms.Rd index a14b0832852fb7fe5d4f0a2be75f064505d51422..9e8ce183db980eef26dbc325853283f909ec6d65 100644 --- a/man/set.transforms.Rd +++ b/man/set.transforms.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/gmjmcmc_support.R \name{set.transforms} \alias{set.transforms} -\title{Set the transformations option for GMJMCMC, +\title{Set the transformations option for GMJMCMC (Genetically Modified MJMCMC), this is also done when running the algorithm, but this function allows for it to be done manually.} \usage{ set.transforms(transforms) @@ -10,7 +10,15 @@ set.transforms(transforms) \arguments{ \item{transforms}{The vector of non-linear transformations} } +\value{ +No return value, just sets the gmjmcmc-transformations option +} \description{ -Set the transformations option for GMJMCMC, +Set the transformations option for GMJMCMC (Genetically Modified MJMCMC), this is also done when running the algorithm, but this function allows for it to be done manually. } +\examples{ +set.transforms(c("p0","p1")) + + +} diff --git a/man/sigmoid.Rd b/man/sigmoid.Rd index 56e917306a0efa1d6c402539f3544e19153f87b2..62605873e7232f08f0f87d246c1f9bb1c91c6d6e 100644 --- a/man/sigmoid.Rd +++ b/man/sigmoid.Rd @@ -15,3 +15,8 @@ The sigmoid of x \description{ Sigmoid function } +\examples{ +sigmoid(2) + + +} diff --git a/man/sin.rad.Rd b/man/sin_deg.Rd similarity index 79% rename from man/sin.rad.Rd rename to man/sin_deg.Rd index 930b9d016784aced0a7a145313a80e44c0bc1185..6c560630f2839b7123c4d16b607816b4577c67f8 100644 --- a/man/sin.rad.Rd +++ b/man/sin_deg.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/nonlinear_functions.R -\name{sin.rad} -\alias{sin.rad} +\name{sin_deg} +\alias{sin_deg} \title{Sine function for degrees} \usage{ -\method{sin}{rad}(x) +sin_deg(x) } \arguments{ \item{x}{The vector of values in degrees} @@ -15,3 +15,7 @@ The sine of x \description{ Sine function for degrees } +\examples{ +sin_deg(0) + +} diff --git a/man/sqroot.Rd b/man/sqroot.Rd index f49609226c17abaaa443d578d6d06b0914cf2581..cb52cf7894ce18bc4604f7c33ab2279776dfcaf3 100644 --- a/man/sqroot.Rd +++ b/man/sqroot.Rd @@ -15,3 +15,7 @@ The square root of the absolute value of x \description{ Square root function } +\examples{ +sqroot(4) + +} diff --git a/man/string.population.Rd b/man/string.population.Rd index 9529872c968ca1a003accab54c2dfd78118fab77..fb6c21bc66790e25985f05e08ddb4a601f2d6af0 100644 --- a/man/string.population.Rd +++ b/man/string.population.Rd @@ -2,8 +2,7 @@ % Please edit documentation in R/results.R \name{string.population} \alias{string.population} -\title{Function to get a character respresentation of a list of features -A list or a population of features in a character representation} +\title{Function to get a character representation of a list of features} \usage{ string.population(x, round = 2) } @@ -12,7 +11,17 @@ string.population(x, round = 2) \item{round}{Rounding precision for parameters of the features} } +\value{ +A matrix of character representations of the features of a model. +} \description{ -Function to get a character respresentation of a list of features -A list or a population of features in a character representation +Function to get a character representation of a list of features +} +\examples{ +result <- gmjmcmc(y = matrix(rnorm(100), 100), +x = matrix(rnorm(600), 100), +P = 2, +transforms = c("p0", "exp_dbl")) +string.population(result$populations[[1]]) + } diff --git a/man/string.population.models.Rd b/man/string.population.models.Rd index 88e2f6d9d3320943e4bab05eb4d34db81d9aa748..f287ac7879f2c9a7d43b17fcbbe882ac020ee84b 100644 --- a/man/string.population.models.Rd +++ b/man/string.population.models.Rd @@ -2,8 +2,7 @@ % Please edit documentation in R/results.R \name{string.population.models} \alias{string.population.models} -\title{Function to get a character respresentation of a list of models -A list of models in a character representation} +\title{Function to get a character representation of a list of models} \usage{ string.population.models(features, models, round = 2, link = "I") } @@ -16,7 +15,17 @@ string.population.models(features, models, round = 2, link = "I") \item{link}{The link function to use, as a string} } +\value{ +A matrix of character representations of a list of models. +} \description{ -Function to get a character respresentation of a list of models -A list of models in a character representation +Function to get a character representation of a list of models +} +\examples{ +result <- gmjmcmc(y = matrix(rnorm(100), 100), +x = matrix(rnorm(600), 100), +P = 2, +transforms = c("p0", "exp_dbl")) +string.population.models(result$populations[[2]], result$models[[2]]) + } diff --git a/man/summary.gmjmcmc.Rd b/man/summary.gmjmcmc.Rd index 92e53d29e14149ef6df04397d0d20d0df45e4291..bc1d172e4359adc284a9401a8e7b9725458d2232 100644 --- a/man/summary.gmjmcmc.Rd +++ b/man/summary.gmjmcmc.Rd @@ -1,10 +1,19 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/results.R +% Please edit documentation in R/summary.R \name{summary.gmjmcmc} \alias{summary.gmjmcmc} \title{Function to print a quick summary of the results} \usage{ -\method{summary}{gmjmcmc}(object, pop = "last", tol = 1e-04, labels = F, ...) +\method{summary}{gmjmcmc}( + object, + pop = "best", + tol = 1e-04, + labels = FALSE, + effects = NULL, + data = NULL, + verbose = TRUE, + ... +) } \arguments{ \item{object}{The results to use} @@ -15,8 +24,27 @@ \item{labels}{Should the covariates be named, or just referred to as their place in the data.frame.} +\item{effects}{Quantiles for posterior modes of the effects across models to be reported, if either effects are NULL or if labels are NULL, no effects are reported.} + +\item{data}{Data to merge on, important if pre-filtering was used} + +\item{verbose}{If the summary should be printed to the console or just returned, defaults to TRUE} + \item{...}{Not used.} } +\value{ +A data frame containing the following columns: +\item{feats.strings}{Character representation of the features ordered by marginal probabilities.} +\item{marg.probs}{Marginal probabilities corresponding to the ordered feature strings.} +} \description{ Function to print a quick summary of the results } +\examples{ +result <- gmjmcmc(y = matrix(rnorm(100), 100), +x = matrix(rnorm(600), 100), +P = 2, +transforms = c("p0", "exp_dbl")) +summary(result, pop = "best") + +} diff --git a/man/summary.gmjmcmc_merged.Rd b/man/summary.gmjmcmc_merged.Rd index 20fb4e95064a624cb0f0f6137a5c10bf3b885a2d..855cc3f4cfc60c365bcf25f3c5ca2f5b77ab0591 100644 --- a/man/summary.gmjmcmc_merged.Rd +++ b/man/summary.gmjmcmc_merged.Rd @@ -1,10 +1,19 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/results.R +% Please edit documentation in R/summary.R \name{summary.gmjmcmc_merged} \alias{summary.gmjmcmc_merged} \title{Function to print a quick summary of the results} \usage{ -\method{summary}{gmjmcmc_merged}(object, tol = 1e-04, labels = F, ...) +\method{summary}{gmjmcmc_merged}( + object, + tol = 1e-04, + labels = FALSE, + effects = NULL, + pop = NULL, + data = NULL, + verbose = TRUE, + ... +) } \arguments{ \item{object}{The results to use} @@ -13,8 +22,33 @@ \item{labels}{Should the covariates be named, or just referred to as their place in the data.frame.} +\item{effects}{Quantiles for posterior modes of the effects across models to be reported, if either effects are NULL or if labels are NULL, no effects are reported.} + +\item{pop}{If null same as in merge.options for running parallel gmjmcmc otherwise results will be re-merged according to pop that can be "all", "last", "best"} + +\item{data}{Data to merge on, important if pre-filtering was used} + +\item{verbose}{If the summary should be printed to the console or just returned, defaults to TRUE} + \item{...}{Not used.} } +\value{ +A data frame containing the following columns: +\item{feats.strings}{Character representation of the features ordered by marginal probabilities.} +\item{marg.probs}{Marginal probabilities corresponding to the ordered feature strings.} +} \description{ Function to print a quick summary of the results } +\examples{ +result <- gmjmcmc.parallel( + runs = 1, + cores = 1, + y = matrix(rnorm(100), 100), + x = matrix(rnorm(600), 100), + P = 2, + transforms = c("p0", "exp_dbl") +) +summary(result) + +} diff --git a/man/summary.mjmcmc.Rd b/man/summary.mjmcmc.Rd index c1127cc70b1e18cad709a6b2d791c940d7680e05..f9771b27087888bafc1f8b21a8b4fd078ce7f6ea 100644 --- a/man/summary.mjmcmc.Rd +++ b/man/summary.mjmcmc.Rd @@ -1,18 +1,43 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/results.R +% Please edit documentation in R/summary.R \name{summary.mjmcmc} \alias{summary.mjmcmc} \title{Function to print a quick summary of the results} \usage{ -\method{summary}{mjmcmc}(object, tol = 1e-04, ...) +\method{summary}{mjmcmc}( + object, + tol = 1e-04, + labels = FALSE, + effects = NULL, + verbose = TRUE, + ... +) } \arguments{ \item{object}{The results to use} \item{tol}{The tolerance to use as a threshold when reporting the results.} +\item{labels}{Should the covariates be named, or just referred to as their place in the data.frame.} + +\item{effects}{Quantiles for posterior modes of the effects across models to be reported, if either effects are NULL or if labels are NULL, no effects are reported.} + +\item{verbose}{If the summary should be printed to the console or just returned, defaults to TRUE} + \item{...}{Not used.} } +\value{ +A data frame containing the following columns: +\item{feats.strings}{Character representation of the covariates ordered by marginal probabilities.} +\item{marg.probs}{Marginal probabilities corresponding to the ordered feature strings.} +} \description{ Function to print a quick summary of the results } +\examples{ +result <- mjmcmc(y = matrix(rnorm(100), 100), +x = matrix(rnorm(600), 100), +loglik.pi = gaussian.loglik) +summary(result) + +} diff --git a/man/summary.mjmcmc_parallel.Rd b/man/summary.mjmcmc_parallel.Rd index 3911a6c3710e15d4720da788c04e4d779e346560..1886745cc3e155d2c26396b426ed222ea34e548d 100644 --- a/man/summary.mjmcmc_parallel.Rd +++ b/man/summary.mjmcmc_parallel.Rd @@ -1,10 +1,17 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/results.R +% Please edit documentation in R/summary.R \name{summary.mjmcmc_parallel} \alias{summary.mjmcmc_parallel} \title{Function to print a quick summary of the results} \usage{ -\method{summary}{mjmcmc_parallel}(object, tol = 1e-04, labels = F, ...) +\method{summary}{mjmcmc_parallel}( + object, + tol = 1e-04, + labels = FALSE, + effects = NULL, + verbose = TRUE, + ... +) } \arguments{ \item{object}{The results to use} @@ -13,8 +20,26 @@ \item{labels}{Should the covariates be named, or just referred to as their place in the data.frame.} +\item{effects}{Quantiles for posterior modes of the effects across models to be reported, if either effects are NULL or if labels are NULL, no effects are reported.} + +\item{verbose}{If the summary should be printed to the console or just returned, defaults to TRUE} + \item{...}{Not used.} } +\value{ +A data frame containing the following columns: +\item{feats.strings}{Character representation of the covariates ordered by marginal probabilities.} +\item{marg.probs}{Marginal probabilities corresponding to the ordered feature strings.} +} \description{ Function to print a quick summary of the results } +\examples{ +result <- mjmcmc.parallel(runs = 1, +cores = 1, +y = matrix(rnorm(100), 100), +x = matrix(rnorm(600), 100), +loglik.pi = gaussian.loglik) +summary(result) + +} diff --git a/man/to23.Rd b/man/to23.Rd deleted file mode 100644 index a178f866de262bc764151ef11deda0ed663543ae..0000000000000000000000000000000000000000 --- a/man/to23.Rd +++ /dev/null @@ -1,17 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/nonlinear_functions.R -\name{to23} -\alias{to23} -\title{To the 2.3 power function} -\usage{ -to23(x) -} -\arguments{ -\item{x}{The vector of values} -} -\value{ -x^2.3 -} -\description{ -To the 2.3 power function -} diff --git a/man/to25.Rd b/man/to25.Rd deleted file mode 100644 index ec77494311598a19e489c84d3092d0c2efff63c9..0000000000000000000000000000000000000000 --- a/man/to25.Rd +++ /dev/null @@ -1,17 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/nonlinear_functions.R -\name{to25} -\alias{to25} -\title{To 2.5 power} -\usage{ -to25(x) -} -\arguments{ -\item{x}{The vector of values} -} -\value{ -x^(2.5) -} -\description{ -To 2.5 power -} diff --git a/man/to72.Rd b/man/to72.Rd deleted file mode 100644 index 28293e94c1f69445e4c56341468eb5fb90ea131d..0000000000000000000000000000000000000000 --- a/man/to72.Rd +++ /dev/null @@ -1,17 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/nonlinear_functions.R -\name{to72} -\alias{to72} -\title{To the 7/2 power function} -\usage{ -to72(x) -} -\arguments{ -\item{x}{The vector of values} -} -\value{ -x^(7/2) -} -\description{ -To the 7/2 power function -} diff --git a/man/troot.Rd b/man/troot.Rd index a873e6d41a6873abad6ef65b3e246c9db8679875..ae90fa8d8181a33431f68c4a9e2d17010c97f919 100644 --- a/man/troot.Rd +++ b/man/troot.Rd @@ -15,3 +15,7 @@ The cube root of x \description{ Cube root function } +\examples{ +troot(27) + +} diff --git a/man/update.alphas.Rd b/man/update.alphas.Rd deleted file mode 100644 index ea566972f76a79238729425a7085ba5c3dcfe390..0000000000000000000000000000000000000000 --- a/man/update.alphas.Rd +++ /dev/null @@ -1,18 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/feature.R -\name{update.alphas} -\alias{update.alphas} -\title{Update alphas on a feature} -\usage{ -\method{update}{alphas}(feature, alphas, recurse = FALSE) -} -\arguments{ -\item{feature}{The feature to be updated} - -\item{alphas}{The alphas that will be used} - -\item{recurse}{If we are recursing, to note the number of alphas used} -} -\description{ -Update alphas on a feature -} diff --git a/man/weighted.quantiles.Rd b/man/weighted.quantiles.Rd deleted file mode 100644 index 1901bb1198d8ac9bb22f66293a820420ce3222cd..0000000000000000000000000000000000000000 --- a/man/weighted.quantiles.Rd +++ /dev/null @@ -1,21 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/predict.R -\name{weighted.quantiles} -\alias{weighted.quantiles} -\title{Calculate weighted quantiles} -\usage{ -weighted.quantiles(values, weights, prob = c(0.025, 0.975)) -} -\arguments{ -\item{values}{The values to use} - -\item{weights}{The weights of the values} - -\item{prob}{The probabilities of the quantiles to use} -} -\value{ -Weighted quantiles -} -\description{ -Calculate weighted quantiles -} diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp index 115e8c552546e7ae89ccb45b948fa1c2c61b0dab..4c4a0cdd5e7a603024a5d27da42452cd21dd3fc0 100644 --- a/src/RcppExports.cpp +++ b/src/RcppExports.cpp @@ -12,7 +12,7 @@ Rcpp::Rostream& Rcpp::Rcerr = Rcpp::Rcpp_cerr_get(); // set_alphas List set_alphas(std::string formula); -RcppExport SEXP _GMJMCMC_set_alphas(SEXP formulaSEXP) { +RcppExport SEXP _FBMS_set_alphas(SEXP formulaSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; @@ -23,7 +23,7 @@ END_RCPP } // vec_in_mat int vec_in_mat(NumericMatrix& mat, NumericVector& vec, int firstCol, int lastCol); -RcppExport SEXP _GMJMCMC_vec_in_mat(SEXP matSEXP, SEXP vecSEXP, SEXP firstColSEXP, SEXP lastColSEXP) { +RcppExport SEXP _FBMS_vec_in_mat(SEXP matSEXP, SEXP vecSEXP, SEXP firstColSEXP, SEXP lastColSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; @@ -37,12 +37,12 @@ END_RCPP } static const R_CallMethodDef CallEntries[] = { - {"_GMJMCMC_set_alphas", (DL_FUNC) &_GMJMCMC_set_alphas, 1}, - {"_GMJMCMC_vec_in_mat", (DL_FUNC) &_GMJMCMC_vec_in_mat, 4}, + {"_FBMS_set_alphas", (DL_FUNC) &_FBMS_set_alphas, 1}, + {"_FBMS_vec_in_mat", (DL_FUNC) &_FBMS_vec_in_mat, 4}, {NULL, NULL, 0} }; -RcppExport void R_init_GMJMCMC(DllInfo *dll) { +RcppExport void R_init_FBMS(DllInfo *dll) { R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); R_useDynamicSymbols(dll, FALSE); } diff --git a/tests/testthat.R b/tests/testthat.R index 4fa4c9dea4c063d3587a429842dda61a264a0dd2..4e707ce0986456101f262bcf1423451c6358e277 100644 --- a/tests/testthat.R +++ b/tests/testthat.R @@ -1,4 +1,4 @@ library(testthat) -library(GMJMCMC) +library(FBMS) -test_check("GMJMCMC") +test_check("FBMS") diff --git a/tests/testthat/test_fbms.R b/tests/testthat/test_fbms.R new file mode 100644 index 0000000000000000000000000000000000000000..6a2935b555ec1ac95ac4bb096b7cf1c81848e084 --- /dev/null +++ b/tests/testthat/test_fbms.R @@ -0,0 +1,104 @@ +# Title : General tests +# Objective : Test the code +# Created by: jonlachmann +# Created on: 2021-02-25 + +context("MJMCMC") + +test_that("Test (G)MJMCMC through the fbms function", { + RNGkind("L'Ecuyer-CMRG") + set.seed(123) + x <- matrix(rnorm(300), 100) + y <- rnorm(100, 0, 0.5) + rowSums(x[, 1:2]) + y_shift <- y + 10 + y_sin <- rnorm(100, 0, 0.05) + sin(x[, 1]) * 3 + sin(x[, 2]) * 2 + y_sin_shift <- y_sin + 10 + + expect_true(length(y_sin) == 100) + + validate.model <- function (model, x, y) { + expect_true(all(c(model$marg.probs[1:2] > 0.9, model$marg.probs[3] < 0.9))) + summary <- summary(model, labels = c("a", "b", "c"), tol = -1) + expect_true(all(c(summary$marg.probs[1:2] > 0.9, summary$marg.probs[3] < 0.9))) + plot(model) + pred <- predict(model, x) + # Handle paralell runs + if (!is.null(pred$aggr)) { + pred <- pred$aggr + } + rmse <- sqrt(mean((pred$mean - y)^2)) + expect_true(rmse < 0.6) + best_model <- get.best.model(model) + mpm_model <- get.mpm.model(model, y, x) + } + + validate.gmodel <- function (model, x, y) { + suppressMessages(summary <- summary(model, labels = c("a", "b", "c"), tol = -1)) + expect_true(all(c(summary$marg.probs[1:2] > 0.9, summary$marg.probs[-(1:2)] < 0.9))) + expect_true(all(summary$feats.strings[1:2] %in% c("sin(a)", "sin(b)"))) + plot(model) + pred <- predict(model, x) + # Handle paralell runs + if (!is.null(pred$aggr)) { + pred <- pred$aggr + } + rmse <- sqrt(mean((pred$mean - y)^2)) + expect_true(rmse < 0.2) + best_model <- get.best.model(model) + mpm_model <- get.mpm.model(model, y, x) + } + + params <- gen.params.gmjmcmc(ncol(x)) + probs <- gen.probs.gmjmcmc("sin") + probs$gen <- c(0, 1, 0, 0) + params$feat$D <- 1 + params$feat$L <- 2 + + # No intercept + data <- as.data.frame(cbind(y, x)) + colnames(data) <- c("y", "a", "b", "c") + mod1 <- fbms(y ~ . - 1, family = "gaussian", beta_prior = list(type = "Jeffreys-BIC"), method = "mjmcmc", data = data, verbose = FALSE) + mod1p <- fbms(y ~ . - 1, family = "gaussian", beta_prior = list(type = "Jeffreys-BIC"), method = "mjmcmc.parallel", data = data, verbose = FALSE) + validate.model(mod1, x, y) + validate.model(mod1p, x, y) + + set.seed(123) + data$y <- y_sin + gmod1 <- fbms(y ~ . - 1, family = "gaussian", beta_prior = list(type = "Jeffreys-BIC"), method = "gmjmcmc", data = data, transforms = "sin", params = params, probs = probs, P = 20, verbose = FALSE) + gmod1p <- fbms(y ~ . - 1, family = "gaussian", beta_prior = list(type = "Jeffreys-BIC"), method = "gmjmcmc.parallel", data = data, transforms = "sin", params = params, probs = probs, P = 20, verbose = FALSE) + validate.gmodel(gmod1, x, y_sin) + validate.gmodel(gmod1p, x, y_sin) + + # Model defined intercept + set.seed(123) + data$y <- y_shift + mod2 <- fbms(y ~ ., family = "gaussian", beta_prior = list(type = "Jeffreys-BIC"), method = "mjmcmc", data = data, verbose = FALSE) + mod2p <- fbms(y ~ ., family = "gaussian", beta_prior = list(type = "Jeffreys-BIC"), method = "mjmcmc.parallel", data = data, verbose = FALSE) + validate.model(mod2, x, y_shift) + validate.model(mod2p, x, y_shift) + + set.seed(123) + data$y <- y_sin_shift + gmod2 <- fbms(y ~ ., family = "gaussian", beta_prior = list(type = "Jeffreys-BIC"), method = "gmjmcmc", data = data, transforms = "sin", params = params, probs = probs, P = 20, verbose = FALSE) + gmod2p <- fbms(y ~ ., family = "gaussian", beta_prior = list(type = "Jeffreys-BIC"), method = "gmjmcmc.parallel", data = data, transforms = "sin", params = params, probs = probs, P = 20, verbose = FALSE) + validate.gmodel(gmod2, x, y_sin_shift) + validate.gmodel(gmod2p, x, y_sin_shift) + + # User defined intercept + set.seed(123) + data <- cbind(data[, 1], 1, data[, -1]) + colnames(data) <- c("y", "const", "a", "b", "c") + data$y <- y_shift + mod3 <- fbms(y ~ . - 1, family = "gaussian", beta_prior = list(type = "Jeffreys-BIC"), method = "mjmcmc", data = data, fixed = 1, verbose = FALSE) + mod3p <- fbms(y ~ . - 1, family = "gaussian", beta_prior = list(type = "Jeffreys-BIC"), method = "mjmcmc.parallel", data = data, fixed = 1, verbose = FALSE) + validate.model(mod3, cbind(1, x), y_shift) + validate.model(mod3p, cbind(1, x), y_shift) + + set.seed(123) + data$y <- y_sin_shift + gmod3 <- fbms(y ~ . - 1, family = "gaussian", beta_prior = list(type = "Jeffreys-BIC"), method = "gmjmcmc", data = data, transforms = "sin", params = params, probs = probs, P = 20, fixed = 1, verbose = FALSE) + gmod3p <- fbms(y ~ . - 1, family = "gaussian", beta_prior = list(type = "Jeffreys-BIC"), method = "gmjmcmc.parallel", data = data, transforms = "sin", params = params, probs = probs, P = 20, fixed = 1, verbose = FALSE) + validate.gmodel(gmod3, cbind(1, x), y_sin_shift) + validate.gmodel(gmod3p, cbind(1, x), y_sin_shift) +}) + diff --git a/tests/testthat/test_local_optim.R b/tests/testthat/test_local_optim.R index 76357d99321ef65867bf8404d24c6578368cdab4..76bdf390ff21bc5d7edf927b22a9debbadbc93e9 100644 --- a/tests/testthat/test_local_optim.R +++ b/tests/testthat/test_local_optim.R @@ -17,7 +17,7 @@ test_that("Testing Greedy algorithm", { # Optimize empty model but dont allow all indices, should set all to true except disallowed optmod <- greedy.optim( c(F, F, F, F, F, F, F, F, F, F), - NULL, + list(fixed = 0), loglik.tester, c(F, F, T, T, T, T, T, T, T, T), NULL, diff --git a/tests/testthat/test_mjmcmc.R b/tests/testthat/test_mjmcmc.R index cca6672c6f1046494ee6ac90f87510ae0b390797..1e7ab6f499301c87e518bbf21b5e2cae9f9a94c6 100644 --- a/tests/testthat/test_mjmcmc.R +++ b/tests/testthat/test_mjmcmc.R @@ -5,35 +5,86 @@ context("MJMCMC") -test_that("Testing MJMCMC algorithm", { - # Dummy test likelihood function - loglik.tester <- function (y, x, model, complex, params) { - lmmod <- lm.fit(x[, model, drop = FALSE], y) - n <- length(y) - k <- length(lmmod$coefficients) - rss <- sum(resid(lmmod)^2) - aic <- n * log(rss / n) + 2 * k - return(list(crit = aic, coefs = lmmod$coefficients)) +test_that("Test (G)MJMCMC", { + RNGkind("L'Ecuyer-CMRG") + set.seed(123) + x <- matrix(rnorm(300), 100) + y <- rnorm(100, 0, 0.5) + rowSums(x[, 1:2]) + y_shift <- y + 10 + y_sin <- rnorm(100, 0, 0.05) + sin(x[, 1]) * 3 + sin(x[, 2]) * 2 + y_sin_shift <- y_sin + 10 + + expect_true(length(y_sin) == 100) + + validate.model <- function (model, x, y) { + expect_true(all(c(model$marg.probs[1:2] > 0.9, model$marg.probs[3] < 0.9))) + summary <- summary(model, labels = c("a", "b", "c"), tol = -1) + expect_true(all(c(summary$marg.probs[1:2] > 0.9, summary$marg.probs[3] < 0.9))) + plot(model) + pred <- predict(model, x) + # Handle paralell runs + if (!is.null(pred$aggr)) { + pred <- pred$aggr + } + rmse <- sqrt(mean((pred$mean - y)^2)) + expect_true(rmse < 0.6) + best_model <- get.best.model(model) + mpm_model <- best_model#get.mpm.model(model, y, x) + } + + validate.gmodel <- function (model, x, y) { + summary <- summary(model, labels = c("a", "b", "c"), tol = -1) + expect_true(all(c(summary$marg.probs[1:2] > 0.9, summary$marg.probs[-(1:2)] < 0.9))) + expect_true(all(summary$feats.strings[1:2] %in% c("sin(a)", "sin(b)"))) + plot(model) + pred <- predict(model, x) + # Handle paralell runs + if (!is.null(pred$aggr)) { + pred <- pred$aggr + } + rmse <- sqrt(mean((pred$mean - y)^2)) + expect_true(rmse < 0.2) + best_model <- get.best.model(model) + mpm_model <- get.mpm.model(model, y, x) } - data <- matrix(rnorm(600), 100) - resm <- mjmcmc(data, loglik.tester) - summary(resm, labels = c("a", "b", "c", "d", "e")) - plot(resm) - predm <- predict(resm, cbind(1, data[, -1, drop = FALSE])) - - resg <- gmjmcmc(data, loglik.tester, NULL, c("p0", "exp.dbl")) - summary(resg) - plot(resg) - prediction <- predict(resg, cbind(1, data[, -1, drop = FALSE])) - - respm <- mjmcmc.parallel(2, 2, data, loglik.tester) - summary(respm) - plot(respm) - pred_pm <- predict(respm, cbind(1, data[, -1, drop = FALSE])) - - respg <- gmjmcmc.parallel(2, 2, NULL, data, loglik.tester, NULL, c("p0", "exp.dbl")) - summary(respg) - plot(respg) - pred_pg <- predict(respg, cbind(1, data[, -1, drop = FALSE])) + params <- gen.params.gmjmcmc(ncol(x)) + probs <- gen.probs.gmjmcmc("sin") + probs$gen <- c(0, 1, 0, 0) + params$feat$D <- 1 + params$feat$L <- 2 + mlpost_params = list(family = "gaussian", beta_prior = list(type = "Jeffreys-BIC")) + + # No intercept + mod1 <- mjmcmc(x = x, y = y, loglik.pi = gaussian.loglik, mlpost_params = mlpost_params, intercept = FALSE) + mod1p <- mjmcmc.parallel(runs = 2, cores = 2, x = x, y = y, loglik.pi = gaussian.loglik, mlpost_params = mlpost_params, intercept = FALSE) + validate.model(mod1, x, y) + validate.model(mod1p, x, y) + + set.seed(123) + gmod1 <- gmjmcmc(x = x, y = y_sin, loglik.pi = gaussian.loglik, mlpost_params = mlpost_params, transforms = "sin", params = params, probs = probs, P = 20, intercept = FALSE, verbose = FALSE) + gmod1p <- gmjmcmc.parallel(runs = 2, cores = 2, x = x, y = y_sin, loglik.pi = gaussian.loglik, mlpost_params = mlpost_params, transforms = "sin", params = params, probs = probs, intercept = FALSE, verbose = FALSE) + validate.gmodel(gmod1, x, y_sin) + validate.gmodel(gmod1p, x, y_sin) + + # Model defined intercept + mod2 <- mjmcmc(x = x, y = y_shift, loglik.pi = gaussian.loglik, mlpost_params = mlpost_params, intercept = TRUE) + validate.model(mod2, x, y_shift) + + set.seed(123) + gmod2 <- gmjmcmc(x = x, y = y_sin_shift, loglik.pi = gaussian.loglik, mlpost_params = mlpost_params, transforms = "sin", params = params, probs = probs, intercept = TRUE, P = 20, verbose = FALSE) + gmod2p <- gmjmcmc.parallel(runs = 2, cores = 2, x = x, y = y_sin_shift, loglik.pi = gaussian.loglik, mlpost_params = mlpost_params, transforms = "sin", params = params, probs = probs, intercept = TRUE, verbose = FALSE) + validate.gmodel(gmod2, x, y_sin_shift) + validate.gmodel(gmod2p, x, y_sin_shift) + + # User defined intercept + mod3 <- mjmcmc(x = cbind(1, x), y = y_shift, loglik.pi = gaussian.loglik, mlpost_params = mlpost_params, fixed = 1) + validate.model(mod3, cbind(1, x), y_shift) + + set.seed(123) + gmod3 <- gmjmcmc(x = cbind(1, x), y = y_sin_shift, loglik.pi = gaussian.loglik, mlpost_params = mlpost_params, transforms = "sin", params = params, probs = probs, fixed = 1, intercept = FALSE, P = 20, verbose = FALSE) + gmod3p <- gmjmcmc.parallel(runs = 2, cores = 2, x = cbind(1, x), y = y_sin_shift, loglik.pi = gaussian.loglik, mlpost_params = mlpost_params, transforms = "sin", params = params, probs = probs, fixed = 1, intercept = FALSE, verbose = FALSE) + validate.gmodel(gmod3, cbind(1, x), y_sin_shift) + validate.gmodel(gmod3p, cbind(1, x), y_sin_shift) }) + diff --git a/tests/testthat/test_priors.R b/tests/testthat/test_priors.R new file mode 100644 index 0000000000000000000000000000000000000000..19ef71554408fa7b315efb259c9233f23297fd3d --- /dev/null +++ b/tests/testthat/test_priors.R @@ -0,0 +1,85 @@ +# Title : General tests +# Objective : Test the code +# Created by: jonlachmann +# Created on: 2021-02-25 + +context("Priors") + +test_that("Test various priors through the fbms function", { + set.seed(123) + x <- matrix(rnorm(300), 100) + y <- rnorm(100, 0, 0.5) + rowSums(x[, 1:2]) + expect_true(length(y)==100) + # validate.model <- function (model, x, y) { + # expect_true(all(c(model$marg.probs[1:2] > 0.9, model$marg.probs[3] < 0.9))) + # summary <- summary(model, labels = c("a", "b", "c"), tol = -1) + # expect_true(all(c(summary$marg.probs[1:2] > 0.9, summary$marg.probs[3] < 0.9))) + # plot(model) + # pred <- predict(model, x) + # # Handle paralell runs + # if (!is.null(pred$aggr)) { + # pred <- pred$aggr + # } + # rmse <- sqrt(mean((pred$mean - y)^2)) + # expect_true(rmse < 0.6) + # best_model <- get.best.model(model) + # mpm_model <- get.mpm.model(model, y, x) + # } + # + # # No intercept + # data <- as.data.frame(cbind(y, x)) + # colnames(data) <- c("y", "a", "b", "c") + # family <- "gaussian" + # beta_prior <- list(type = "g-prior", g = 5, a = 3, b = 1, s = 1, rho = 0, v = 1, k = 1) + # + # gaussian_priors <- c( + # "CH", "tCCH", "TG", "beta.prime", "intrinsic", "ZS-adapted", "uniform","Jeffreys", "benchmark", "robust", + # "g-prior", "hyper-g", "EB-local", "ZS-null", "ZS-full", "BIC", "hyper-g-laplace", "AIC", "EB-global", "hyper-g-n", "JZS", + # "Jeffreys-BIC", "g-prior" + # ) + # + # expected <- list( + # CH = list(crit = 1.79116859063856e+28, coefs = c(X1 = 0.971122645911043, X2 = 1.02417531317894, X3 = -0.0301201893345434)), + # tCCH = list(crit = 1.79116859063856e+28, coefs = c(X1 = 0.971122645911043, X2 = 1.02417531317894, X3 = -0.0301201893345434)), + # TG = list(crit = 3.30010826314369e+26, coefs = c(X1 = 0.971122645911043, X2 = 1.02417531317894, X3 = -0.0301201893345434)), + # beta.prime = list(crit = 2.37584282903985e+33, coefs = c(X1 = 0.971122645911043, X2 = 1.02417531317894, X3 = -0.0301201893345434)), + # intrinsic = list(crit = 16.013997004248, coefs = c(X1 = 0.971122645911043, X2 = 1.02417531317894, X3 = -0.0301201893345434)), + # `ZS-adapted` = list(crit = 3.08085895954179e+52, coefs = c(X1 = 0.971122645911043, X2 = 1.02417531317894, X3 = -0.0301201893345434)), + # uniform = list(crit = 2.6188594083781e+29, coefs = c(X1 = 0.971122645911043, X2 = 1.02417531317894, X3 = -0.0301201893345434)), + # Jeffreys = list(crit = 1.96893489476632e+31, coefs = c(X1 = 0.971122645911043, X2 = 1.02417531317894, X3 = -0.0301201893345434)), + # benchmark = list(crit = 1.88194647439014e+31, coefs = c(X1 = 0.971122645911043, X2 = 1.02417531317894, X3 = -0.0301201893345434)), + # robust = list(crit = 15.4590106422538, coefs = c(X1 = 0.971122645911043, X2 = 1.02417531317894, X3 = -0.0301201893345434)), + # `g-prior` = list(crit = 61.0283622188635, coefs = c(X1 = 0.971122645911043, X2 = 1.02417531317894, X3 = -0.0301201893345434)), + # `hyper-g` = list(crit = 88.8999586451438, coefs = c(0.971122645911043, 1.02417531317894, -0.0301201893345434)), + # `EB-local` = list(crit = 91.5555793778985, coefs = c(0.971122645911043, 1.02417531317894, -0.0301201893345434)), + # `ZS-null` = list(crit = 90.2037895063674, coefs = c(0.971122645911043, 1.02417531317894, -0.0301201893345434)), + # `ZS-full` = list(crit = 0, coefs = c(0.971122645911043, 1.02417531317894, -0.0301201893345434)), + # BIC = list(crit = -170.850296079658, coefs = c(0.971122645911043, 1.02417531317894, -0.0301201893345434)), + # `hyper-g-laplace` = list(crit = 88.8449712472898, coefs = c(0.971122645911043, 1.02417531317894, -0.0301201893345434)), + # AIC = list(crit = -166.942540800676, coefs = c(0.971122645911043, 1.02417531317894, -0.0301201893345434)), + # `EB-global` = list(crit = 91.5555793778985, coefs = c(0.971122645911043, 1.02417531317894, -0.0301201893345434)), + # `hyper-g-n` = list(crit = 90.6511779673767, coefs = c(0.971122645911043, 1.02417531317894, -0.0301201893345434)), + # JZS = list(crit = 90.9166314790781, coefs = c(0.971122645911043, 1.02417531317894, -0.0301201893345434)), + # `Jeffreys-BIC` = list(crit = -83.4856401007207, coefs = c(X1 = 0.971122645911043, X2 = 1.02417531317894, X3 = -0.0301201893345434)) + # ) + # + # for (prior in gaussian_priors) { + # if (prior == "TG") next + # beta_prior$type <- prior + # results[[prior]] <- fbms.mlpost.master(data[, 1], x, c(TRUE, TRUE, TRUE), list(), list(beta_prior = beta_prior, family = "gaussian", r = exp(-0.5))) + # print(prior) + # print(results[[prior]]$crit) + # #expect_equal(results[[prior]]$crit, expected[[prior]]$crit) + # #mod1 <- fbms(y ~ ., family = family, beta_prior = beta_prior, method = "mjmcmc", data = data, verbose = FALSE) + # #if (!(prior %in% c("hyper-g", "EB-local", "uniform", "ZS-null", "ZS-full", "BIC", "hyper-g-laplace", "AIC", "EB-global", "hyper-g-n", "JZS"))) { + # # validate.model(mod1, x, y) + # #} + # } + # results2 <- list() + # for (prior in gaussian_priors) { + # results2[[prior]] <- fbms.mlik.master2(data[, 1], x, c(TRUE, TRUE, TRUE), list(), list(prior_beta = prior, family = "gaussian", r = exp(-0.5), g = 5, a = 3, b = 1, s = 1, rho = 0, v = 1, k = 1)) + # print(prior) + # print(results[[prior]]$crit) + # } +}) + diff --git a/tests_current/Ex10_Sec6_3.R b/tests_current/Ex10_Sec6_3.R new file mode 100644 index 0000000000000000000000000000000000000000..433b8dbdbb02aebdf107a80b91d15038311f128e --- /dev/null +++ b/tests_current/Ex10_Sec6_3.R @@ -0,0 +1,102 @@ +####################################################### +# +# Example 10 (Section 6.3): Epil data set from the INLA package +# +# Mixed Effect Poisson Model with Fractional Polynomials, using only fbms +# +# This is the valid version for the JSS Paper +# +####################################################### + +library(FBMS) +library(INLA) +library(tictoc) + +data <- INLA::Epil +data <- data[,-c(5,6)] + +df <- data[1:5] +df$V2 <- rep(c(0,1,0,0),59) +df$V3 <- rep(c(0,0,1,0),59) +df$V4 <- rep(c(0,0,0,1),59) + +transforms <- c("p0","p2","p3","p05","pm05","pm1","pm2","p0p0","p0p05","p0p1","p0p2","p0p3","p0p05","p0pm05","p0pm1","p0pm2") +probs <- gen.probs.gmjmcmc(transforms) +probs$gen <- c(1,1,0,1) # Only modifications! + +params <- gen.params.gmjmcmc(ncol(df) - 1) +params$feat$D <- 2 # Set depth of features to 2 (allow for interactions) +params$feat$keep.min <- 0.2 +params$greedy$steps <- 2 +params$greedy$tries <- 1 +params$sa$t.min <- 0.1 +params$sa$dt <- 10 + +# function to estimate log posterior +poisson.loglik.inla <- function (y, x, model, complex, mlpost_params) +{ + if(sum(model)>1) + { + data1 <- data.frame(y, as.matrix(x[,model]), mlpost_params$PID) + formula1 <- as.formula(paste0(names(data1)[1],"~",paste0(names(data1)[3:(dim(data1)[2]-1)],collapse = "+"),"+ f(mlpost_params.PID,model = \"iid\")")) + } else + { + data1 <- data.frame(y, mlpost_params$PID) + formula1 <- as.formula(paste0(names(data1)[1],"~","1 + f(mlpost_params.PID,model = \"iid\")")) + } + + #to make sure inla is not stuck + inla.setOption(inla.timeout=30) + inla.setOption(num.threads=mlpost_params$INLA.num.threads) + + mod<-NULL + + #error handling for unstable libraries that might crash + tryCatch({ + mod <- inla(family = "poisson",silent = 1L,safe = F,data = data1,formula = formula1) + }, error = function(e) { + # Handle the error by setting result to NULL + mod <- NULL + # Print a message or log the error if needed + cat("An error occurred:", conditionMessage(e), "\n") + }) + + # logarithm of model prior + if (length(mlpost_params$r) == 0) mlpost_params$r <- 1/dim(x)[1] # default value or parameter r + lp <- log_prior(mlpost_params, complex) + + if(length(mod)<3||length(mod$mlik[1])==0) { + return(list(crit = -10000 + lp,coefs = rep(0,dim(data1)[2]-2))) + } else { + mloglik <- mod$mlik[1] + return(list(crit = mloglik + lp, coefs = mod$summary.fixed$mode)) + } +} + +set.seed(03052024) +#specify indices for a random effect + +result <- fbms(formula = y ~ 1+., data = df, transforms = transforms, + method = "gmjmcmc", probs = probs, params = params, P=25, N = 100, + family = "custom", loglik.pi = poisson.loglik.inla, + model_prior = list(r = 1/dim(df)[1]), + extra_params = list(PID = data$Ind, INLA.num.threads = 1)) + +plot(result) +summary(result) + + +set.seed(23052024) + +tic() +# Number of threads used by INLA set to 1 to avoid conflicts between two layers of parallelization +result2 <- fbms(formula = y ~ 1+., data = df, transforms = transforms, + probs = probs, params = params, P=25, N = 100, + method = "gmjmcmc.parallel", runs = 40, cores = 40, + family = "custom", loglik.pi = poisson.loglik.inla, + model_prior = list(r = 1/dim(df)[1]), + extra_params = list(PID = data$Ind, INLA.num.threads = 1)) +time.inla <- toc() + +plot(result2) +summary(result2, labels = names(df)[-1], tol = 0.01) \ No newline at end of file diff --git a/tests_current/Ex11_Sec6_4.R b/tests_current/Ex11_Sec6_4.R new file mode 100644 index 0000000000000000000000000000000000000000..92b10fbdb39a5e4d186e6f8fa25916d8515372bc --- /dev/null +++ b/tests_current/Ex11_Sec6_4.R @@ -0,0 +1,185 @@ +####################################################### +# +# Example 11 (Section 6.4): +# +# Subsampling, using only fbms +# +# Heart Disease Health Indicators Dataset” +# +# This is the valid version for the JSS Paper +# +####################################################### + +library(tictoc) +library(FBMS) +#library(devtools) +#devtools::install_github("jonlachmann/irls.sgd", force=T, build_vignettes=F) +library(irls.sgd) +#Kaggle API +library(RKaggle) + +# Download latest version +df <- RKaggle::get_dataset("alexteboul/heart-disease-health-indicators-dataset") + +summary(df) +dim(df) + + + +#number of observations and covariates in the data + +n <- dim(df)[1] +p <- dim(df)[2] - 1 + +params <- gen.params.gmjmcmc(p) +transforms <- c("sigmoid","pm1","p0","p05","p2","p3") + +r = 0.01 # Parameter for the model prior + +logistic.posterior.bic.irlssgd <- function (y, x, model, complex, mlpost_params) +{ + if (!is.null(mlpost_params$crit)) { + mod <- glm.sgd(x[,model], y, binomial(), + sgd.ctrl = list(start=mlpost_params$coefs, subs=mlpost_params$subs, + maxit=10, alpha=0.00008, decay=0.99, histfreq=10)) + mod$deviance <- get_deviance(mod$coefficients, x[,model], y, binomial()) + mod$rank <- length(mod$coefficients) + } else { + mod <- irls.sgd(as.matrix(x[,model]), y, binomial(), + irls.control=list(subs=mlpost_params$subs, maxit=20, tol=1e-7, + cooling = c(1,0.9,0.75), expl = c(3,1.5,1)), + sgd.control=list(subs=mlpost_params$subs, maxit=250, alpha=0.001, + decay=0.99, histfreq=10)) + } + + # logarithm of marginal likelihood + mloglik <- -mod$deviance / 2 - 0.5 * log(length(y)) * (mod$rank - 1) + + # logarithm of model prior + if (length(mlpost_params$r) == 0) mlpost_params$r <- 1/dim(x)[1] # default value or parameter r + lp <- log_prior(mlpost_params, complex) + crit <- mloglik + lp + + if (!is.null(mlpost_params$crit) && mlpost_params$crit > crit) { + return(list(crit = mlpost_params$crit, coefs = mlpost_params$coefs)) + } + + return(list(crit = crit, coefs = mod$coefficients)) +} + + + +############################ +# +# Testing runtime +# +############################ + +set.seed(100001) +tic() +result1 <- fbms(formula = HeartDiseaseorAttack ~ 1 + ., data = df, P = 2, + transforms = transforms, params = params, method = "gmjmcmc", + family = "custom", loglik.pi = logistic.posterior.bic.irlssgd, + model_prior = list(r = r, subs = 0.01), sub = T) +time1 <- toc() + +set.seed(100002) +# regular analysis +tic() +result2 <- fbms(formula = HeartDiseaseorAttack ~ 1 + ., data = df, P = 2, + transforms = transforms, params = params, method = "gmjmcmc", + family = "binomial", beta_prior = list(type = "Jeffreys-BIC"), + model_prior = list(r = r)) +time2 <- toc() + +c(time1, time2) + +############################ +# +# More serious analysis +# +############################ + + +# with subsampling + +set.seed(100003) + +tic() +result_parallel_1 <- fbms(formula = HeartDiseaseorAttack ~ 1 + ., data = df, P = 3, + transforms = transforms, params = params, + method = "gmjmcmc.parallel", runs = 10, cores = 10, + family = "custom", loglik.pi = logistic.posterior.bic.irlssgd, + model_prior = list(r = r, subs = 0.01), sub = T) +time3 <- toc() + +summary(result_parallel_1) + +# without subsampling + + +set.seed(100004) + +tic() +result_parallel_2 <- fbms(formula = HeartDiseaseorAttack ~ 1 + ., data = df, P = 3, + transforms = transforms, params = params, family = "binomial", + method = "gmjmcmc.parallel", runs = 10, cores = 10, + model_prior = list(r = r), + beta_prior = list(type = "Jeffreys-BIC")) +time4 <- toc() + +summary(result_parallel_2) + +filename = paste0("Ex11_Results_",r,"_4.RData") +save.image(filename) + +############################ +# +# Final analysis +# +############################ + +# with subsampling + +set.seed(100005) +tic() +result_parallel_long_1 <- fbms(formula = HeartDiseaseorAttack ~ 1 + ., data = df, P = 10, + transforms = transforms, params = params, N = 500, + method = "gmjmcmc.parallel", runs = 40, cores = 40, + family = "custom", loglik.pi = logistic.posterior.bic.irlssgd, + model_prior = list(r = r, subs = 0.01), sub = T) + +time5 <- toc() +summary(result_parallel_long_1) + +filename = paste0("Ex11_Results_",r,"_5.RData") +save.image(filename) + +# regular analysis + + +set.seed(100006) + +tic() +result_parallel_long_2 <- fbms(formula = HeartDiseaseorAttack ~ 1 + ., data = df, P = 10, + transforms = transforms, params = params, family = "binomial", + method = "gmjmcmc.parallel", runs = 40, cores = 40, N = 500, + model_prior = list(r = r), + beta_prior = list(type = "Jeffreys-BIC")) +time6 <- toc() + + +summary(result_parallel_long_2) + + +############################################################################ + +C = cor(df, use = "everything", + method = "spearman") + +corrplot::corrplot(C) + +apply((abs(C - diag(diag(C)))), 2, max) + +filename = paste0("Ex11_Results_",r,".RData") +save.image(filename) \ No newline at end of file diff --git a/tests_current/Ex12_Sec6_5.R b/tests_current/Ex12_Sec6_5.R new file mode 100644 index 0000000000000000000000000000000000000000..c159f0dcfa81df1ac90a2498565115bbbc5abac1 --- /dev/null +++ b/tests_current/Ex12_Sec6_5.R @@ -0,0 +1,322 @@ +####################################################### +# +# Example 13 (Section 6.5): +# +# Cox Regression (using only fbms) +# +# This is the valid version for the JSS Paper +# +####################################################### + +#install.packages("FBMS") +library(FBMS) +library(pec) #for the computation of cindex + +#install.packages("survival") +library(survival) + + +# Download data +download.file('https://www.uniklinik-freiburg.de/fileadmin/mediapool/08_institute/biometrie-statistik/Dateien/Studium_und_Lehre/Lehrbuecher/Multivariable_Model-building/gbsg_br_ca.zip', + 'gbsg_br_ca.zip') +df1 <- read.csv(unz('gbsg_br_ca.zip', + 'gbsg_br_ca/gbsg_br_ca.csv'), + header = TRUE) +file.remove("gbsg_br_ca.zip") + +# Prepare data +df <- df1[, c(13, 14, 2:4, 6:8, 10:12)] +names(df) = c("time","cens",names(df)[3:ncol(df)]) + +# Split into training and test set +set.seed(123) +train <- c(sample((1:nrow(df))[df$cens == 1], sum(df$cens)*2/3), # split separately events + sample((1:nrow(df))[df$cens == 0], sum(!df$cens)*2/3)) # and censored observations + +df.train <- df[train,] +df.test <- df[-train,] + +# time will be used as an extra parameter in the custom function +time <- df.train$time + + +params <- gen.params.gmjmcmc(ncol(df.train) - 2) +transforms <- c("p0","p2","p3","p05","pm05","pm1","pm2") +probs <- gen.probs.gmjmcmc(transforms) +probs$gen <- c(1,1,0,0) + + +# specify the custom function to estimate log posterior for cox +surv.pseudo.loglik = function(y, x, model, complex, mlpost_params){ + + data <- data.frame(time = mlpost_params$time, cens = y, as.matrix(x[,model]))[,-3] # Removing intercept + if(dim(data)[2]==2) + { + return(list(crit=-.Machine$double.xmax, coefs=rep(0,1))) + } else { + formula1 <- as.formula(paste0("Surv(time,cens)","~ 1 + .")) + + out <- coxph(formula1, data = data) + + # logarithm of marginal likelihood + mloglik <- (out$loglik[2] - out$loglik[1]) - log(length(y)) * (dim(data)[2] - 2)/2 + + # logarithm of model prior + if (length(mlpost_params$r) == 0) mlpost_params$r <- 1/dim(x)[1] # default value or parameter r + lp <- log_prior(mlpost_params, complex) + + # Compute criterion and consider special cases like multicollinearity + + crit <- mloglik + lp + if(sum(is.na(out$coefficients))>0) #Get rid of models with collinearities (with more than two features) + crit <- -.Machine$double.xmax + + return(list(crit = crit, coefs = c(0,out$coefficients))) + } +} + + + +####################################################### +# +# Analysis with 4 different modeling strategies +# +# + + +# 1) Single chain analysis (just to illustrate how it works) +set.seed(121) +result1 <- fbms(formula = cens ~ 1 + .,data = df.train[,-1], params = params, P = 5, + transforms = transforms, method = "gmjmcmc", + family = "custom", loglik.pi = surv.pseudo.loglik, + model_prior = list(r = 0.5), + extra_params = list(time = time)) + + +summary(result1,labels = names(df.train)[-(1:2)]) + +# 2) Parallel version only linear terms + + +set.seed(122) +result2 <- fbms(formula = cens ~ 1 + .,data = df.train[,-1], params = params, + method = "mjmcmc.parallel", runs = 40, cores = 40, + family = "custom", loglik.pi = surv.pseudo.loglik, + model_prior = list(r = 0.5), extra_params = list(time = time)) + +summary(result2,tol = 0.01,labels = names(df.train)[-(1:2)],effects = c(0.025,0.5,0.975)) + + + +# 3) Parallel version only fractional polynomials + +set.seed(123) +probs$gen <- c(0,1,0,1) +params$feat$D <- 1 + +result3 <- fbms(formula = cens ~ 1 + .,data = df.train[,-1], params = params, probs = probs, P = 10, + transforms = transforms, method = "gmjmcmc.parallel", runs = 40, cores = 40, + family = "custom", loglik.pi = surv.pseudo.loglik, + model_prior = list(r = 0.5), extra_params = list(time = time)) + + +summary(result3,tol = 0.01, effects = c(0.025,0.5,0.975)) + + + +# 4) Parallel version using all types of non-linear features +set.seed(124) +probs$gen <- c(1,1,1,1) +params$feat$D <- 5 +result4 <- fbms(formula = cens ~ 1 + .,data = df.train[,-1], params = params, probs = probs,P = 20, + transforms = transforms, method = "gmjmcmc.parallel", runs = 40, cores = 40, + family = "custom", loglik.pi = surv.pseudo.loglik, + model_prior = list(r = 0.5), extra_params = list(time = time)) + + +summary(result4,tol = 0.01) + + + + + + +################################################ +# +# Prediction and C index using model averaging +# +################################################ + + +linpreds1.train <- predict(result1,df.train[,-(1:2)], link = function(x) x) +linpreds1 <- predict(result1,df.test[,-(1:2)], link = function(x) x) + +linpreds2.train <- predict(result2,df.train[,-(1:2)], link = function(x) x) +linpreds2 <- predict(result2,df.test[,-(1:2)], link = function(x) x) + +linpreds3.train <- predict(result3,df.train[,-(1:2)], link = function(x) x) +linpreds3 <- predict(result3,df.test[,-(1:2)], link = function(x) x) + +linpreds4.train <- predict(result4,df.train[,-(1:2)], link = function(x) x) +linpreds4 <- predict(result4,df.test[,-(1:2)], link = function(x) x) + + + +df.train$average.lin.pred1 <- linpreds1.train$aggr$mean +df.train$average.lin.pred2 <- linpreds2.train$aggr$mean +df.train$average.lin.pred3 <- linpreds3.train$aggr$mean +df.train$average.lin.pred4 <- linpreds4.train$aggr$mean + +df.test$average.lin.pred1 <- linpreds1$aggr$mean +df.test$average.lin.pred2 <- linpreds2$aggr$mean +df.test$average.lin.pred3 <- linpreds3$aggr$mean +df.test$average.lin.pred4 <- linpreds4$aggr$mean + + + +# Compute cindex using package pec + +mod1 <- coxph(Surv(time, cens) ~ average.lin.pred1, data = as.data.frame(df.train), x = TRUE) +cindex1 <- cindex(mod1, mod1$formula, data = as.data.frame(df.test), cens.model = 'cox')$AppCindex + +mod2 <- coxph(Surv(time, cens) ~ average.lin.pred2, data = as.data.frame(df.train), x = TRUE) +cindex2 <- cindex(mod2, mod2$formula, data = as.data.frame(df.test), cens.model = 'cox')$AppCindex + +mod3 <- coxph(Surv(time, cens) ~ average.lin.pred3, data = as.data.frame(df.train), x = TRUE) +cindex3 <- cindex(mod3, mod3$formula, data = as.data.frame(df.test), cens.model = 'cox')$AppCindex + +mod4 <- coxph(Surv(time, cens) ~ average.lin.pred4, data = as.data.frame(df.train), x = TRUE) +cindex4 <- cindex(mod4, mod4$formula, data = as.data.frame(df.test), cens.model = 'cox')$AppCindex + + +#Full model without nonlinearities (for the sake of comparison) +mod5 <- coxph(Surv(time, cens) ~ 1+., data = as.data.frame(df.train[,1:11]),x = T) +cindex5 <- cindex(mod5, mod5$formula, data = as.data.frame(df.test), cens.model = 'cox')$AppCindex + +#Model without predictors (for the sake of comparison) +mod6 <- coxph(Surv(time, cens) ~ 1, data = as.data.frame(df.train[,1:11]),x = T) +cindex6 <- cindex(mod6, mod6$formula, data = as.data.frame(df.test), cens.model = 'cox')$AppCindex + +all.cindices = round(unlist(c(cindex1, cindex2, cindex3, cindex4, cindex5, cindex6)),3) +names(all.cindices) = c("Model 1", "Model 2", "Model 3", "Model 4", "Full Linear Model", "Null Model") + +# Clean the train and test data for the next type of predictions + +df.train <- df[train,] +df.test <- df[-train,] + +############################################## +# +# Prediction and C index using best model +# +############################################## + + +linpreds.train.best <- predict(get.best.model(result1),df.train[,-(1:2)], link = function(x) x) +linpreds.best <- predict(get.best.model(result1),df.test[,-(1:2)], link = function(x) x) + + +linpreds2.train.best <- predict(get.best.model(result2),df.train[,-(1:2)], link = function(x) x) +linpreds2.best <- predict(get.best.model(result2),df.test[,-(1:2)], link = function(x) x) + + +linpreds3.train.best <- predict(get.best.model(result3),df.train[,-(1:2)], link = function(x) x) +linpreds3.best <- predict(get.best.model(result3),df.test[,-(1:2)], link = function(x) x) + + +linpreds4.train.best <- predict(get.best.model(result4),df.train[,-(1:2)], link = function(x) x) +linpreds4.best <- predict(get.best.model(result4),df.test[,-(1:2)], link = function(x) x) + + +df.train$best.lin.pred1 <- linpreds.train.best +df.train$best.lin.pred2 <- linpreds2.train.best +df.train$best.lin.pred3 <- linpreds3.train.best +df.train$best.lin.pred4 <- linpreds4.train.best + +df.test$best.lin.pred1 <- linpreds.best +df.test$best.lin.pred2 <- linpreds2.best +df.test$best.lin.pred3 <- linpreds3.best +df.test$best.lin.pred4 <- linpreds4.best + +mod1 <- coxph(Surv(time, cens) ~ best.lin.pred1, data = as.data.frame(df.train), x = TRUE) +cindex1 <- cindex(mod1, mod1$formula, data = as.data.frame(df.test), cens.model = 'cox')$AppCindex + +mod2 <- coxph(Surv(time, cens) ~ best.lin.pred2, data = as.data.frame(df.train), x = TRUE) +cindex2 <- cindex(mod2, mod2$formula, data = as.data.frame(df.test), cens.model = 'cox')$AppCindex + +mod3 <- coxph(Surv(time, cens) ~ best.lin.pred3, data = as.data.frame(df.train), x = TRUE) +cindex3 <- cindex(mod3, mod3$formula, data = as.data.frame(df.test), cens.model = 'cox')$AppCindex + +mod4 <- coxph(Surv(time, cens) ~ best.lin.pred4, data = as.data.frame(df.train), x = TRUE) +cindex4 <- cindex(mod4, mod4$formula, data = as.data.frame(df.test), cens.model = 'cox')$AppCindex + +all.cindices <- rbind(all.cindices, round(unlist(c(cindex1, cindex2, cindex3, cindex4, cindex5, cindex6)),3)) + +# Clean the train and test data for the next type of predictions + +df.train <- df[train,] +df.test <- df[-train,] + +############################################## +# +# Prediction and C index using mpm model +# +############################################## + + +linpreds.train.mpm <- predict(get.mpm.model(result1, y = df.train$cens, x = df.train[, -c(1,2)],family = "custom", + loglik.pi = surv.pseudo.loglik,params = list(r = 0.5, time = time)), + df.train[,-(1:2)], link = function(x) x) + +linpreds.mpm <- predict(get.mpm.model(result1, y = df.train$cens, x = df.train[, -c(1,2)],family = "custom", + loglik.pi = surv.pseudo.loglik,params = list(r = 0.5, time = time)),df.test[,-(1:2)], link = function(x) x) + + +linpreds2.train.mpm <- predict(get.mpm.model(result2, y = df.train$cens, x = df.train[, -c(1,2)],family = "custom", + loglik.pi = surv.pseudo.loglik,params = list(r = 0.5, time = time)), + df.train[,-(1:2)], link = function(x) x) + +linpreds2.mpm <- predict(get.mpm.model(result2, y = df.train$cens, x = df.train[, -c(1,2)],family = "custom", + loglik.pi = surv.pseudo.loglik,params = list(r = 0.5, time = time)),df.test[,-(1:2)], link = function(x) x) + +linpreds3.train.mpm <- predict(get.mpm.model(result3, y = df.train$cens, x = df.train[, -c(1,2)],family = "custom", + loglik.pi = surv.pseudo.loglik,params = list(r = 0.5, time = time)), + df.train[,-(1:2)], link = function(x) x) +linpreds3.mpm <- predict(get.mpm.model(result3, y = df.train$cens, x = df.train[, -c(1,2)],family = "custom", + loglik.pi = surv.pseudo.loglik,params = list(r = 0.5, time = time)),df.test[,-(1:2)], link = function(x) x) + + +linpreds4.train.mpm <- predict(get.mpm.model(result4, y = df.train$cens, x = df.train[, -c(1,2)],family = "custom", + loglik.pi = surv.pseudo.loglik,params = list(r = 0.5, time = time)), + df.train[,-(1:2)], link = function(x) x) +linpreds4.mpm <- predict(get.mpm.model(result4, y = df.train$cens, x = df.train[, -c(1,2)],family = "custom", + loglik.pi = surv.pseudo.loglik,params = list(r = 0.5, time = time)),df.test[,-(1:2)], link = function(x) x) + + +df.train$mpm.lin.pred1 <- linpreds.train.mpm +df.train$mpm.lin.pred2 <- linpreds2.train.mpm +df.train$mpm.lin.pred3 <- linpreds3.train.mpm +df.train$mpm.lin.pred4 <- linpreds4.train.mpm + +df.test$mpm.lin.pred1 <- linpreds.mpm +df.test$mpm.lin.pred2 <- linpreds2.mpm +df.test$mpm.lin.pred3 <- linpreds3.mpm +df.test$mpm.lin.pred4 <- linpreds4.mpm + +mod1 <- coxph(Surv(time, cens) ~ mpm.lin.pred1, data = as.data.frame(df.train), x = TRUE) +cindex1 <- cindex(mod1, mod1$formula, data = as.data.frame(df.test), cens.model = 'cox')$AppCindex + +mod2 <- coxph(Surv(time, cens) ~ mpm.lin.pred2, data = as.data.frame(df.train), x = TRUE) +cindex2 <- cindex(mod2, mod2$formula, data = as.data.frame(df.test), cens.model = 'cox')$AppCindex + +mod3 <- coxph(Surv(time, cens) ~ mpm.lin.pred3, data = as.data.frame(df.train), x = TRUE) +cindex3 <- cindex(mod3, mod3$formula, data = as.data.frame(df.test), cens.model = 'cox')$AppCindex + +mod4 <- coxph(Surv(time, cens) ~ mpm.lin.pred4, data = as.data.frame(df.train), x = TRUE) +cindex4 <- cindex(mod4, mod4$formula, data = as.data.frame(df.test), cens.model = 'cox')$AppCindex + + +all.cindices <- rbind(all.cindices, round(unlist(c(cindex1, cindex2, cindex3, cindex4, cindex5, cindex6)),3)) +rownames(all.cindices) = c("Model Averaging", "Best Model", "MPM") + +print(all.cindices) diff --git a/tests_current/Ex1_Sec3.R b/tests_current/Ex1_Sec3.R new file mode 100644 index 0000000000000000000000000000000000000000..e2badb29cbf0f07ff680a66cd5211e8405c66c51 --- /dev/null +++ b/tests_current/Ex1_Sec3.R @@ -0,0 +1,208 @@ +################################################# +# +# Example 1: +# +# Kepler Example with the most recent database update, only using fbms function +# +# This is the valid version for the JSS paper +# +################################################## + + +#install.packages("FBMS") +#install.packages("devtools") +#library(devtools) +#devtools::install_github("jonlachmann/GMJMCMC@data-inputs", force=T, build_vignettes=F) +library(FBMS) + +data(exoplanet) + +train.indx <- 1:500 +df.train = exoplanet[train.indx, ] +df.test = exoplanet[-train.indx, ] + + +to3 <- function(x) x^3 +transforms <- c("sigmoid","sin_deg","exp_dbl","p0","troot","to3") + + +#################################################### +# +# single thread analysis (default values, Section 3.1) +# +#################################################### + + +set.seed(123) + +result.default <- fbms(formula = semimajoraxis ~ 1 + . , data = df.train, method = "gmjmcmc", transforms = transforms) + + + +#################################################### +# +# single thread analysis (more iterations, Section 3.2) +# +#################################################### + + +set.seed(123) + +result.P50 <- fbms(data = df.train, method = "gmjmcmc", transforms = transforms, + P = 50, N = 1000, N.final = 5000) + + +#################################################### +# +# multiple thread analysis (Section 3.3) +# +#################################################### + +set.seed(123) + +result_parallel <- fbms(data = df.train, method = "gmjmcmc.parallel", transforms = transforms, + runs = 40, cores = 40, P = 25) + + +#################################################### +# +# Inspection of Results (Section 3.4) +# +#################################################### + +###################### +# summary + +summary(result.default) +summary(result.default, pop = "all", labels = paste0("x",1:length(df.train[,-1]))) + + +summary(result.P50) +summary(result.P50, pop = "best", labels = paste0("x",1:length(df.train[,-1]))) +summary(result.P50, pop = "last", labels = paste0("x",1:length(df.train[,-1]))) +summary(result.P50, pop = "last", tol = 0.01, labels = paste0("x",1:length(df.train[,-1]))) +summary(result.P50, pop = "all") + +summary(result_parallel) +library(tictoc) +tic() +summary(result_parallel, tol = 0.01, pop = "all") +toc() + + + + +###################### +# plot + +pdf("result.pdf") +plot(result.default) +dev.off() + +plot(result.default) + + + +pdf("result.P50.pdf") +plot(result.P50) +dev.off() + +plot(result.P50) + + + +pdf("result_parallel.pdf") +plot(result_parallel) +dev.off() + +plot(result_parallel) + + +###################### +# Prediction + + +#preds <- predict(result.default, df.test[,-1], link = function(x) x) +preds <- predict(result.default, df.test[,-1]) +rmse.default <- sqrt(mean((preds$aggr$mean - df.test$semimajoraxis)^2)) + +pdf("prediction.pdf") +plot(preds$aggr$mean, df.test$semimajoraxis) +dev.off() + +plot(preds$aggr$mean, df.test$semimajoraxis) + + + + + + +############################### + + +#preds.P50 = predict(result.P50, df.test[,-1], link = function(x) x) +preds.P50 = predict(result.P50, df.test[,-1]) +rmse.P50 <- sqrt(mean((preds.P50$aggr$mean - df.test$semimajoraxis)^2)) + +pdf("prediction.P50.pdf") +plot(preds.P50$aggr$mean, df.test$semimajoraxis) +dev.off() + +plot(preds.P50$aggr$mean, df.test$semimajoraxis) + + + +############################### + + +preds.multi <- predict(result_parallel , df.test[,-1], link = function(x) x) +rmse.parallel <- sqrt(mean((preds.multi$aggr$mean - df.test$semimajoraxis)^2)) + +pdf("pred_parallel.pdf") +plot(preds.multi$aggr$mean, df.test$semimajoraxis) +dev.off() + + +round(c(rmse.default, rmse.P50, rmse.parallel),2) + + +############################### + + +#Prediction based on the best model () or the MPM (Median Probability Model) + +get.best.model(result = result.default) +preds.best <- predict(get.best.model(result.default), df.test[, -1]) +sqrt(mean((preds.best - df.test$semimajoraxis)^2)) + +get.mpm.model(result = result.default, y = df.train$semimajoraxis, x = df.train[, -1]) +preds.mpm <- predict(get.mpm.model(result.default, y = df.train$semimajoraxis, x = df.train[, -1]), df.test[, -1]) +sqrt(mean((preds.mpm - df.test$semimajoraxis)^2)) + + +#################################################### +# +# Diagnostic plots (Section 3.5) +# +#################################################### + + +pdf("diagn_default.pdf") +diagn_plot(result.default, ylim = c(600,1500), FUN = max) +dev.off() +diagn_plot(result.default, ylim = c(600,1500), FUN = max) + + +pdf("diagn_long.pdf") +diagn_plot(result.P50, ylim = c(600,1500), FUN = max) +dev.off() +diagn_plot(result.P50, ylim = c(600,1500), FUN = max) + + +pdf("diagn_par.pdf") +diagn_plot(result_parallel, ylim = c(600,1500),FUN = max) +dev.off() + +diagn_plot(result_parallel, ylim = c(600,1500),FUN = max) + + diff --git a/tests_current/Ex2_Sec4_1.R b/tests_current/Ex2_Sec4_1.R new file mode 100644 index 0000000000000000000000000000000000000000..bba447fbd16791068dea8622f6cb05035074cad9 --- /dev/null +++ b/tests_current/Ex2_Sec4_1.R @@ -0,0 +1,94 @@ +####################################################### +# +# Example 2 (Section 4.1): +# +# Simulated data without any nonlinearities, only using fbms function +# +# This is the valid version for the JSS Paper +# +####################################################### + +#install.packages("FBMS") +#install.packages("devtools") +#library(devtools) +#devtools::install_github("jonlachmann/GMJMCMC@data-inputs", force=T, build_vignettes=F) + +library(mvtnorm) +library(FBMS) + + + +n <- 100 # sample size +p <- 20 # number of covariates +p.vec <- 1:p + + +k <- 5 #size of the data generating model + + +correct.model <- 1:k +beta.k <- (1:5)/5 # Coefficents of the correct submodel + +beta <- c(rep(0, p)) +beta[correct.model] <- beta.k + +set.seed(123) + +x <- rmvnorm(n, rep(0, p)) +y <- x %*% beta + rnorm(n) +X <- as.matrix(x) + +y<-scale(y) +X<-scale(X)/sqrt(n) + + +df <- as.data.frame(cbind(y, X)) +colnames(df) <- c("Y", paste0("X", seq_len(ncol(df) - 1))) + +correct.model +beta.k + +######################################################## +# +# Models with non-linear effects (gmjmcmc) +# +# + +to3 <- function(x) x^3 +transforms <- c("sigmoid","sin_deg","exp_dbl","p0","troot","to3") + +set.seed(1) + result <- fbms(data = df, method = "gmjmcmc", transforms = transforms) + summary(result) + plot(result) + + +set.seed(2) + result2 <- fbms(data = df, method = "gmjmcmc", transforms = transforms, + N = 1000, P = 40) + summary(result2, tol = 0.1) + plot(result) + + + +######################################################## +# +# Model which includes no non-linear effects (mjmcmc) +# +# + + # The default value of N = 1000 works relatively well here. + set.seed(1) + result.lindef <- fbms(data = df) + summary(result.lindef) + plot(result.lindef) + + # Check that this is actually the default + set.seed(1) + result.lin <- fbms(data = df, N = 1000) + summary(result.lin) + plot(result.lin) + + + + diff --git a/tests_current/Ex3_Sec4_2.R b/tests_current/Ex3_Sec4_2.R new file mode 100644 index 0000000000000000000000000000000000000000..f2f0b4fae72f7533dfe0a2539676cc51cd724383 --- /dev/null +++ b/tests_current/Ex3_Sec4_2.R @@ -0,0 +1,84 @@ +####################################################### +# +# Example 3 (Section 4.2): +# +# Simulated data with interactions, using only fbms +# +# This is the valid version for the JSS Paper +# +####################################################### + +library(mvtnorm) +library(FBMS) + +n <- 100 # sample size +p <- 20 # number of covariates + +# Model: +# X1: Pure Main effect +# X2 : X3: Pure interaction effect +# X4 * X5: Main effects plus interaction effect + + +set.seed(1003) + +x = rmvnorm(n, rep(0, p)) +X <- as.matrix(x) +X <- scale(X)/sqrt(n) + +y <- (1.2 * x[,1] + 1.5 * x[,2]* x[,3] - x[,4] + 1.1*x[,5] - 1.3 * x[,4]*x[,5])+ rnorm(n) +y<-scale(y) + +df <- data.frame(y = y, X) + + +transforms <- c("") +probs <- gen.probs.gmjmcmc(transforms) +probs$gen <- c(1,0,0,1) #Include interactions and mutations + +#################################################### +# +# single thread analysis (two different runs) +# +#################################################### + +set.seed(123) +result <- fbms(data = df, method = "gmjmcmc", transforms = transforms, + probs = probs) +summary(result) + + +set.seed(123) +result2 <- fbms(data = df, method = "gmjmcmc", transforms = transforms, + N = 1000, probs = probs, P=40) +summary(result2, tol = 0.01) + + +#################################################### +# +# multiple thread analysis +# +#################################################### + + +set.seed(123) + + result_parallel <- fbms(data = df, method = "gmjmcmc.parallel", transforms = transforms, + runs = 40, cores = 40, + probs = probs, P=25) + +summary(result_parallel, tol = 0.01) + + + +# Using longer more iterations of MJMCMC chains does not change results substantially +set.seed(123) + +result_parallel2 <- fbms(data = df, method = "gmjmcmc.parallel", transforms = transforms, + runs = 40, cores = 10, N=1000, N.final=2000, + probs = probs, P=25) +summary(result_parallel2, tol = 0.01) + +#summary(result_parallel2, pop = "all", tol = 0.01) + + diff --git a/tests_current/Ex4_Sec4_3.R b/tests_current/Ex4_Sec4_3.R new file mode 100644 index 0000000000000000000000000000000000000000..2ffdcb790624b958216af459202ff7f4c0390cc6 --- /dev/null +++ b/tests_current/Ex4_Sec4_3.R @@ -0,0 +1,97 @@ +####################################################### +# +# Example 4 (Section 4.3): +# +# Fractional Polynomials: Depths is set to 1, using only fbms +# +# This is the valid version for the JSS Paper +# +####################################################### + + +library(FBMS) + + +url <- "https://www.uniklinik-freiburg.de/fileadmin/mediapool/08_institute/biometrie-statistik/Dateien/Studium_und_Lehre/Lehrbuecher/Multivariable_Model-building/ART.zip" +temp_dir <- tempfile() +download.file(url, tf <- tempfile(fileext = ".zip"), mode = "wb") +unzip(tf, exdir = temp_dir) + +df <- read.csv(file.path(temp_dir, "ART/art", "art.csv"))[,c(16,1:3,5:8,10:14)] + +summary(df) + + +#number of observations in the data + +n = dim(df)[1] + +#number of covariates + +p = dim(df)[2] - 1 + + +set.seed(040590) + + +mu = 0.1 + p05(df$x1) + df$x1 + pm05(df$x3) + p0pm05(df$x3) + df$x4a + pm1(df$x5) + p0(df$x6) + df$x8 + df$x10 +df$y = rnorm(n =n, mean = mu,sd = 1) + + +transforms <- c("p0","p2","p3","p05","pm05","pm1","pm2","p0p0","p0p05","p0p1","p0p2","p0p3","p0p05","p0pm05","p0pm1","p0pm2") +probs <- gen.probs.gmjmcmc(transforms) +probs$gen <- c(0,1,0,1) # Only modifications! +params <- gen.params.gmjmcmc(ncol(df) - 1) +params$feat$D <- 1 # Set depth of features to 1 + + +#################################################### +# +# single thread analysis +# +#################################################### + +set.seed(123) +result <- fbms(data = df, method = "gmjmcmc", transforms = transforms, + probs = probs, params = params) +summary(result) + + + +#################################################### +# +# multiple thread analysis +# +#################################################### + +set.seed(101) +result_parallel <- fbms(data = df, method = "gmjmcmc.parallel", transforms = transforms, + probs = probs, params = params, P=25,runs = 40, cores = 40) +summary(result_parallel, tol = 0.05) + +diagn_plot(result_parallel, FUN = median) + + + + +set.seed(102) + result_parallel2 <- fbms(data = df, method = "gmjmcmc.parallel", transforms = transforms, + probs = probs, params = params, P=25, N=1000, N.final=2000, + runs = 40, cores = 40,) + +summary(result_parallel2, tol = 0.05) + +diagn_plot(result_parallel2,FUN = median) + + +########################## + +# Using Jeffreys-BIC prior + +set.seed(103) +result_parallel3 <- fbms(data = df, method = "gmjmcmc.parallel", beta_prior = list(type = "Jeffreys-BIC"), transforms = transforms, + probs = probs, params = params, P=25, N=1000, N.final=2000, + runs = 40, cores = 40,) + +summary(result_parallel3, tol = 0.05) + diff --git a/tests_current/Ex5_Sec4_3.R b/tests_current/Ex5_Sec4_3.R new file mode 100644 index 0000000000000000000000000000000000000000..36942d3a111f7e32aa2605675c04f878fdf8234b --- /dev/null +++ b/tests_current/Ex5_Sec4_3.R @@ -0,0 +1,97 @@ +####################################################### +# +# Example 5 (Section 4.3): +# +# Fractional Polynomials: Depths is set to 1, using only fbms +# +# This is the valid version for the JSS Paper +# +####################################################### + + +library(FBMS) + +url <- "https://www.uniklinik-freiburg.de/fileadmin/mediapool/08_institute/biometrie-statistik/Dateien/Studium_und_Lehre/Lehrbuecher/Multivariable_Model-building/ART.zip" +temp_dir <- tempfile() +download.file(url, tf <- tempfile(fileext = ".zip"), mode = "wb") +unzip(tf, exdir = temp_dir) + +df <- read.csv(file.path(temp_dir, "ART/art", "art.csv"))[,c(16,1:3,5:8,10:14)] + +summary(df) + + +#number of observations in the data + +n = dim(df)[1] + +#number of covariates + +p = dim(df)[2] - 1 + + +set.seed(040590) + + +mu = 0.1 + p05(df$x1) + df$x1 + pm05(df$x3) + p0pm05(df$x3) + df$x4a + pm1(df$x5) + p0(df$x6) + df$x8 + df$x10 +df$y = rnorm(n =n, mean = mu,sd = 1) + + +transforms <- c("p0","p2","p3","p05","pm05","pm1","pm2","p0p0","p0p05","p0p1","p0p2","p0p3","p0p05","p0pm05","p0pm1","p0pm2") +probs <- gen.probs.gmjmcmc(transforms) +probs$gen <- c(0,1,0,1) # Only modifications! +params <- gen.params.gmjmcmc(ncol(df) - 1) +params$feat$D <- 1 # Set depth of features to 1 + + +#################################################### +# +# single thread analysis +# +#################################################### + +set.seed(123) +result <- fbms(data = df, method = "gmjmcmc", transforms = transforms, + probs = probs, params = params) +summary(result) + + + +#################################################### +# +# multiple thread analysis +# +#################################################### + +set.seed(101) +result_parallel <- fbms(data = df, method = "gmjmcmc.parallel", transforms = transforms, + probs = probs, params = params, P=25,runs = 40, cores = 40) +summary(result_parallel, tol = 0.01) + +diagn_plot(result_parallel, FUN = median) + + + + +set.seed(102) + result_parallel2 <- fbms(data = df, method = "gmjmcmc.parallel", transforms = transforms, + probs = probs, params = params, P=25, N=1000, N.final=2000, + runs = 40, cores = 40,) + +summary(result_parallel2, tol = 0.01) + +diagn_plot(result_parallel2,FUN = median) + + +# Very large number of mjmcmc iterations (not needed for paper) +set.seed(104) + +if (use.fbms) { + result_parallel3 <- fbms(data = df, method = "gmjmcmc.parallel", transforms = transforms, beta_prior = list(type = "Jeffreys-BIC"), + probs = probs, params = params, P=50, runs = 40, cores = 40, N.init=2000, N.final=4000) +} else { + result_parallel3 = gmjmcmc.parallel(runs = 40, cores = 40, x = df[, -1], y = df[, 1], transforms = transforms, mlpost_params = list(family = "gaussian", beta_prior = list(type = "Jeffreys-BIC")), + probs = probs, params = params, P=50, N.init=2000, N.final=4000) +} +#summary(result_parallel3, labels = names(df[-1])) +summary(result_parallel3, labels = names(df[-1]), tol = 0.01) \ No newline at end of file diff --git a/tests_current/Ex6_Sec5_1.R b/tests_current/Ex6_Sec5_1.R new file mode 100644 index 0000000000000000000000000000000000000000..6b9c7f8b695acda9c392ce6a6bf8541a0787d2da --- /dev/null +++ b/tests_current/Ex6_Sec5_1.R @@ -0,0 +1,121 @@ +####################################################### +# +# Example 6 (Section 5.1): Sanger data again +# +# High dimensional analysis without nonlinearities, using only FBMS +# +# This is the valid version for the JSS Paper +# +####################################################### + +#library(devtools) +#devtools::install_github("jonlachmann/GMJMCMC@FBMS", force=T, build_vignettes=F) + +library(FBMS) +library(xtable) +library(tictoc) +run.parallel <- TRUE # Flag to control whether to run gmjmcmc in parallel or just load results + + +data(SangerData2) +df <- SangerData2 +# Rename columns for clarity: response is "y", predictors "x1", "x2", ..., "xp" +colnames(df) = c("y",paste0("x",1:(ncol(df)-1))) +n = dim(df)[1]; p=dim(df)[2]-1 + +#Use only linear terms and mutations +transforms = c("") +probs = gen.probs.gmjmcmc(transforms) +probs$gen = c(0,0,0,1) + + +# Select candidate features for the first MJMCMC round by correlation with response +c.vec = unlist(mclapply(2:ncol(df), function(x)abs(cor(df[,1],df[,x])))) +ids = sort(order(c.vec,decreasing=TRUE)[1:50]) + +# Generate default parameters for GMJMCMC for p-1 predictors +params = gen.params.gmjmcmc(p) +# Restrict feature pre-filtering to top 50 predictors selected by correlation +params$feat$prel.filter <- ids + +params$feat$pop.max <- 50 # Maximum population size for the GMJMCMC search + +#################################################### +# +# Three independent runs of gmjmcmc.parallel +# +#################################################### + + +if (run.parallel) { + set.seed(123) + result_parallel1 = fbms(data=df, transforms=transforms, + beta_prior = list(type="g-prior", g=max(n,p^2)), + probs=probs,params=params, + method="gmjmcmc.parallel", + P=50,N=1000,runs=10,cores=10) + save(result_parallel1,file="Ex6_parallel1_orig.RData") + + set.seed(1234) + result_parallel2=fbms(data=df, transforms=transforms, + beta_prior = list(type="g-prior", g=max(n,p^2)), + probs=probs,params=params, + method="gmjmcmc.parallel", + P=50,N=1000,runs=10,cores=10) + save(result_parallel2,file="Ex6_parallel2_orig.RData") + + set.seed(123456) + result_parallel3=fbms(data=df, transforms=transforms, + beta_prior = list(type="g-prior", g=max(n,p^2)), + probs=probs,params=params, + method="gmjmcmc.parallel", + P=50,N=1000,runs=10,cores=10) + save(result_parallel3,file="Ex6_parallel3_orig.RData") + +} else { + + # If not running gmjmcmc.parallel again, load previously saved results + load("Ex6_parallel1.RData") + load("Ex6_parallel2.RData") + load("Ex6_parallel3.RData") + +} + + +# Summarize results from each of the three parallel runs with tolerance of 0.01 + +res1 = summary(result_parallel1,tol=0.01) +res1$marg.probs = round(res1$marg.probs,3) +res2 = summary(result_parallel2,tol=0.01) +res2$marg.probs = round(res2$marg.probs,3) +res3 = summary(result_parallel3,tol=0.01) +res3$marg.probs = round(res3$marg.probs,3) + +# Combine unique feature names found in all three runs +names.best = unique(c(res1$feats.strings,res2$feats.strings,res3$feats.strings)) + +# Find maximum number of rows across summaries to equalize sizes for cbind +m = max(nrow(res1),nrow(res2),nrow(res3)) +# Pad shorter summaries with empty rows to make them all length m +while(nrow(res1) 1) { + x.model = x[,model] + data <- data.frame(y, x = x.model[,-1], dr = mlpost_params$dr) + + mm <- lmer(as.formula(paste0("y ~ 1 +",paste0(names(data)[2:(dim(data)[2]-1)],collapse = "+"), "+ (1 | dr)")), data = data, REML = FALSE) + } else{ #model without fixed effects + data <- data.frame(y, dr = mlpost_params$dr) + mm <- lmer(as.formula(paste0("y ~ 1 + (1 | dr)")), data = data, REML = FALSE) + } + + mloglik <- as.numeric(logLik(mm)) - 0.5*log(length(y)) * (dim(data)[2] - 2) #Laplace approximation for beta prior + + # logarithm of model prior + if (length(mlpost_params$r) == 0) mlpost_params$r <- 1/dim(x)[1] # default value or parameter r + lp <- log_prior(mlpost_params, complex) + + + return(list(crit = mloglik + lp, coefs = fixef(mm))) +} + + +# function to estimate log posterior with INLA + +mixed.model.loglik.inla <- function (y, x, model, complex, mlpost_params) +{ + if(sum(model)>1) + { + data1 = data.frame(y, as.matrix(x[,model]), mlpost_params$dr) + formula1 = as.formula(paste0(names(data1)[1],"~",paste0(names(data1)[3:(dim(data1)[2]-1)],collapse = "+"),"+ f(mlpost_params.dr,model = \"iid\")")) + } else + { + data1 = data.frame(y, mlpost_params$dr) + formula1 = as.formula(paste0(names(data1)[1],"~","1 + f(mlpost_params.dr,model = \"iid\")")) + } + + #to make sure inla is not stuck + inla.setOption(inla.timeout=30) + inla.setOption(num.threads=mlpost_params$INLA.num.threads) + + mod<-NULL + #importance with error handling for unstable libraries that one does not trust 100% + tryCatch({ + mod <- inla(family = "gaussian",silent = 1L,safe = F, data = data1,formula = formula1) + }, error = function(e) { + + # Handle the error by setting result to NULL + mod <- NULL + + # You can also print a message or log the error if needed + cat("An error occurred:", conditionMessage(e), "\n") + }) + + # logarithm of model prior + if (length(mlpost_params$r) == 0) mlpost_params$r <- 1/dim(x)[1] # default value or parameter r + lp <- log_prior(mlpost_params, complex) + + if(length(mod)<3||length(mod$mlik[1])==0) { + return(list(crit = -10000 + lp,coefs = rep(0,dim(data1)[2]-2))) + } else { + mloglik <- mod$mlik[1] + return(list(crit = mloglik + lp, coefs = mod$summary.fixed$mode)) + } +} + + +# function to estimate log posterior with RTMB + +mixed.model.loglik.rtmb <- function (y, x, model, complex, mlpost_params) +{ + z = model.matrix(y~mlpost_params$dr) #Design matrix for random effect + + msize = sum(model) + #Set up and estimate model + dat = list(y = y, xm = x[,model], z = z) + par = list(logsd_eps = 0, + logsd_dr = 0, + beta = rep(0,msize), + u = rep(0,mlpost_params$nr_dr)) + + nll = function(par){ + getAll(par,dat) + sd_eps = exp(logsd_eps) + sd_dr = exp(logsd_dr) + + nll = 0 + #-log likelihood random effect + nll = nll - sum(dnorm(u, 0, sd_dr, log = TRUE)) + mu = as.vector(as.matrix(xm)%*%beta) + z%*%u + nll <- nll - sum(dnorm(y, mu, sd_eps, log = TRUE)) + + return(nll) + } + obj <- MakeADFun(nll , par, random = "u", silent = T ) + opt <- nlminb ( obj$par , obj$fn , obj$gr, control = list(iter.max = 10)) + + # logarithm of model prior + if (length(mlpost_params$r) == 0) mlpost_params$r <- 1/dim(x)[1] # default value or parameter r + lp <- log_prior(mlpost_params, complex) + + mloglik <- -opt$objective - 0.5*log(dim(x)[1])*msize + return(list(crit = mloglik + lp, coefs = opt$par[-(1:2)])) +} + + + +###################### +# +# Compare runtime +# + +set.seed(03052024) + +tic() +result1a <- fbms(formula = z ~ 1+., data = df, transforms = transforms, + method = "gmjmcmc",probs = probs, params = params, P=3, N = 30, + family = "custom", loglik.pi = mixed.model.loglik.lme4, + model_prior = list(r = 1/dim(df)[1]), + extra_params = list(dr = droplevels(Zambia$dr))) +time.lme4 = toc() + + +tic() +result1b <- fbms(formula = z ~ 1+., data = df, transforms = transforms, + method = "gmjmcmc",probs = probs, params = params, P=3, N = 30, + family = "custom", loglik.pi = mixed.model.loglik.inla, + model_prior = list(r = 1/dim(df)[1]), + extra_params = list(dr = droplevels(Zambia$dr), + INLA.num.threads = 10)) +time.inla = toc() + +tic() +result1c <- fbms(formula = z ~ 1+., data = df, transforms = transforms, + method = "gmjmcmc",probs = probs, params = params, P=3, N = 30, + family = "custom", loglik.pi = mixed.model.loglik.rtmb, + model_prior = list(r = 1/dim(df)[1]), + extra_params = list(dr = droplevels(Zambia$dr), + nr_dr = sum((table(Zambia$dr))>0))) +time.rtmb = toc() +plot(result1c) +summary(result1c, labels = names(df)[-1]) + +c(time.lme4$callback_msg, time.inla$callback_msg, time.rtmb$callback_msg) + +###################### +# +# Analysis with lme4 +# +# + + +# Only this one is actually reported in the manuscript +set.seed(20062024) +params$feat$pop.max = 10 + +result2a <- fbms(formula = z ~ 1+., data = df, transforms = transforms, + probs = probs, params = params, P=25, N = 100, + method = "gmjmcmc.parallel", runs = 40, cores = 40, + family = "custom", loglik.pi = mixed.model.loglik.lme4, + model_prior = list(r = 1/dim(df)[1]), + extra_params = list(dr = droplevels(Zambia$dr))) + +summary(result2a,tol = 0.05,labels=names(df)[-1]) + + +set.seed(21062024) + +result2b <- fbms(formula = z ~ 1+., data = df, transforms = transforms, + probs = probs, params = params, P=25, N = 100, + method = "gmjmcmc.parallel", runs = 120, cores = 40, + family = "custom", loglik.pi = mixed.model.loglik.lme4, + model_prior = list(r = 1/dim(df)[1]), + extra_params = list(dr = droplevels(Zambia$dr))) + +summary(result2b, labels = names(df)[-1]) + +summary(result2b, labels = names(df)[-1], pop = "all") +summary(result2b, labels = names(df)[-1], pop = "last") + +plot(result2b) + + +set.seed(03072024) + +result2c <- fbms(formula = z ~ 1+., data = df, transforms = transforms, + probs = probs, params = params, P=25, N = 100, + method = "gmjmcmc.parallel", runs = 200, cores = 40, + family = "custom", loglik.pi = mixed.model.loglik.lme4, + model_prior = list(r = 1/dim(df)[1]), + extra_params = list(dr = droplevels(Zambia$dr))) + +summary(result2c, labels = names(df)[-1]) +summary(result2c, labels = names(df)[-1], pop = "last") +summary(result2c, labels = names(df)[-1], pop = "all") +summary(result2c, labels = names(df)[-1], pop = "best") + + +summary(result2a, labels = names(df)[-1]) +summary(result2b, labels = names(df)[-1]) +summary(result2c, labels = names(df)[-1]) + + +###################### +# +# Analysis with INLA (Not used for manuscript, very long runtime) +# +# + +set.seed(22052024) + +# Number of threads used by INLA set to 1 +result2aI <- fbms(formula = z ~ 1+., data = df, transforms = transforms, + probs = probs, params = params, P=25, N = 100, + method = "gmjmcmc.parallel", runs = 40, cores = 40, + family = "custom", loglik.pi = mixed.model.loglik.inla, + model_prior = list(r = 1/dim(df)[1]), + extra_params = list(dr = droplevels(Zambia$dr), INLA.num.threads = 1)) + +plot(result2aI) +summary(result2aI, labels = names(df)[-1]) + + + +params$feat$check.col = F + +set.seed(20062024) +# Number of threads used by INLA set to 1 +result2bI <- fbms(formula = z ~ 1+., data = df, transforms = transforms, + probs = probs, params = params, P=25, N = 100, + method = "gmjmcmc.parallel", runs = 120, cores = 40, + family = "custom", loglik.pi = mixed.model.loglik.inla, + model_prior = list(r = 1/dim(df)[1]), + extra_params = list(dr = droplevels(Zambia$dr), INLA.num.threads = 1)) + +plot(result2bI) +summary(result2bI, labels = names(df)[-1]) \ No newline at end of file diff --git a/tests_current/some tests.R b/tests_current/some tests.R new file mode 100644 index 0000000000000000000000000000000000000000..c4da54660ad737646e556e27d3516196154232c7 --- /dev/null +++ b/tests_current/some tests.R @@ -0,0 +1,114 @@ +# Validation script for fbms.mlik.master +# Tests all supported (family, prior) combinations with required parameters + +set.seed(42) # Ensure reproducibility + +# Generate synthetic data +gen_data <- function(family) { + n <- 50 + p <- 3 + x <- cbind(1, matrix(rnorm(n * p), n, p)) # Include intercept + beta <- c(1, -1, 0.5, -0.5) + + if (family == "gaussian") { + y <- x %*% beta + rnorm(n, mean = 0, sd = 1000) + } else if (family == "binomial") { + prob <- 1 / (1 + exp(-x %*% beta + rnorm(n, mean = 0, sd = 1))) + y <- rbinom(n, 1, prob) + } else if (family == "poisson") { + lambda <- exp(x %*% beta + rnorm(n, mean = 0, sd = 1)) + y <- rpois(n, lambda) + } else if (family == "gamma") { + shape <- 2 + rate <- exp(-x %*% beta + rnorm(n, mean = 0, sd = 0.5)) + y <- rgamma(n, shape = shape, rate = rate) + } else { + stop("Unsupported family") + } + + list(y = as.vector(y), x = x) +} + +# Define prior lists +glm_and_gaussian_priors <- c("ZS-adapted", "beta.prime", "EB-local", "g-prior", "hyper-g", "hyper-g-n", + "intrinsic", "Jeffreys", "uniform", "benchmark", "robust", "Jeffreys-BIC", + "CH", "tCCH", "TG") +gaussian_only_priors <- c("ZS-null", "ZS-full", "hyper-g-laplace", "AIC", "JZS","EB-global") + +glm_priors <- glm_and_gaussian_priors +gaussian_priors <- c(glm_and_gaussian_priors, gaussian_only_priors) + +families <- c("gaussian", "binomial", "poisson", "gamma") + +# Required parameters for priors +prior_params <- list( + "g-prior" = list(g = 10,a = 10), + "hyper-g" = list(a = 3), + "hyper-g-n" = list(a = 3), + "ZS-null" = list(a = 3), + "ZS-full" = list(a = 500), + "hyper-g-laplace" = list(a = 3), + "AIC" = list(a = 3), + "JZS" = list(a = 3), + "EB-global" = list(a = 3), + "EB-local" = list(a = 3), + "CH" = list(a = 1, b = 2, s = 1), + "tCCH" = list(a = 1, b = 2, s = 0, rho = 1, v = 1, k = 1), + "TG" = list(a = 2, s = 1) +) + +# Testing loop +for (family in families) { + priors <- if (family == "gaussian") gaussian_priors else glm_priors + data <- gen_data(family) + + cat("\n===== Testing family:", family, "=====") + + for (prior in priors) { + + print(prior) + + params <- list(family = family, beta_prior = list(type = prior)) + + params_old <- list(family = family, prior_beta = prior) + + + # Add required parameters if applicable + + if (prior %in% names(prior_params)) { + params$beta_prior <- c(params$beta_prior, prior_params[[prior]]) + } + + if (prior %in% names(prior_params)) { + params_old <- c(params_old, prior_params[[prior]]) + } + + # Run the model + tryCatch({ + + set.seed(1) + result <- fbms.mlik.master(data$y, data$x, model = c(T, rep(TRUE, ncol(data$x) - 1)), + complex = list(oc = 1), mlpost_params = params) + set.seed(1) + result.null <- fbms.mlik.master(data$y, data$x, model = c(T, T, rep(FALSE, ncol(data$x) - 2)), + complex = list(oc = 1), mlpost_params = params) + set.seed(1) + result.old <- fbms.mlik.master_old(data$y, data$x, model = c(T, rep(TRUE, ncol(data$x) - 1)), + complex = list(oc = 1), mlpost_params = params_old)# + set.seed(1) + result.null.old <- fbms.mlik.master_old(data$y, data$x, model = c(T, T, rep(FALSE, ncol(data$x) - 2)), + complex = list(oc = 1), mlpost_params = params_old) + + + crit_rounded <- round(result$crit - result.null$crit - result.old$crit + result.null.old$crit, 8) + coefs_mean <- round(mean(result$coefs) - mean(result.null$coefs) - mean(result.old$coefs) + mean(result.null.old$coefs), 8) + + cat(sprintf("\nPrior: %-15s -> crit: %8.4f, mean(coefs): %8.4f", prior, crit_rounded, coefs_mean)) + + print("Finished") + + }, error = function(e) { + cat(sprintf("\nPrior: %-15s -> ERROR: %s", prior, conditionMessage(e))) + }) + } +} diff --git a/vignettes/FBMS-guide.Rmd b/vignettes/FBMS-guide.Rmd new file mode 100644 index 0000000000000000000000000000000000000000..2df7103bb22cf732e784d6de1f4950d2014c2662 --- /dev/null +++ b/vignettes/FBMS-guide.Rmd @@ -0,0 +1,793 @@ +--- +title: "FBMS-Flexible Bayesian Model Selection and Model Averaging" +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{FBMS - Flexible Bayesian Model Selection and Model Averaging} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} + %\VignetteDepends{fastglm, FBMS} +--- + +This vignette introduces the **FBMS** package and shows how to perform **Flexible Bayesian Model Selection (BMS)** and **Bayesian Model Averaging (BMA)** for linear, generalized, nonlinear, fractional–polynomial, mixed–effect, and logic–regression models. More details are provided in the paper: "FBMS: An R Package for Flexible Bayesian Model Selection and Model Averaging" available on arxiv: more explicit examples accompanying the paper can be found on github + +------------------------------------------------------------------------ + +# Setup + +Load technical markdown settings and a custom function for printing only what is needed through **`printn()`**. + +```{r include=FALSE} +knitr::opts_chunk$set( + message = TRUE, # show package startup and other messages + warning = FALSE, # suppress warnings + echo = TRUE, # show code + results = "hide" # hide default printed results unless printed via printn() +) + +# For careful printing of only what I explicitly ask for +printn <- function(x) { + # Capture the *exact* console print output as a character vector + txt <- capture.output(print(x)) + # Combine lines with newline, send as a message to be shown in output + message(paste(txt, collapse = "\n")) +} + +library(FBMS) +``` + +```{r eval=FALSE, include=FALSE} +library(FBMS) +``` + +------------------------------------------------------------------------ + +# Bayesian Model Selection and Averaging + +1. Consider a class of models: $\Omega: m_1(Y|X,\theta_1), \dots, m_k(Y|X,\theta_k)$.\ +2. Assign priors to models $P(m_1), \dots, P(m_k)$ and parameters $P(\theta_j|m_j)$.\ +3. Obtain joint posterior $P(m_j,\theta_j|D)$.\ +4. Make inference on a quantity of interest $\Delta$. + +
+ +Show equations + +$$ +P(\Delta|D) = \sum_{m\in\Omega} P(m|D)\, \int_{\Theta_m} P(\Delta|m,\theta,D)\, P(\theta|m,D)\, d\theta. +$$ + +
+ +## Bayesian Generalized Nonlinear Model (BGNLM) + +**Reference**: [@hubin2020flexible] + +
+ +Show equations + +$$ +\begin{aligned} +Y_i \mid \mu_i, \phi &\sim \mathfrak{f}(y \mid \mu_i,\phi), \quad i = 1,\dots,n,\\ +\mathsf{h}(\mu_i) &= \beta_0 + \sum_{j=1}^{q} \gamma_j \beta_j F_j(\mathbf{x}_i, \boldsymbol{\alpha}_j) + \sum_{k=1}^{r} \delta_k. +\end{aligned} +$$ + +
+ +- **Predictors (features)**: $F_j(\mathbf{x}_i, \boldsymbol{\alpha}_j)$, $j=1,\dots,q$\ +- **Random effects**: $\delta_k$\ +- **Total models**: $2^{q+r}$ + +### Feature space + +Depending on allowed nonlinear functions $\mathbb{G}$: neural nets (sigmoid), decision trees (thresholds), MARS (hinges), fractional polynomials, logic regression, etc. + +### Transformations available in `FBMS` + +| Name | Function | Name | Function | +|---------|---------------------------|---------|--------------------------| +| sigmoid | $1 / (1 + \exp(-x))$ | sqroot | $|x|^{1/2}$ | +| relu | $\max(x, 0)$ | troot | $|x|^{1/3}$ | +| nrelu | $\max(-x, 0)$ | sin_deg | $\sin(x/180 \cdot \pi)$ | +| hs | $x > 0$ | cos_deg | $\cos(x/180 \cdot \pi)$ | +| nhs | $x < 0$ | exp_dbl | $\exp(-|x|)$ | +| gelu | $x \Phi(x)$ | gauss | $\exp(-x^2)$ | +| ngelu | $-x \Phi(-x)$ | erf | $2 \Phi(\sqrt{2}x) - 1$ | +| pm2 | $x^{-2}$ | p0pm2 | $p0(x) \cdot x^{-2}$ | +| pm1 | $\text{sign}(x) |x|^{-1}$ | p0pm05 | $p0(x) \cdot |x|^{-0.5}$ | +| pm05 | $|x|^{-0.5}$ | p0p0 | $p0(x)^2$ | +| p05 | $|x|^{0.5}$ | p0p05 | $p0(x) \cdot |x|^{0.5}$ | +| p2 | $x^2$ | p0p1 | $p0(x) \cdot x$ | +| p3 | $x^3$ | p0p2 | $p0(x) \cdot x^2$ | +| | | p0p3 | $p0(x) \cdot x^3$ | + +*Custom functions can be added to* $\mathbb{G}$. + +------------------------------------------------------------------------ + +## Priors + +### Model priors + +Let $M = (\gamma_1, \dots, \gamma_q)$ (for linear models $q=p$). + +**Penalizing complexity priors** + +
+ +Show equation + +$$ +P(M) \propto \mathbb{I}(|\boldsymbol\gamma_{1:q}| \le Q) + \prod_{j=1}^q r^{\gamma_j c(F_j(\mathbf{x}, \boldsymbol{\alpha}_j))}, \quad 0 < r < 1, +$$ + +- $c(F_j(\cdot))$: complexity measure (linear models: $c(x)=1$; BGNLM counts algebraic operators). + +
+ + The following parameter will be used to change the prior penalization. + +``` r +# model prior complexity penalty +model_prior = list(r = 0.005) #default is 1/n +``` + +### Parameter priors + +**Mixtures of g-priors** + +
+ +Show equations + +$$ +\begin{aligned} +P(\beta_0, \phi \mid M) &\propto \phi^{-1}, \\ +P(\boldsymbol{\beta} \mid g) &\sim \mathbb{N}_{|M|}\!\left(\mathbf{0},\, g \cdot \phi\, J_n(\boldsymbol{\beta})^{-1}\right), \\ +\frac{1}{1+g} &\sim \text{tCCH}\!\left(\frac{a}{2}, \frac{b}{2}, \rho, \frac{s}{2}, v, \kappa\right). +\end{aligned} +$$ + +
+ +- **Robust-g** (convenient default): $a=1, b=2, \rho=1.5, s=0, v=\frac{n+1}{|M|+1}, \kappa=1$. + +**Jeffreys prior** + +
+ +Show equations + +$$ +P(\phi \mid M) = \phi^{-1}, \quad +P(\beta_0, \boldsymbol{\beta} \mid M) = |J_n(\beta_0, \boldsymbol{\beta})|^{1/2}. +$$ + +
+ +**All priors from the table below (default is the g-prior)** + +### Parameter priors available (and where to tune) + +| Prior (Alias) | $a$ | $b$ | $\rho$ | $s$ | $v$ | $k$ | Families | +|---------|---------|---------|---------|---------|---------|---------|---------| +| **Default:** | | | | | | | | +| `g-prior` | $g$ (default: $\max(n, p^2)$) | | | | | | GLM | +| **tCCH-Related Priors:** | | | | | | | | +| `CH` | $a$ | $b$ | 0 | $s$ | 1 | 1 | GLM | +| `uniform` | 2 | 2 | 0 | 0 | 1 | 1 | GLM | +| `Jeffreys` | 0 | 2 | 0 | 0 | 1 | 1 | GLM | +| `beta.prime` | $1/2$ | $n - p_M - 1.5$ | 0 | 0 | 1 | 1 | GLM | +| `benchmark` | 0.02 | $0.02 \max(n, p^2)$ | 0 | 0 | 1 | 1 | GLM | +| `TG` | $2a$ | 2 | 0 | $2s$ | 1 | 1 | GLM | +| `ZS-adapted` | 1 | 2 | 0 | $n + 3$ | 1 | 1 | GLM | +| `robust` | 1 | 2 | 1.5 | 0 | $(n+1)/(p_M+1)$ | 1 | GLM | +| `hyper-g-n` | 1 | 2 | 1.5 | 0 | 1 | $1/n$ | GLM | +| `intrinsic` | 1 | 1 | 1 | 0 | $(n + p_M + 1)/(p_M + 1)$ | $(n + p_M + 1)/n$ | GLM | +| `tCCH` | $a$ | $b$ | $\rho$ | $s$ | $v$ | $k$ | GLM | +| **Other Priors:** | | | | | | | | +| `EB-local` | $a$ | | | | | | GLM | +| `EB-global` | $a$ | | | | | | G | +| `JZS` | $a$ | | | | | | G | +| `ZS-null` | $a$ | | | | | | G | +| `ZS-full` | $a$ | | | | | | G | +| `hyper-g` | $a$ | | | | | | GLM | +| `hyper-g-laplace` | $a$ | | | | | | G | +| `AIC` | None | | | | | | GLM | +| `BIC` | None | | | | | | GLM | +| `Jeffreys-BIC` | Var | | | | | | GLM | + +*Here* $p_M$ is the number of predictors excluding the intercept. "G" denotes Gaussian-only; "GLM" additionally includes binomial, Poisson, and gamma. + +**How to switch priors in code (be explicit):** + +``` r +# g-prior with g = 1000 +beta_prior = list(type = "g-prior", alpha = 1000) + +# Robust prior (tune by Table parameters) +beta_prior = list(type = "robust") + +# Jeffreys-BIC +beta_prior = list(type = "Jeffreys-BIC") + +# Generic tCCH (provide all hyperparameters explicitly) +beta_prior = list(type = "tCCH", a = 2, b = 2, rho = 0, s = 0, v = 1, k = 1) +``` + +------------------------------------------------------------------------ + +# Inference algorithms + +### Model posterior + +
+ +Show equations + +**Marginal likelihood** $$ +P(D|M) = \int_{\Theta_M} P(D|\theta_M, M) \, P(\theta_M|M) \, d\theta_M. +$$ + +**Posterior** $$ +P(M|D) = \frac{P(D|M) P(M)}{\sum_{M' \in \Omega} P(D|M') P(M')}. +$$ + +**Approximation over discovered models** $\Omega^*$ $$ +P(M|D) \approx \frac{P(D|M) P(M)}{\sum_{M' \in \Omega^*} P(D|M') P(M')}, \quad M \in \Omega^*. +$$ + +**Marginal inclusion probability** $$ +P(\gamma_j=1|D) \approx \sum_{M \in \Omega^*: \gamma_j=1} P(M|D). +$$ + +
+ +### MCMC, MJMCMC, GMJMCMC + +- Variable selection spans exponential number of models; naive MCMC can get trapped.\ +- **MJMCMC**: random mode jumps + local improvements; valid MH acceptance [@hubin2018mode].\ +- **GMJMCMC**: embeds MJMCMC in a genetic algorithm to traverse huge spaces [@hubin2020logic; @hubin2020flexible].\ +- **RGMJMCMC**: reversible version [@hubin2021reversible].\ +- **Subsampling**: efficient for tall data [@lachmann2022subsampling]. + +### Parallelization + +Run multiple chains and aggregate unique models $\Omega^*$: + +
+ +Show equation + +$$ +\widehat{P}(\Delta|D) = \sum_{M \in \Omega^*} P(\Delta|M,D) \, \widehat{P}(M|D). +$$ + +
+ +```{r} + +# Parameters for parallel runs are set to a single thread and single core to comply with CRAN requirenments (please tune for your machine if you have more capacity) +runs <- 1 # 1 set for simplicity; use rather 16 or more +cores <- 1 # 1 set for simplicity; use rather 8 or more +``` + +------------------------------------------------------------------------ + +# Example 1 — BGNLM: recovering Kepler’s third law + +**Data**: $n=939$ exoplanets; variables include `semimajoraxis`, `period`, `hoststar_mass`, etc.\ +Target relationship: ${a \approx K_2 \left(P^2 M_h\right)^{1/3}}$. + +We shall run a single chain **GMJMCMC** + +```{r} +# Load example +data <- FBMS::exoplanet + +# Choose a small but expressive transform set for a quick demo +transforms <- c("sigmoid", "sin_deg", "exp_dbl", "p0", "troot", "p3") + +# ---- fbms() call (simple GMJMCMC) ---- +# Key parameters (explicit): +# - formula : semimajoraxis ~ 1 + . # response and all predictors +# - data : data # dataset +# - beta_prior : list(type = "g-prior") # parameter prior +# - model_prior : list(r = 1/dim(data)[1]) # model prior +# - method : "gmjmcmc" # exploration strategy +# - transforms : transforms # nonlinear feature dictionary +# - P : population size per generation (search breadth) +result_single <- fbms( + formula = semimajoraxis ~ 1 + ., + data = data, + beta_prior = list(type = "g-prior", alpha = dim(data)[1]), + model_prior = list(r = 1/dim(data)[1]), + method = "gmjmcmc", + transforms = transforms, + P = 20 +) + +# Summarize +printn(summary(result_single)) +``` + +**and a parallel GMJMCMC** + +```{r} + +# ---- fbms() call (parallel GMJMCMC) ---- +# Key parameters (explicit): +# - formula : semimajoraxis ~ 1 + . # response and all predictors +# - data : data # dataset +# - beta_prior : list(type = "g-prior") # parameter prior +# - model_prior : list(r = 1/dim(data)[1]) # model prior +# - method : "gmjmcmc" # exploration strategy +# - transforms : transforms # nonlinear feature dictionary +# - runs, cores : parallelization controls +# - P : population size per generation (search breadth) +result_parallel <- fbms( + formula = semimajoraxis ~ 1 + ., + data = data, + beta_prior = list(type = "g-prior", alpha = dim(data)[1]), + model_prior = list(r = 1/dim(data)[1]), + method = "gmjmcmc.parallel", + transforms = transforms, + runs = runs*10, # by default the rmd has runs = 1; increase for convergence + cores = cores, # by default the rmd has cores = 1; increase for convergence + P = 20 +) + +# Summarize +printn(summary(result_parallel)) +``` + +**Plot output** + +```{r} +plot(result_parallel) +``` + +**Convergence plots** + +```{r} +diagn_plot(result_parallel) +``` + +------------------------------------------------------------------------ + +# Example 2 — Bayesian linear models + +**Reference**: [@hubin2018mode] + +
+ +Model + +$$ +\begin{aligned} +Y_i \mid \mu_i, \phi &\sim \mathfrak{f}(y\mid \mu_i, \phi), \quad i=1,\dots,n, \\ +\mathsf{h}(\mu_i) &= \beta_0 + \sum_{j=1}^{p} \gamma_j \beta_j x_{ij}. +\end{aligned} +$$ + +
+ +We simulate data with a known sparse truth and run **MJMCMC** with an explicit **g-prior**. + +```{r} +library(mvtnorm) + +n <- 100 # sample size +p <- 20 # number of covariates +k <- 5 # size of true submodel + +correct.model <- 1:k +beta.k <- (1:5)/5 + +beta <- rep(0, p) +beta[correct.model] <- beta.k + +set.seed(123) +x <- rmvnorm(n, rep(0, p)) +y <- x %*% beta + rnorm(n) + +# Standardize +y <- scale(y) +X <- scale(x) / sqrt(n) + +df <- as.data.frame(cbind(y, X)) +colnames(df) <- c("Y", paste0("X", seq_len(ncol(df) - 1))) + +printn(correct.model) +printn(beta.k) +``` + +**Run MJMCMC with a g-prior (g = 100)** + +```{r} +# ---- fbms() call (MJMCMC) ---- +# Explicit prior choice: +# beta_prior = list(type = "g-prior", alpha = 100) +# To switch to another prior, e.g. robust: +# beta_prior = list(type = "robust") +result.lin <- fbms( + formula = Y ~ 1 + ., + data = df, + method = "mjmcmc", + N = 5000, # number of iterations + beta_prior = list(type = "g-prior", alpha = 100) +) +``` + +**Plot results** + +```{r} +plot(result.lin) +``` + +**Summarize with posterior effects** + +```{r} +# 'effects' specifies quantiles for posterior modes of effects across models +printn(summary(result.lin, effects = c(0.5, 0.025, 0.975))) +``` + +------------------------------------------------------------------------ + +**Run parallel MJMCMC** + +```{r} +# ---- fbms() call (parallel MJMCMC) ---- +# Explicit prior choice: +# beta_prior = list(type = "g-prior", alpha = 100) +# To switch to another prior, e.g. robust: +# beta_prior = list(type = "robust") +# method = mjmcmc.parallel +# runs, cores : parallelization controls +result.lin.par <- fbms( + formula = Y ~ 1 + ., + data = df, + method = "mjmcmc.parallel", + N = 5000, # number of iterations + beta_prior = list(type = "g-prior", alpha = 100), + runs = runs, + cores = cores +) +printn(summary(result.lin.par, effects = c(0.5, 0.025, 0.975))) +``` + +# Example 3 — Bayesian Fractional Polynomials (FP) + +**Reference**: [@hubin2023fractional] + +We augment the linear example to follow an FP truth and fit with **GMJMCMC**. + +
+ +FP model class + +$$ +\begin{aligned} +Y_i \mid \mu_i, \phi &\sim \mathfrak{f}(y|\mu_i,\phi),\\ +\mathsf{h}(\mu_i) &= \beta_0 + \sum_{j=1}^{p} \sum_{k \in K} \gamma_{jk}\, \beta_{jk}\, \rho_k(x_{ij}), \quad \text{with } K = \mathbf{F}_0 \cup \mathbf{F}_1 \cup \mathbf{F}_2, +\end{aligned} +$$ + +
+ +```{r} +# Create FP-style response with known structure, covariates are from previous example +df$Y <- p05(df$X1) + df$X1 + pm05(df$X3) + p0pm05(df$X3) + df$X4 + + pm1(df$X5) + p0(df$X6) + df$X8 + df$X10 + rnorm(nrow(df)) + +# Allow common FP transforms +transforms <- c( + "p0", "p2", "p3", "p05", "pm05", "pm1", "pm2", "p0p0", + "p0p05", "p0p1", "p0p2", "p0p3", "p0p05", "p0pm05", "p0pm1", "p0pm2" +) + +# Generation probabilities — here only modifications and mutations +probs <- gen.probs.gmjmcmc(transforms) +probs$gen <- c(0, 1, 0, 1) + +# Feature-generation parameters +params <- gen.params.gmjmcmc(ncol(df) - 1) +params$feat$D <- 1 # max depth 1 features +``` + +**Run GMJMCMC (single-thread)** + +```{r} +result <- fbms( + formula = Y ~ 1 + ., + data = df, + method = "gmjmcmc", + transforms = transforms, + beta_prior = list(type = "Jeffreys-BIC"), + probs = probs, + params = params, + P = 25 +) + +printn(summary(result)) +``` + +**Parallel GMJMCMC** + +```{r} +result_parallel <- fbms( + formula = Y ~ 1 + ., + data = df, + method = "gmjmcmc.parallel", + transforms = transforms, + beta_prior = list(type = "Jeffreys-BIC"), + probs = probs, + params = params, + P = 25, + runs = runs, + cores = cores +) + +printn(summary(result_parallel)) +``` + +------------------------------------------------------------------------ + +# Example 4 — Mixed-effects FP with interactions + +Dataset: $n=659$ kids; response $y$: standardized height; covariates: `c.bf, c.age, m.ht, m.bmi, reg`. Random intercept for `dr.`\ +We specify a **custom estimator** that uses a mixed model (via `lme4`), and plug it into `fbms()` with `family = "custom"`. We pass extra parameters of the estimator through `mlpost_params = list(dr = dr,r = r)` + +```{r} +# Custom approximate log marginal likelihood for mixed model using Laplace approximation +mixed.model.loglik.lme4 <- function (y, x, model, complex, mlpost_params) { + if (sum(model) > 1) { + x.model <- x[, model] + data <- data.frame(y, x = x.model[, -1], dr = mlpost_params$dr) + mm <- lmer(as.formula(paste0("y ~ 1 +", + paste0(names(data)[2:(ncol(data)-1)], collapse = "+"), + " + (1 | dr)")), data = data, REML = FALSE) + } else { + data <- data.frame(y, dr = mlpost_params$dr) + mm <- lmer(y ~ 1 + (1 | dr), data = data, REML = FALSE) + } + # log marginal likelihood (Laplace approx) + log model prior + mloglik <- as.numeric(logLik(mm)) - 0.5 * log(length(y)) * (ncol(data) - 2) + if (length(mlpost_params$r) == 0) mlpost_params$r <- 1 / nrow(x) + lp <- log_prior(mlpost_params, complex) + list(crit = mloglik + lp, coefs = fixef(mm)) +} +``` + +```{r} +library(lme4) +data(Zambia, package = "cAIC4") + +df <- as.data.frame(sapply(Zambia[1:5], scale)) + +transforms <- c("p0","p2","p3","p05","pm05","pm1","pm2", + "p0p0","p0p05","p0p1","p0p2","p0p3", + "p0p05","p0pm05","p0pm1","p0pm2") + +probs <- gen.probs.gmjmcmc(transforms) +probs$gen <- c(1, 1, 0, 1) # include modifications and interactions + +params <- gen.params.gmjmcmc(ncol(df) - 1) +params$feat$D <- 1 +params$feat$pop.max <- 10 + +result2a <- fbms( + formula = z ~ 1 + ., + data = df, + method = "gmjmcmc.parallel", + transforms = transforms, + probs = probs, + params = params, + P = 25, + N = 100, + runs = runs, + cores = cores, + family = "custom", + loglik.pi = mixed.model.loglik.lme4, + model_prior = list(r = 1 / nrow(df)), # model_prior is passed to mlpost_params + extra_params = list(dr = droplevels(Zambia$dr)) # extra_params are passed to mlpost_params +) + +printn(summary(result2a, tol = 0.05, labels = names(df)[-1])) +``` + +------------------------------------------------------------------------ + +# Example 5 — Bayesian Logic Regression + +**Reference**: [@hubin2020logic] + +
+ +Model + +$$ +\mathsf{h}(\mu_i) = \beta_0 + \sum_{j=1}^{q} \gamma_j \beta_j L_{ji}, \quad +L_{ji} \text{ are logic trees (e.g., } (x_{i1}\wedge x_{i2}) \vee x_{i3}^c ). +$$ + +
+ +We generate Boolean covariates and a known logic signal, define a custom estimator with a **logic prior**, and fit via **GMJMCMC**. + +```{r} +n <- 2000 +p <- 50 + +set.seed(1) +X2 <- as.data.frame(matrix(rbinom(n * p, size = 1, prob = runif(n * p, 0, 1)), n, p)) +y2.Mean <- 1 + 7*(X2$V4*X2$V17*X2$V30*X2$V10) + 9*(X2$V7*X2$V20*X2$V12) + + 3.5*(X2$V9*X2$V2) + 1.5*(X2$V37) + +Y2 <- rnorm(n, mean = y2.Mean, sd = 1) +df <- data.frame(Y2, X2) + +# Train/test split +df.training <- df[1:(n/2), ] +df.test <- df[(n/2 + 1):n, ] +df.test$Mean <- y2.Mean[(n/2 + 1):n] +``` + +**Custom estimator with logic regression priors** + +```{r} +estimate.logic.lm <- function(y, x, model, complex, mlpost_params) { + suppressWarnings({ + mod <- fastglm(as.matrix(x[, model]), y, family = gaussian()) + }) + mloglik <- -(mod$aic + (log(length(y)) - 2) * (mod$rank)) / 2 + wj <- complex$width + lp <- sum(log(factorial(wj))) - sum(wj * log(4 * mlpost_params$p) - log(4)) + logpost <- mloglik + lp + if (logpost == -Inf) logpost <- -10000 + list(crit = logpost, coefs = mod$coefficients) +} +``` + +**Run GMJMCMC** + +```{r} +set.seed(5001) + +# Only "not" operator; "or" is implied by De Morgan via "and" + "not" +transforms <- c("not") +probs <- gen.probs.gmjmcmc(transforms) +probs$gen <- c(1, 1, 0, 1) # no projections + +params <- gen.params.gmjmcmc(p) +params$feat$pop.max <- 50 +params$feat$L <- 15 + +result <- fbms( + formula = Y2 ~ 1 + ., + data = df.training, + method = "gmjmcmc", + transforms = transforms, + N = 500, + P = 25, + family = "custom", + loglik.pi = estimate.logic.lm, + probs = probs, + params = params, + model_prior = list(p = p) +) + +printn(summary(result)) + +# Extract models +mpm <- get.mpm.model(result, y = df.training$Y2, x = df.training[,-1], + family = "custom", loglik.pi = estimate.logic.lm, params = list(p = 50)) +printn(mpm$coefs) + +mpm2 <- get.mpm.model(result, y = df.training$Y2, x = df.training[,-1]) +printn(mpm2$coefs) + +mbest <- get.best.model(result) +printn(mbest$coefs) +``` + +**Prediction** + +```{r} +# Correct link is identity for Gaussian +pred <- predict(result, x = df.test[,-1], link = function(x) x) +pred_mpm <- predict(mpm, x = df.test[,-1], link = function(x) x) +pred_best <- predict(mbest, x = df.test[,-1], link = function(x) x) + +# RMSEs +printn(sqrt(mean((pred$aggr$mean - df.test$Y2)^2))) +printn(sqrt(mean((pred_mpm - df.test$Y2)^2))) +printn(sqrt(mean((pred_best - df.test$Y2)^2))) +printn(sqrt(mean((df.test$Mean - df.test$Y2)^2))) + +# Errors to the true mean (oracle) +printn(sqrt(mean((pred$aggr$mean - df.test$Mean)^2))) +printn(sqrt(mean((pred_best - df.test$Mean)^2))) +printn(sqrt(mean((pred_mpm - df.test$Mean)^2))) + +# Quick diagnostic plot +plot(pred$aggr$mean, df.test$Y2, + xlab = "Predicted (BMA)", ylab = "Observed") +points(pred$aggr$mean, df.test$Mean, col = 2) +points(pred_best, df.test$Mean, col = 3) +points(pred_mpm, df.test$Mean, col = 4) +``` + +------------------------------------------------------------------------ + +# Example 6 — Full BGNLM classification (Bernoulli): `spam` data + +We fit a binomial BGNLM and compare BMA, best-model, and MPM predictions.\ +**Important:** specify the correct link in `predict()` (here logistic). + +```{r} +library(kernlab) +data("spam") + +df <- spam[, c(58, 1:57)] +n <- nrow(df) +p <- ncol(df) - 1 + +colnames(df) <- c("y", paste0("x", 1:p)) +df$y <- as.numeric(df$y == "spam") + +to3 <- function(x) x^3 +transforms <- c("sigmoid","sin_deg","exp_dbl","p0","troot","to3") +probs <- gen.probs.gmjmcmc(transforms) +probs$gen <- c(1, 1, 1, 1) + +params <- gen.params.gmjmcmc(p) +params$feat$check.col <- FALSE + +set.seed(6001) +result <- fbms( + formula = y ~ 1 + ., + data = df, + method = "gmjmcmc", + family = "binomial", + beta_prior = list(type = "Jeffreys-BIC"), + transforms = transforms, + probs = probs, + params = params +) + +printn(summary(result)) +``` + +**Prediction accuracy** + +```{r} +# Logistic link +invlogit <- function(x) 1/(1 + exp(-x)) + +# Model averaging +pred <- predict(result, x = df[,-1], link = invlogit) +printn(mean(round(pred$aggr$mean) == df$y)) + +# Best model +bm <- get.best.model(result) +preds <- predict(bm, df[,-1], link = invlogit) +printn(mean(round(preds) == df$y)) + +# Median Probability Model +mpm <- get.mpm.model(result, family = "binomial", y = df$y, x = df[,-1]) +preds_mpm <- predict(mpm, df[,-1], link = invlogit) +printn(mean(round(preds_mpm) == df$y)) +``` + +------------------------------------------------------------------------ + +# References + +- Hubin, A., Storvik, G. (2018). *Mode jumping MCMC for Bayesian variable selection in GLMs.*\ +- Hubin, A., Frommlet, F., & Storvik, G. (2020). *Flexible Bayesian Model Averaging for Generalized Nonlinear Models.*\ +- Hubin, A., et al. (2020). *Bayesian Logic Regression via GMJMCMC.*\ +- Hubin, A., et al. (2021). *Reversible GMJMCMC.*\ +- Lachmann, J., et al. (2022). *Subsampling for tall data in GMJMCMC.* diff --git a/vignettes/GMJMCMC-guide.Rmd b/vignettes/GMJMCMC-guide.Rmd deleted file mode 100644 index b7cb73b3f5abcf103fd18d6fdf1e5e571a44f169..0000000000000000000000000000000000000000 --- a/vignettes/GMJMCMC-guide.Rmd +++ /dev/null @@ -1,61 +0,0 @@ ---- -title: "GMJMCMC - Genetically Modified Mode Jumping MCMC" -output: rmarkdown::html_vignette -vignette: > - %\VignetteIndexEntry{GMJMCMC - Genetically Modified Mode Jumping MCMC} - %\VignetteEngine{knitr::rmarkdown} - %\VignetteEncoding{UTF-8} - %\VignetteDepends{fastglm,GMJMCMC} ---- -The `GMJMCMC` package provides functions to estimate Bayesian Generalized nonlinear models (BGNLMs) through a Genetically Modified Mode Jumping MCMC algorithm. - - -```{r, include = FALSE} -knitr::opts_chunk$set( - collapse = TRUE, - comment = "#>" -) -``` -# Examples -Below are provided examples on how to run the algorithm and what the results tell us, we begin by loading the package and a supplied dataset -```{r setup} -library(GMJMCMC) -library(GenSA) -library(fastglm) -data("breastcancer") -bc <- breastcancer[,c(ncol(breastcancer),2:(ncol(breastcancer)-1))] -``` -We need some nonlinear transformations for the algorithm to use, the package offers a selection of these, but you are also able to define your own. Here we create a list of the ones to use, all but one are supplied by the package. -```{r} -to3 <- function(x) x^3 - -transforms <- c("sigmoid","sin.rad","exp.dbl","p0","troot","to3") -``` -By calling two functions in the package, a list of probabilities for various parts of the algorithm, as well as a list of parameters are created. The list of probabilities needs the list of transformations to be able to create the vector of probabilities for the different transformations -```{r} -probs <- gen.probs.gmjmcmc(transforms) -params <- gen.params.gmjmcmc(bc) -``` -We can use one of the supplied likelihood functions, but here we demonstrate how to create our own, it takes four arguments, the dependent $y$ variable, the matrix $X$ containing all independent variables, the model as a logical vector specifying the columns of $X$, and a list of complexity measures for the features involved in the model -```{r} -loglik.example <- function (y, x, model, complex, params) { - r <- 20/223 - suppressWarnings({mod <- fastglm(as.matrix(x[,model]), y, family=binomial())}) - ret <- (-(mod$deviance -2*log(r)*sum(complex$width)))/2 - return(list(crit=ret, coefs=mod$coefficients)) -} -``` -To be able to calculate the alphas when using for example strategy 3 as per Hubin et al., we need a function for the log likelihood, in this example we will use the function supplied by the package called `logistic.loglik.alpha`. With that function as a starting point, you can also create your own function for this. We also adjust our parameter list to use the third strategy. -```{r} -params$feat$alpha <- 3 -``` - -We are now ready to run the algorithm, in this vignette we will only run very few iterations for demonstration purposes, but the only thing that needs to be changed are the number or populations to visit `T`, the number of iterations per population `N` and the number of iterations for the final population `N.final` -```{r} -set.seed(1234) -result <- gmjmcmc(bc, loglik.example, logistic.loglik.alpha, transforms, P=3, N=30, N.final=60, probs, params) -``` -We can then summarize the results using the supplied function and get a plot of the importance of the parameters in the last population of features -```{r, fig.width=6, fig.height=6} -plot(result) -```