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..4cb41b610829a898b553a3475a0e6b04c327436f 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: @@ -24,6 +31,7 @@ Suggests: knitr, rmarkdown, markdown -RoxygenNote: 7.2.3 +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..2128090d196adadf719502b281ead1f3ff292570 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(compute_effects) +export(cos_deg) +export(diagn_plot) export(erf) -export(exp.dbl) +export(exp_dbl) +export(fbms) +export(fbms.mlik.master) export(gauss) 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,67 @@ 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(to23) export(to25) export(to35) +export(to72) 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,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,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..c3511ddd2afae309c84e3cc0abac1a0acc425768 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) 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,7 +34,10 @@ 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 <- set_alphas(featfun) @@ -37,23 +45,37 @@ alpha_3 <- function (feature, data, loglik) { 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) { + # Create the string representation of the feature with variable alphas + featfun <- print.feature(feature, dataset = TRUE, 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..854b4f2b719913fac2ede507fec57518f9f309e9 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,17 +119,73 @@ gen.probs.gmjmcmc <- function (transforms) { return(probs) } -#' Generate a parameter list for MJMCMC +#' Generate a parameter list for MJMCMC (Mode Jumping MCMC) #' #' @param data The dataset that will be used in the algorithm #' -#' @return A list of parameters to use when running the MJMCMC 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.} +#' } +#' } +#' +#' \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.} +#' } +#' } #' -#' 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) { ### Create a list of parameters for the algorithm @@ -66,7 +193,6 @@ gen.params.mjmcmc <- function (data) { ## 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), @@ -85,7 +211,7 @@ 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, @@ -94,10 +220,98 @@ gen.params.mjmcmc <- function (data) { return(params) } -#' Generate a parameter list for GMJMCMC +#' Generate a parameter list for GMJMCMC (Genetically Modified MJMCMC) #' -#' @param data The dataset that will be used in the algorithm +#' 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 data A data frame containing the dataset with covariates and response variable. +#' @return A list of parameters for controlling GMJMCMC behavior: +#' +#' @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(data) +#' str(params) +#' +#' @seealso \code{\link{gen.params.mjmcmc}}, \code{\link{gmjmcmc}} +#' #' @export gen.params.gmjmcmc gen.params.gmjmcmc <- function (data) { # Get mjmcmc params @@ -106,18 +320,27 @@ gen.params.gmjmcmc <- function (data) { ncov <- ncol(data) - 2 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 + 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 = 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) + 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..f27deb26fbe94c0ec7f2132d6d70427f01cc0ec4 100644 --- a/R/diagnostics.R +++ b/R/diagnostics.R @@ -3,24 +3,8 @@ # 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 @@ -28,9 +12,16 @@ gmjmcmc.iact <- function (x) { #' @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 ylim limits for the plotting range, if unspecified, min and max of confidence intervals will be used #' -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(matrix(rnorm(600), 100), P = 2, gaussian.loglik, NULL, c("p0", "exp_dbl")) +#' diagnstats <- diagn_plot(result) +#' +#' @export +diagn_plot <- function (res, FUN = median, conf = 0.95, burnin = 0, window = 5, ylim = NULL) { if(length(res$thread.best)>0) matrix.results <- res$best.log.posteriors @@ -42,7 +33,10 @@ plot.diagn <- function (res, FUN = median, conf = 0.95, burnin = 0, window = 100 ub <- sr + qnorm(p = 1-(1-conf)/2)*sds lb <- sr - qnorm(p = 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") + if(length(ylim)==0) + ylim <- c(min(lb), max(ub)) + + plot(y = sr,x = (burnin+1):(dim(matrix.results)[1]), type = "l",col = 1,ylim = ylim, 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) diff --git a/R/fbms.R b/R/fbms.R new file mode 100644 index 0000000000000000000000000000000000000000..c4e4e60a9074fd60843767813dee6268d5bef1f3 --- /dev/null +++ b/R/fbms.R @@ -0,0 +1,123 @@ +#' 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" and "custom". Default is "gaussian". +#' @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 containing the variables in the model. If NULL, the variables are taken from the environment of the formula. Default is NULL. +#' @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) +#' plot(fbms_result) +#' +#' +#' @seealso \code{\link{mjmcmc}}, \code{\link{gmjmcmc}}, \code{\link{gmjmcmc.parallel}} +#' @export +fbms <- function(formula = NULL, family = "gaussian", data = NULL, impute = FALSE, + loglik.pi = gaussian.loglik, + method = "mjmcmc", verbose = TRUE, ...) { + if (family == "gaussian") + loglik.pi <- gaussian.loglik + else if (family == "binomial") + loglik.pi <- logistic.loglik + else if (family == "custom") + loglik.pi <- loglik.pi + 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)[, -1] + mis.Y <- which(is.na(Y)) + if(length(mis.Y)>0) + { + warning("Missing values in the response. Dropped.") + df <- data.frame(Y[-c(mis.Y)], X[-c(mis.Y),]) + } else df <- data.frame(Y, X) + + mis.All <- sum(is.na(df)) + imputed <- NULL + if(impute & mis.All>0) + { + print("Imputing missing values!") + na.matr <- data.frame(1*(is.na(df))) + names(na.matr) <- paste0("mis_",names(na.matr)) + cm <- colMeans(na.matr) + na.matr <- na.matr[,cm!=0] + for (i in seq_along(df)){ + df[[i]][is.na(df[[i]])] <- median(df[[i]], na.rm = TRUE) + } + imputed <- names(df)[cm!=0] + df <- data.frame(df,na.matr) + + rm(na.matr) + rm(cm) + print("Continue to sampling!") + } else if(mis.All>0){ + print("Dropping missing values!") + } + } else { + df <- data + 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(df, loglik.pi, verbose = verbose, ...) + else if (method == "mjmcmc") + res <- mjmcmc(df, loglik.pi, verbose = verbose, ...) + else if (method == "gmjmcmc.parallel") { + res <- gmjmcmc.parallel(data = df, loglik.pi = loglik.pi, verbose = verbose,...) + } + + else if (method == "gmjmcmc") + res <- gmjmcmc(df, loglik.pi, 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(df)[1:(dim(df)[2]-1)] + options(na.action=na.opt) + return(res) +} \ No newline at end of file diff --git a/R/feature.R b/R/feature.R index c34b3415c03d5272e37284fb684725c03667cfcd..08071753ae6c6baa93311db8fac502096d4bcdc2 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 @@ -99,7 +101,13 @@ update.alphas <- function (feature, alphas, recurse=FALSE) { #' @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(matrix(rnorm(600), 100), P = 2, gaussian.loglik, NULL, c("p0", "exp_dbl")) +#' print(result$populations[[1]][1]) +#' #' @export print.feature <- function (x, dataset = FALSE, alphas = FALSE, labels = FALSE, round = FALSE, ...) { fString <- "" @@ -111,7 +119,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,21 +127,21 @@ 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], "*") } @@ -144,7 +152,7 @@ print.feature <- function (x, dataset = FALSE, alphas = FALSE, labels = FALSE, r } # This is a plain covariate else if (is.numeric(feat)) { - if (dataset) fString <- paste0("data[,", feat+2, "]") + if (dataset) fString <- paste0("data[,", feat + 2, "]") else if (labels[1] != F) fString <- labels[feat] else fString <- paste0("x", feat) } else stop("Invalid feature structure") diff --git a/R/feature_generation.R b/R/feature_generation.R index 7d25b3e54abd1052d8507d79249efcb68c461a08..999384cba88c5e07931189098ce1500c5c9e3e7a 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 @@ -79,7 +79,7 @@ check.collinearity <- function (proposal, features, F.0.size, data, 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])), ]) + mock.data <- check.data(data[seq_len(min(F.0.size * 2, dim(data)[1])), ], FALSE) # 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 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..5cd999d647ff46bcbddea509a2abc3932d31d013 100644 --- a/R/gmjmcmc.R +++ b/R/gmjmcmc.R @@ -4,21 +4,20 @@ # 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 +#' first column should be the dependent variable, #' 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. +#' @param P The number of generations for GMJMCMC (Genetically Modified MJMCMC). #' 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) @@ -26,20 +25,51 @@ NULL #' @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 models per population.} +#' \item{lo.models}{All local optimization models 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(matrix(rnorm(600), 100), P = 2, gaussian.loglik, NULL, 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 ( + 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, + verbose = TRUE +) { # Verify that the data is well-formed - data <- check.data(data) + labels <- names(data)[-1] + data <- check.data(data, verbose) # 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) # 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) @@ -59,10 +89,10 @@ gmjmcmc <- function (data, loglik.pi = gaussian.loglik, loglik.alpha = gaussian. # Create first population F.0 <- gen.covariates(ncol(data) - 2) - if (is.null(params$feat$prel.filter)) + 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]]) @@ -77,14 +107,14 @@ gmjmcmc <- function (data, loglik.pi = gaussian.loglik, loglik.alpha = gaussian. # 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$loglik, 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, 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 @@ -98,13 +128,15 @@ gmjmcmc <- function (data, loglik.pi = gaussian.loglik, loglik.alpha = gaussian. # Store best marginal model probability for current population best.margs[[p]] <- mjmcmc_res$best.crit # 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]])) } @@ -124,14 +156,16 @@ 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 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,29 +176,44 @@ 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))) - + + # Always keep original covariates if that setting is on if (params$keep.org) { 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 feats.replace <- which(!feats.keep) @@ -174,30 +223,42 @@ 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)) { + 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..db52330fdf26b61e2b24d3b397d58dd09db08c8c 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,13 @@ 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(matrix(rnorm(600), 100), P = 2, gaussian.loglik, NULL, c("p0", "exp_dbl")) +#' marginal.probs(result$models[[1]]) +#' #' @export marginal.probs <- function (models) { mod.count <- length(models) @@ -46,13 +61,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) @@ -89,7 +109,15 @@ precalc.features <- function (data, features) { # 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 = visited.models, sub = 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 @@ -98,7 +126,7 @@ loglik.pre <- function (loglik.pi, model, complex, data, params = NULL) { 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,14 +135,14 @@ 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) { +check.data <- function (data, verbose) { if (!is.matrix(data)) { data <- as.matrix(data) - cat("Data coerced to matrix type.\n") + if (verbose) cat("Data 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 (verbose) cat("Intercept added to data.\n") } return(data) } @@ -129,11 +157,11 @@ data.dims <- function (data) { } # Function to extract column names if they are well formed -get.labels <- function (data) { +get.labels <- function (data, verbose) { labels <- colnames(data)[-(1:2)] if (is.null(labels)) return(F) if (sum(is.na(labels)) != 0) { - cat("NA labels present, using x#\n") + if (verbose) cat("NA labels present, using x#\n") return(F) } return(labels) 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..1522ccbef1b5b2c1d4a781fd6f7a3f75eb09879f 100644 --- a/R/likelihoods.R +++ b/R/likelihoods.R @@ -3,7 +3,171 @@ # 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. +#' +#' @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, 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, params = list(r = exp(-0.5), family = "binomial", prior_beta = Jeffreys(), laplace = FALSE)) { + if (length(params) == 0) + params <- list(r = 1/dim(x)[1], family = "binomial", prior_beta = g.prior(max(dim(x)[1],sum(model)-1)), 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 + + tryCatch({ + if(params$family == "binomial") + 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 = params$prior_beta, + family = binomial(), + Rcontrol = glm.control(), + Rlaplace = as.integer(params$laplace)) + }) + else if(params$family == "poisson") + 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 = params$prior_beta, + family = poisson(), + Rcontrol = glm.control(), + Rlaplace = as.integer(params$laplace)) + }) + else{ + 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 = params$prior_beta, + family = Gamma(), + Rcontrol = glm.control(), + Rlaplace = as.integer(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) { + return(list(crit = -.Machine$double.xmax + log(params$r * sum(complex$oc)),coefs = rep(0,p+1))) + } + + if(p == 0) + { + ret <- mod$logmarg[2] + log(params$r) * sum(complex$oc) + return(list(crit=ret, coefs=mod$mle[[2]])) + } + ret <- mod$logmarg + log(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 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, params = list(r = exp(-0.5),prior_beta = "g-prior",alpha = 4)) { + if (length(params) == 0) + params <- list(r = 1/dim(x)[1], prior_beta = 0,alpha = max(dim(x)[1],sum(model)^2)) + + + 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(params$alpha)>0,as.numeric(params$alpha),NULL), + method = as.integer(params$prior_beta), + 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) { + return(list(crit = -.Machine$double.xmax + log(params$r * sum(complex$oc)),coefs = rep(0,p+1))) + } + + if(p == 0) + { + ret <- mod$logmarg[2] + log(params$r) * sum(complex$oc) + return(list(crit=ret, coefs=mod$mle[[2]])) + } + ret <- mod$logmarg + log(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. #' @@ -13,28 +177,59 @@ #' @param complex A list of complexity measures for the features #' @param 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, params = list(r = exp(-0.5))) { + if (length(params) == 0) + params <- list(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 + ret <- (-(mod$deviance + log(length(y)) * (mod$rank - 1) - 2 * log(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 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, params = list(r = exp(-0.5),family = "Gamma")) { + if (length(params) == 0) + params <- list(r = 1/dim(x)[1]) + + if(params$family == "binomial") + { + fam = binomial() + }else if(params$family == "poisson"){ + fam = poisson() + }else + { + fam = Gamma() + } + + suppressWarnings({mod <- fastglm(as.matrix(x[, model]), y, family = fam)}) + ret <- (-(mod$deviance + log(length(y)) * (mod$rank - 1) - 2 * log(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 @@ -42,33 +237,32 @@ logistic.loglik.alpha <- function (a, data, mu_func) { #' @param complex A list of complexity measures for the features #' @param 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() + if (length(params$r) == 0) + params$r <- 1/dim(x)[1] + if(length(params$var) == 0) + params$var <- 1 + suppressWarnings({mod <- fastglm(as.matrix(x[, model]), y, family = gaussian())}) - if(length(params) == 0) - params = list(r = 1/dim(x)[1]) + if(params$var == "unknown") + ret <- (-(mod$aic + (log(length(y))-2) * (mod$rank) - 2 * log(params$r) * (sum(complex$oc)))) / 2 + else + ret <- (-(mod$deviance/params$var + log(length(y)) * (mod$rank - 1) - 2 * log_prior(params, complex))) / 2 - 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 return(list(crit=ret, coefs=mod$coefficients)) } -#' 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 -#' -#' @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]. -#' -#' @export gaussian.loglik.alpha -gaussian.loglik.alpha <- function (a, data, mu_func) { - m <- eval(parse(text=mu_func)) - sum((data[,1]-m)^2) -} -#' Log likelihood function for gaussian regression with a prior p(m)=r*sum(total_width), using subsampling. +#' 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 @@ -76,16 +270,214 @@ gaussian.loglik.alpha <- function (a, data, mu_func) { #' @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 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, params = NULL) +{ + if(length(params)==0) + params <- list() + if (length(params$r) == 0) + 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(params$r) == 0 || length(params$g) == 0) + { + params$r <- 1/dim(x)[1] + params$g <- max(mod$rank^2,length(y)) + } + + # logarithm of marginal likelihood + mloglik <- 0.5*(log(1.0 + params$g) * (dim(x)[1] - mod$rank) - log(1.0 + params$g * (1.0 - Rsquare)) * (dim(x)[1] - 1))*(mod$rank!=1) + + # logarithm of model prior + # default value or parameter r + lp <- log_prior(params, complex) + + return(list(crit = mloglik + lp, coefs = mod$coefficients)) } -#' Log likelihood function for linear regression using Zellners g-prior + +#' 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 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)), TRUE, list(oc=1)) +#' +#' @importFrom BAS phi1 hypergeometric1F1 hypergeometric2F1 +#' @importFrom tolerance F1 +#' @export +gaussian_tcch_log_likelihood <- function(y, x, model, complex, params = list(r = exp(-0.5), prior_beta = "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 + if (params$prior_beta[[1]] == "CH") { + # CH prior: b and s should be user-specified, with defaults if not provided + a <- ifelse(!is.null(params$prior_beta$a),params$prior_beta$a, 1) # Default to 1 if not specified + b <- ifelse(!is.null(params$prior_beta$b),params$prior_beta$b, 2) # Default to 1 if not specified + r <- 0 + s <- ifelse(!is.null(params$prior_beta$s), params$prior_beta$s, 1) # Default to 1 if not specified + v <- 1 + k <- 1 + + } else if (params$prior_beta[[1]] == "hyper-g") { + a <- 1 + b <- 2 + r <- 0 + s <- 0 + v <- 1 + k <- 1 + + } else if (params$prior_beta[[1]] == "uniform") { + a <- 2 + b <- 2 + r <- 0 + s <- 0 + v <- 1 + k <- 1 + + } else if (params$prior_beta[[1]] == "Jeffreys") { + a <- 0.0001 + b <- 2 + r <- 0 + s <- 0 + v <- 1 + k <- 1 + } else if (params$prior_beta[[1]] == "beta.prime") { + a <- 1/2 + b <- n - p_M - 1.5 + r <- 0 + s <- 0 + v <- 1 + k <- 1 + + } else if (params$prior_beta[[1]] == "benchmark") { + a <- 0.02 + b <- 0.02 * max(n, p_M^2) + r <- 0 + s <- 0 + v <- 1 + k <- 1 + + } else if (params$prior_beta[[1]] == "TG") { + + a <- 2 * ifelse(!is.null(params$prior_beta$a),params$prior_beta$a, 1) + b <- 2 + r <- 0 + s <- 2 * ifelse(!is.null(params$prior_beta$s),params$prior_beta$s, 1) + v <- 1 + k <- 1 + + } else if (params$prior_beta[[1]] == "ZS-adapted") { + a <- 1 + b <- 2 + r <- 0 + s <- n + 3 + v <- 1 + k <- 1 + } else if (params$prior_beta[[1]] == "robust") { + a <- 1 + b <- 2 + r <- 1.5 + s <- 0 + v <- (n + 1) / (p_M + 1) + k <- 1 + + } else if (params$prior_beta[[1]] == "hyper-g-n") { + a <- 1 + b <- 2 + r <- 1.5 + s <- 0 + v <- 1 + k <- 1 + + } else if (params$prior_beta[[1]] == "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 (params$prior_beta[[1]] == "tCCH") { + a <- params$prior_beta$a + b <- params$prior_beta$b + r <- params$prior_beta$rho + s <- params$prior_beta$s + v <- params$prior_beta$v + k <- params$prior_beta$k + }else { + stop("Unknown prior name: ", params$prior_beta) + } + + # + 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 = T)) + + 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 = T) + 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 = T) + 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(params$r) == 0) params$r <- 1/dim(x)[1] # default value or parameter r + + lp <- log_prior(params, complex) + + 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 @@ -93,14 +485,310 @@ gaussian.loglik.bic.irlssgd <- function (y, x, model, complex, params = list(r = #' @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) +#' @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, params = list(r = exp(-0.5))) { + if (length(params) == 0) + 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(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[,1] * log(m) + (1 - data[, 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 +#' +#' @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. +#' @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) +} + + +#' Log model prior function +#' @param params list of passed parameters of the likelihood in GMJMCMC +#' @param complex list of complexity measures of the features included into the model +#' +#' @return A numeric with the log model prior. +#' +#' @examples +#' log_prior(params = list(r=2), complex = list(oc = 2)) +#' +#' @export log_prior +log_prior <- function (params, complex) { + pl <- log(params$r) * (sum(complex$oc)) + return(pl) +} + + +#' Master Log Marginal Likelihood Function +#' +#' 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 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) +#' - 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) +#' +#' @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(rnorm(100), matrix(rnorm(100)), TRUE, list(oc = 1), list(family = "gaussian", prior_beta = "g-prior")) +#' +#' @importFrom BAS 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, params = list(family = "gaussian", prior_beta = "g-prior", r = exp(-0.5))) { + # Extract dimensions + n <- length(y) + p <- sum(model) - 1 # Number of predictors excluding intercept + + # Set default parameters if not fully specified + if (is.null(params$family)) params$family <- "gaussian" + if (is.null(params$prior_beta)) params$prior_beta <- "g-prior" + if (is.null(params$g)) params$g <- max(p^2, n) + if (is.null(params$n)) params$n <- n + if (is.null(params$r)) params$r <- 1/n + + # Ensure complex has oc if not provided, ignore by default + if (is.null(complex$oc)) complex$oc <- 0 + + # Homogenize and prepare params for nested calls + params_master <- params + params_nested <- list(r = params_master$r) + + # Define valid priors for each family + #glm_only_priors <- c("CCH", "tCCH", "TG") + glm_and_gaussian_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") + gaussian_only_priors <- c("ZS-null", "ZS-full", "hyper-g-laplace","BIC", "AIC", "JZS","EB-global") + + #review a bit + 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") + + all_priors <- c(glm_and_gaussian_priors, gaussian_only_priors) + #browser() + # Validate prior_beta + if (!params_master$prior_beta %in% all_priors) { + stop(sprintf("Prior '%s' is not supported. Supported priors: %s", + params_master$prior_beta, paste(all_priors, collapse = ", "))) + } + + # Decision logic based on family and prior_beta + if (params_master$family %in% c("binomial", "poisson", "gamma")) { + if (params_master$prior_beta %in% gaussian_only_priors) { + stop(sprintf("Prior '%s' is not supported for GLM family '%s'. Supported GLM priors: %s", + params_master$prior_beta, params_master$family, + paste(c(glm_only_priors, glm_and_gaussian_priors), collapse = ", "))) + } + + params_nested$family <- params_master$family + if (is.null(params_master$laplace)) params_nested$laplace <- FALSE else params_nested$laplace <- params_master$laplace + + #if(params_nested$laplace) + # print("Laplace approximations will be used") + + if (params_master$prior_beta == "Jeffreys-BIC") { + if(params_nested$family == "binomial") + result <- logistic.loglik(y, x, model, complex, params_nested) + else if(params_nested$family%in% c("poisson", "gamma")) + result <- glm.loglik(y, x, model, complex, params_nested) + + } else { + params_nested$prior_beta <- switch( + params_master$prior_beta, + "beta.prime" = beta.prime(n = n), + "CH" = CCH(alpha = if (is.null(params_master$a)) stop("a must be provided") else params_master$a, + beta = if (is.null(params_master$b)) stop("b must be provided") else params_master$b, + s = if (is.null(params_master$s)) stop("s must be provided") else params_master$s), + "EB-local" = EB.local(), + "g-prior" = g.prior(g = params_master$g), + "hyper-g" = hyper.g(alpha = if (is.null(params_master$a)) stop("a must be provided") else params_master$a), + "tCCH" = tCCH(alpha = if (is.null(params_master$a)) stop("a must be provided") else params_master$a, + beta = if (is.null(params_master$b)) stop("b must be provided") else params_master$b, + s = if (is.null(params_master$s)) stop("s must be provided") else params_master$s, + r = if (is.null(params_master$rho)) stop("rho must be provided") else params_master$rho, + v = if (is.null(params_master$v)) stop("v must be provided") else params_master$v, + theta = if (is.null(params_master$k)) stop("k must be provided") else params_master$k), + "intrinsic" = intrinsic(n = params_master$n), + "TG" = TG(alpha = if (is.null(params_master$a)) stop("a must be provided") else params_master$a), + "Jeffreys" = Jeffreys(), + "uniform" = tCCH(alpha = 2, + beta = 2, + s = 0, + r = 0, + v = 1, + theta = 1), + "benchmark" = tCCH(alpha = 0.02, + beta = 0.02*max(n,p^2), + s = 0, + r = 0, + v = 1, + theta = 1), + "ZS-adapted" = tCCH(alpha = 1, + beta = 2, + s = n + 3, + r = 0, + v = 1, + theta = 1), + "TG" = TG(alpha = if (is.null(params_master$a)) stop("a must be provided") else params_master$a), + "robust" = robust(n = if (is.null(params_master$n)) as.numeric(n) else as.numeric(params_master$n)), + "hyper-g-n" = hyper.g.n(alpha = if (is.null(params_master$a)) 3 else params_master$a, + n = params_master$n), + "BIC" = bic.prior(n = if (is.null(params_master$n)) n else params_master$n), + stop("Unrecognized prior_beta for GLM: ", params_master$prior_beta) + ) + result <- glm.logpost.bas(y, x, model, complex, params_nested) + } + } else if (params_master$family == "gaussian") { + + if (params_master$prior_beta %in% gaussian_not_robust) { + warning(sprintf("Prior '%s' is not reccomended supported for Gaussian family '%s'. Can be unstable for strong signals (R^2 > 0.9). Reccomended priors under Gaussian family: %s", + params_master$prior_beta, params_master$family, + paste(gaussian_robust, collapse = ", "))) + } + + params_nested$r <- params_master$r + + if (params_master$prior_beta %in% gaussian_tcch) { + + params_nested$prior_beta <- switch( + params_master$prior_beta, + "beta.prime" = list("beta.prime"), + "CH" = list("CH",a = if (is.null(params_master$a)) stop("a must be provided") else params_master$a, + b = if (is.null(params_master$b)) stop("b must be provided") else params_master$b, + s = if (is.null(params_master$s)) stop("s must be provided") else params_master$s), + "tCCH" = list("tCCH", a = if (is.null(params_master$a)) stop("a must be provided") else params_master$a, + b = if (is.null(params_master$b)) stop("b must be provided") else params_master$b, + s = if (is.null(params_master$s)) stop("s must be provided") else params_master$s, + rho = if (is.null(params_master$rho)) stop("rho must be provided") else params_master$rho, + v = if (is.null(params_master$v)) stop("v must be provided") else params_master$v, + k = if (is.null(params_master$k)) stop("k must be provided") else params_master$k), + "intrinsic" = list("intrinsic"), + "TG" = list("TG",a = if (is.null(params_master$a)) stop("a must be provided") else params_master$a, + s = if (is.null(params_master$s)) stop("s must be provided") else params_master$s), + "Jeffreys" = list("Jeffreys"), + "ZS-adapted" = list("ZS-adapted"), + "benchmark" = list("benchmark"), + "robust" = list("robust"), + "uniform" = list("uniform"), + stop("Unrecognized prior_beta for Gaussian GLM: ", params_master$prior_beta) + ) + result <- gaussian_tcch_log_likelihood(y, x, model, complex, params_nested) + + }else if (params_master$prior_beta == "Jeffreys-BIC") { + if (is.null(params_master$var)) params_nested$var <- "unknown" else params_nested$var <- params_master$var + result <- gaussian.loglik(y, x, model, complex, params_nested) + } else if (params_master$prior_beta %in% gaussian_bas) { + + params_nested$prior_beta <- switch( + params_master$prior_beta, + "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 + ) + if(params_master$prior_beta == "g-prior") + { + if (!is.null(params_master$g)) params_nested$g <- params_master$g else stop("g must be provided") + result <- gaussian.loglik.g(y, x, model, complex, params_nested) + } + else{ + if (!is.null(params_master$a)) params_nested$alpha <- params_master$a else params_nested$alpha = -1 + result <- lm.logpost.bas(y, x, model, complex, params_nested) + } + + } else { + stop("Unexpected error in prior_beta logic for Gaussian.") + } + } else { + stop("Unsupported family: ", params_master$family, ". Supported families are 'binomial', 'poisson', 'gamma', or 'gaussian'.") + } + + # Ensure consistent return structure + if (is.null(result$crit) || is.null(result$coefs)) { + stop("Error in computation: Returned result does not contain 'crit' and 'coefs'.") + } + + 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..28696f0ce504f856fbdf3a57842ea18ce02583ef 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,7 +13,7 @@ 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)) @@ -22,7 +22,7 @@ simulated.annealing <- function (model, data, loglik.pi, indices, complex, param 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) @@ -42,7 +42,7 @@ simulated.annealing <- function (model, data, loglik.pi, indices, complex, param 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 +50,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 +62,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 +80,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$loglik, 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$loglik, 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..8e6e57bb4cc6062c95df4ffb133a36b0d21f0e93 100644 --- a/R/mjmcmc.R +++ b/R/mjmcmc.R @@ -3,21 +3,38 @@ # 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 +#' first column should be the dependent variable, #' 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 verbose A logical denoting if messages should be printed +#' +#' @return A list containing the following elements: +#' \item{models}{All visited models.} +#' \item{accept}{Average acceptance rate of the chain.} +#' \item{lo.models}{All models visited during local optimization.} +#' \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(matrix(rnorm(600), 100), gaussian.loglik) +#' summary(result) +#' plot(result) #' #' @export mjmcmc -mjmcmc <- function (data, loglik.pi, N = 100, probs = NULL, params = NULL, sub = FALSE) { +mjmcmc <- function (data, loglik.pi = gaussian.loglik, N = 100, probs = NULL, params = NULL, sub = FALSE, verbose = TRUE) { # Verify that data is well-formed - data <- check.data(data) + labels <- names(data)[-1] + data <- check.data(data, verbose) # Generate default probabilities and parameters if there are none supplied. if (is.null(probs)) probs <- gen.probs.mjmcmc() @@ -32,22 +49,23 @@ mjmcmc <- function (data, loglik.pi, N = 100, probs = NULL, params = NULL, sub = # 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.res <- loglik.pre(loglik.pi, model.cur, complex, data, params$loglik, 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$labels <- labels 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,10 +75,20 @@ 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{lo.models}{All models visited during local optimization.} +#' \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.} #' -#' @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) { +#' @noRd +#' +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 @@ -70,53 +98,33 @@ mjmcmc.loop <- function (data, complex, loglik.pi, model.cur, N, probs, params, # 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 @@ -151,8 +159,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 +171,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 +206,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$loglik, 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..932782787e0a81155fb4a83ca42e9c2b69f8d6da 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,6 +65,9 @@ sqroot <- function(x) abs(x)^(1/2) #' @param x The vector of values #' @return The cube root of x #' +#' @examples +#' troot(27) +#' #' @export troot troot <- function(x) abs(x)^(1/3) @@ -57,7 +76,10 @@ troot <- function(x) abs(x)^(1/3) #' @param x The vector of values #' @return x^2.3 #' -#' @export troot +#' @examples +#' to23(2) +#' +#' @export to23 to23 <- function(x) abs(x)^(2.3) #' To the 7/2 power function @@ -65,7 +87,10 @@ to23 <- function(x) abs(x)^(2.3) #' @param x The vector of values #' @return x^(7/2) #' -#' @export troot +#' @examples +#' to72(2) +#' +#' @export to72 to72 <- function(x) abs(x)^(7/2) #' Gaussian function @@ -73,6 +98,9 @@ to72 <- function(x) abs(x)^(7/2) #' @param x The vector of values #' @return e^(-x^2) #' +#' @examples +#' gauss(2) +#' #' @export gauss gauss <- function(x) exp(-x*x) @@ -81,6 +109,9 @@ gauss <- function(x) exp(-x*x) #' @param x The vector of values #' @return x^(2.5) #' +#' @examples +#' to25(2) +#' #' @export to25 to25 <- function(x)abs(x)^(2.5) @@ -90,6 +121,9 @@ to25 <- function(x)abs(x)^(2.5) #' @param x The vector of values #' @return x^(3.5) #' +#' @examples +#' to35(2) +#' #' @export to35 to35 <- function(x)abs(x)^(3.5) @@ -98,6 +132,9 @@ to35 <- function(x)abs(x)^(3.5) #' @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 +143,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 +154,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 +165,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 +176,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 +187,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 +198,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 +209,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 +220,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 +231,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 +242,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 +253,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 +264,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 +275,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 +286,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 +298,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 +321,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 +333,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 +344,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 +356,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 +368,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 +379,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..839d6b7b7458e8f1ba1f5142e3b612fa1de65940 100644 --- a/R/parallel.R +++ b/R/parallel.R @@ -1,30 +1,136 @@ +#' 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, matrix(rnorm(600), 100), gaussian.loglik) +#' 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 <- rmclapply(seq_len(runs), args = list(...), mc.cores = cores, fun = mjmcmc) 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 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 ... Further parameters passed to mjmcmc. #' @return Results from multiple gmjmcmc runs +#' +#' @examples +#' result <- gmjmcmc.parallel( +#' runs = 1, +#' cores = 1, +#' list(populations = "best", complex.measure = 2, tol = 0.0000001), +#' matrix(rnorm(600), 100), +#' P = 2, +#' gaussian.loglik, +#' loglik.alpha = gaussian.loglik.alpha, +#' 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(runs = 2, 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, ...) { 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(data = data, loglik.pi = loglik.pi, loglik.alpha = loglik.alpha, transforms = transforms, ...), 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) + gc() return(merged) } diff --git a/R/predict.R b/R/predict.R index f76d5143d1948cf10dd6822a66cb7e455843dbef..3171f73fd1877edc049faf2bd49f02ec2d62d26b 100644 --- a/R/predict.R +++ b/R/predict.R @@ -1,6 +1,95 @@ +#' 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 ... 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.precalc <- model.matrix( + as.formula(paste0("~I(", paste0(names(object$coefs)[-1][object$coefs[-1]!=0], collapse = ")+I("), ")")), + data = x + ) + #browser() + if(dim(x.precalc)[2]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..fdc168180082d57112e512221a62eb613f418804 100644 --- a/R/results.R +++ b/R/results.R @@ -4,27 +4,61 @@ # 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, +#' list(populations = "best", complex.measure = 2, tol = 0.0000001), +#' matrix(rnorm(600), 100), +#' P = 2, +#' gaussian.loglik, +#' loglik.alpha = gaussian.loglik.alpha, +#' 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 @@ -43,11 +77,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 +87,6 @@ merge_results <- function (results, populations = NULL, complex.measure = NULL, } } - # Collect all features and their renormalized weighted values features <- vector("list") renorms <- vector("list") @@ -75,14 +106,16 @@ merge_results <- function (results, populations = NULL, complex.measure = NULL, } 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")))) 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] } @@ -93,8 +126,9 @@ merge_results <- function (results, populations = NULL, complex.measure = NULL, ## 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) + if (is.null(data)) mock.data <- matrix(runif((feat.count + 2)^2, -100, 100), ncol = feat.count + 2) + else mock.data <- check.data(data, FALSE) + mock.data.precalc <- precalc.features(mock.data, features)[,-(1:2)] # Calculate the correlation to find equivalent features @@ -103,7 +137,7 @@ merge_results <- function (results, populations = NULL, complex.measure = NULL, # 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 @@ -118,12 +152,43 @@ 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 + ) 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,17 +196,14 @@ 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) @@ -155,6 +217,15 @@ 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(matrix(rnorm(600), 100), P = 2, gaussian.loglik, NULL, 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="+") @@ -163,126 +234,188 @@ model.string <- function (model, features, link = "I", round = 2) { 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. +#' +#' @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 +#' +#' @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.} +#' } +#' +#' @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 +#' } #' #' @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)) +get.mpm.model <- function(result, y, x, labels = F, family = "gaussian", loglik.pi = gaussian.loglik, params = NULL) { + if (!family %in% c("custom","binomial","gaussian")) + warning("Unknown family specified. The default gaussian.loglik will be used.") - 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 - ) + if (family == "binomial") + loglik.pi <- logistic.loglik + + sm <- summary(result, labels = labels, verbose = FALSE) + mpm <- sm$feats.strings[sm$marg.probs > 0.5] + + x.precalc <- model.matrix( + as.formula(paste0("~I(", paste0(mpm, collapse = ")+I("), ")")), + data = x) + + model <- loglik.pi(y = y, x = x.precalc, model = rep(TRUE, length(mpm) + 1), complex = list(oc = 0), params = params) + class(model) <- "bgnlm_model" + model$crit <- "MPM" + 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. #' -#' @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 +#' @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}. #' -#' @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 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.} +#' } #' -#' @export -summary.mjmcmc <- function (object, tol = 0.0001, labels = FALSE, ...) { - return(summary.mjmcmc_parallel(list(object), tol = tol, labels = labels)) -} - -#' Function to print a quick summary of the results +#' @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.} +#' } #' -#' @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. +#' @examples +#' result <- gmjmcmc(matrix(rnorm(600), 100), P = 2, gaussian.loglik, NULL, 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")) { + return(get.best.model.mjmcmc(result, labels)) } - cat("\n") - feats.strings <- feats.strings[keep] - marg.probs <- marg.probs[1,keep] - - ord.marg <- order(marg.probs, decreasing = T) + 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,function(x)x$best.crit)) + return(get.best.model.mjmcmc(result[[best.chain]], labels)) + } + if (is(result,"gmjmcmc")) { + return(get.best.model.gmjmcmc(result, labels)) + } - return(data.frame(feats.strings = feats.strings[ord.marg], marg.probs = marg.probs[ord.marg])) + 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)) + return(get.best.model.gmjmcmc(result$results.raw[[best.chain]], labels)) + } +} + +get.best.model.gmjmcmc <- function (result, labels) { + if (length(labels) == 1 && labels[1] == FALSE && length(result$labels) > 0) { + labels = result$labels + } + 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]] + names(ret$coefs) <- c("Intercept",sapply(result$populations[[best.pop.id]],print.feature,labels = labels)[which(ret$model)]) + class(ret) = "bgnlm_model" + 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]] + names(ret$coefs) <- c("Intercept",sapply(result$populations,print.feature,labels = labels)[which(ret$model)]) + 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(matrix(rnorm(600), 100), P = 2, gaussian.loglik, NULL, 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(matrix(rnorm(600), 100), P = 2, gaussian.loglik, NULL, 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 +427,27 @@ 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(matrix(rnorm(600), 100), P = 2, gaussian.loglik, NULL, 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 +457,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 +468,15 @@ 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(matrix(rnorm(600), 100), 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)) { @@ -331,6 +490,8 @@ plot.mjmcmc <- function (x, count = "all", ...) { } 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,20 +499,26 @@ 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, matrix(rnorm(600), 100), 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])) { @@ -367,6 +534,7 @@ merge.mjmcmc_parallel <- function (x) { )) } + run.weigths <- function (results) { best.crits <- sapply(results, function (x) x$best.crit) max.crit <- max(best.crits) @@ -375,7 +543,64 @@ run.weigths <- function (results) { #' Plot a gmjmcmc_merged run #' @inheritParams plot.gmjmcmc +#' @return No return value, just creates a plot +#' +#' @examples +#' result <- gmjmcmc.parallel( +#' runs = 1, +#' cores = 1, +#' list(populations = "best", complex.measure = 2, tol = 0.0000001), +#' matrix(rnorm(600), 100), +#' P = 2, +#' gaussian.loglik, +#' loglik.alpha = gaussian.loglik.alpha, +#' 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, data, gaussian.loglik) +#' compute_effects(result,labels = names(data)[-1]) +#' +#' @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..10e731f48893ac5e5ef39e3ccb9ae3b5437223b0 --- /dev/null +++ b/R/summary.R @@ -0,0 +1,230 @@ +#' 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(matrix(rnorm(600), 100), P = 2, gaussian.loglik, NULL, 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, +#' list(populations = "best", complex.measure = 2, tol = 0.0000001), +#' matrix(rnorm(600), 100), +#' P = 2, +#' gaussian.loglik, +#' loglik.alpha = gaussian.loglik.alpha, +#' 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, 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(matrix(rnorm(600), 100), gaussian.loglik) +#' summary(result) +#' +#' @export +summary.mjmcmc <- function (object, tol = 0.0001, labels = FALSE, effects = NULL, verbose = TRUE, ...) { + if (length(labels) == 1 && labels[1] == FALSE && length(object$labels) > 0) + labels = object$labels + return(summary.mjmcmc_parallel(list(object), 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, matrix(rnorm(600), 100), 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[[1]]$labels) > 0) { + labels = object[[1]]$labels + } + 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)) + if (!is.null(effects) & !is.null(labels)) { + if (is.list(object)) + effects <- compute_effects(object[[1]],labels = labels, quantiles = effects) + else + effects <- compute_effects(object,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 final distribution + 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") + } + 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..08b826dee9d643833f3755dcc5cc2a5c401ffcc2 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/master) +[![](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/FBMS/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@FBMS", 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/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/compute_effects.Rd b/man/compute_effects.Rd new file mode 100644 index 0000000000000000000000000000000000000000..a0105914b43a1c83a6bba586d3f31fd7540108e8 --- /dev/null +++ b/man/compute_effects.Rd @@ -0,0 +1,33 @@ +% 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, data, gaussian.loglik) +compute_effects(result,labels = names(data)[-1]) + +} +\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/plot.diagn.Rd b/man/diagn_plot.Rd similarity index 55% rename from man/plot.diagn.Rd rename to man/diagn_plot.Rd index e3708a747bd6ad23f4ef2155c8b4ce98c19bb215..058797b7c2b6d4c91606b7ed44aac5573438870c 100644 --- a/man/plot.diagn.Rd +++ b/man/diagn_plot.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/diagnostics.R -\name{plot.diagn} -\alias{plot.diagn} +\name{diagn_plot} +\alias{diagn_plot} \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) +diagn_plot(res, FUN = median, conf = 0.95, burnin = 0, window = 5, ylim = NULL) } \arguments{ \item{res}{Object corresponding gmjmcmc output} @@ -16,10 +16,17 @@ \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} } \value{ -summary statistics with given confidence intervals +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(matrix(rnorm(600), 100), P = 2, gaussian.loglik, NULL, 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/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..55e251c17b3c2dab793fada583210bda413301f2 --- /dev/null +++ b/man/fbms.Rd @@ -0,0 +1,62 @@ +% 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", + data = NULL, + impute = FALSE, + loglik.pi = gaussian.loglik, + 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" and "custom". Default is "gaussian".} + +\item{data}{A data frame containing the variables in the model. If NULL, the variables are taken from the environment of the formula. Default is NULL.} + +\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) +plot(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..9ee5f71719152d50878656bca16700ddcbc9bee7 --- /dev/null +++ b/man/fbms.mlik.master.Rd @@ -0,0 +1,73 @@ +% 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, + params = list(family = "gaussian", prior_beta = "g-prior", r = exp(-0.5)) +) +} +\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{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 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) +}} +} +\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(rnorm(100), matrix(rnorm(100)), TRUE, list(oc = 1), list(family = "gaussian", prior_beta = "g-prior")) + +} diff --git a/man/gauss.Rd b/man/gauss.Rd index 944da4fdba205e7926818b7aa57646d0f4542a13..98af515a037ffb77ff33102427330d160988c789 100644 --- a/man/gauss.Rd +++ b/man/gauss.Rd @@ -15,3 +15,7 @@ e^(-x^2) \description{ Gaussian function } +\examples{ +gauss(2) + +} diff --git a/man/gaussian.loglik.Rd b/man/gaussian.loglik.Rd index 24ad6f841f776c21b88d07bafd87a1c22d3ef9a6..b0bbae6fcaee9fd983aed15673c470fcbf0656e3 100644 --- a/man/gaussian.loglik.Rd +++ b/man/gaussian.loglik.Rd @@ -2,7 +2,7 @@ % 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) } @@ -17,6 +17,14 @@ gaussian.loglik(y, x, model, complex, params) \item{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 64% rename from man/linear.g.prior.loglik.Rd rename to man/gaussian.loglik.g.Rd index ccd65f2b6a391207393c367308d0889290ca8a66..25619ae2c3491fc9f48ac9f9748142fd125237b0 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, params = NULL) } \arguments{ \item{y}{A vector containing the dependent variable} @@ -17,6 +17,13 @@ linear.g.prior.loglik(y, x, model, complex, params = list(g = 4)) \item{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..6cea042f2aea5e74c6dc6edb39c9df100ac416b8 --- /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, + params = list(r = exp(-0.5), prior_beta = "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{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)), 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..945cd644c4306c95c48e85a85b10da099cfdaf12 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) } \arguments{ -\item{data}{The dataset that will be used in the algorithm} +\item{data}{A data frame containing the dataset with covariates and response variable.} +} +\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(data) +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..0fe0b17f344a047c1161a6a6a4de4d8ce6f658fb 100644 --- a/man/gen.params.mjmcmc.Rd +++ b/man/gen.params.mjmcmc.Rd @@ -2,7 +2,7 @@ % 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) } @@ -10,13 +10,70 @@ gen.params.mjmcmc(data) \item{data}{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..42d8f9f36a38c8d351979b53d9a729ff7c6103da --- /dev/null +++ b/man/get.best.model.Rd @@ -0,0 +1,43 @@ +% 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(matrix(rnorm(600), 100), P = 2, gaussian.loglik, NULL, 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..3cc398db9ead7bb1cb0deefa295adec300438e63 --- /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, + 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{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..50eb6254123d6691baca1a4f6b09d4fdf784ede9 --- /dev/null +++ b/man/glm.logpost.bas.Rd @@ -0,0 +1,40 @@ +% 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, + params = list(r = exp(-0.5), family = "binomial", prior_beta = 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{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..471e01637e2275b6307ea6fe878a89860268a5cc 100644 --- a/man/gmjmcmc.Rd +++ b/man/gmjmcmc.Rd @@ -2,8 +2,7 @@ % 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, @@ -15,12 +14,13 @@ gmjmcmc( N.final = 100, probs = NULL, params = NULL, - sub = FALSE + 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 +first column should be the dependent variable, and the rest of the columns should be the independent variables.} \item{loglik.pi}{The (log) density to explore} @@ -30,7 +30,7 @@ and the rest of the columns should be the independent variables.} \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 generations for GMJMCMC. +\item{P}{The number of generations for GMJMCMC (Genetically Modified MJMCMC). 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.} @@ -43,8 +43,28 @@ A larger value like $P = 50$ might be more realistic for more complicated exampl \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!)} + +\item{verbose}{A logical denoting if messages should be printed} +} +\value{ +A list containing the following elements: +\item{models}{All models per population.} +\item{lo.models}{All local optimization models 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(matrix(rnorm(600), 100), P = 2, gaussian.loglik, NULL, 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..d51130d64e1e1a8c4d818b48e9589c0fbc6019e9 100644 --- a/man/gmjmcmc.parallel.Rd +++ b/man/gmjmcmc.parallel.Rd @@ -2,15 +2,15 @@ % 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, + runs = 2, cores = getOption("mc.cores", 2L), merge.options = list(populations = "best", complex.measure = 2, tol = 1e-07), data, loglik.pi = gaussian.loglik, - loglik.alpha = gaussian.loglik.alpha(), + loglik.alpha = gaussian.loglik.alpha, transforms, ... ) @@ -23,7 +23,7 @@ gmjmcmc.parallel( \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 +first column should be the dependent variable, and the rest of the columns should be the independent variables.} \item{loglik.pi}{The (log) density to explore} @@ -33,11 +33,28 @@ and the rest of the columns should be the independent variables.} \item{transforms}{A Character vector including the names of the non-linear functions to be used by the modification and the projection operator.} -\item{...}{Further params passed to mjmcmc.} +\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, + list(populations = "best", complex.measure = 2, tol = 0.0000001), + matrix(rnorm(600), 100), + P = 2, + gaussian.loglik, + loglik.alpha = gaussian.loglik.alpha, + 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..b089a5ff12af8edf0d651e5f18dfb2cf002eb2b2 --- /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, + params = list(r = exp(-0.5), prior_beta = "g-prior", alpha = 4) +) +} +\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, 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..80a87a1d4b15c93927d684a867de88581ba9f1fb --- /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(params, complex) +} +\arguments{ +\item{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(params = list(r=2), complex = list(oc = 2)) + +} diff --git a/man/logistic.loglik.Rd b/man/logistic.loglik.Rd index 69a581f0c6ed4e836d1a9d8f6bff7914bc8b85f6..0f8b07745f718de5a6d9008940154df671b03f87 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, params = list(r = exp(-0.5))) } \arguments{ \item{y}{A vector containing the dependent variable} @@ -19,8 +19,16 @@ logistic.loglik(y, x, model, complex, params = list(r = 1)) \item{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..32f7b8a3cb7dfc8c8db4f03d9c9b247c31dd3a8d --- /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, 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{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..53df969d500b4049e6bc8139bca5641e9b423313 100644 --- a/man/marginal.probs.Rd +++ b/man/marginal.probs.Rd @@ -9,6 +9,14 @@ 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(matrix(rnorm(600), 100), P = 2, gaussian.loglik, NULL, 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..c0a89ab7cdbc090677857a6c1ea028f6ae48d2a2 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,53 @@ 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, + list(populations = "best", complex.measure = 2, tol = 0.0000001), + matrix(rnorm(600), 100), + P = 2, + gaussian.loglik, + loglik.alpha = gaussian.loglik.alpha, + c("p0", "exp_dbl") +) + +summary(result) + +plot(result) + +merge_results(result$results) + +} diff --git a/man/mjmcmc.Rd b/man/mjmcmc.Rd index 29e3867e946ac57b945c5eaff65da1ad8a56ffac..9d2fe5892e85a89751fcabf21ffe98bd26ba93a1 100644 --- a/man/mjmcmc.Rd +++ b/man/mjmcmc.Rd @@ -2,13 +2,21 @@ % 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( + data, + loglik.pi = gaussian.loglik, + N = 100, + probs = NULL, + params = NULL, + 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 +first column should be the dependent variable, and the rest of the columns should be the independent variables.} \item{loglik.pi}{The (log) density to explore} @@ -20,7 +28,26 @@ and the rest of the columns should be the independent variables.} \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!)} + +\item{verbose}{A logical denoting if messages should be printed} +} +\value{ +A list containing the following elements: +\item{models}{All visited models.} +\item{accept}{Average acceptance rate of the chain.} +\item{lo.models}{All models visited during local optimization.} +\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(matrix(rnorm(600), 100), 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..756ce4f86cac4a8089b9ad715a64c0217bcd1692 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,9 @@ 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, matrix(rnorm(600), 100), gaussian.loglik) +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..7a3e8bea07b4a8a6580d1c5f0038895ffa4a5d83 100644 --- a/man/model.string.Rd +++ b/man/model.string.Rd @@ -15,6 +15,17 @@ 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(matrix(rnorm(600), 100), P = 2, gaussian.loglik, NULL, 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.gmjmcmc.Rd b/man/plot.gmjmcmc.Rd index 792750fdacd341c55262b85342cd8f948683feeb..ff2fd5def39c5153c5352207017db7046691c8c2 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,22 @@ 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(matrix(rnorm(600), 100), P = 2, gaussian.loglik, NULL, c("p0", "exp_dbl")) +plot(result) + + +} diff --git a/man/plot.gmjmcmc_merged.Rd b/man/plot.gmjmcmc_merged.Rd index 3e4620a3503e6d32ef8b127ffc10fb7ade60e9a7..f2aa5c6cf6a8c57b168a075da8dd3d193c5b2e3e 100644 --- a/man/plot.gmjmcmc_merged.Rd +++ b/man/plot.gmjmcmc_merged.Rd @@ -4,15 +4,38 @@ \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, + list(populations = "best", complex.measure = 2, tol = 0.0000001), + matrix(rnorm(600), 100), + P = 2, + gaussian.loglik, + loglik.alpha = gaussian.loglik.alpha, + c("p0", "exp_dbl") +) +plot(result) + +} diff --git a/man/plot.mjmcmc.Rd b/man/plot.mjmcmc.Rd index 6ee09c7792b25a27f1bcfc609ff553ca25a35d41..050e495b8836ed73d711214d01087ac2d8cf5b81 100644 --- a/man/plot.mjmcmc.Rd +++ b/man/plot.mjmcmc.Rd @@ -14,7 +14,15 @@ 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(matrix(rnorm(600), 100), gaussian.loglik) +plot(result) + +} diff --git a/man/plot.mjmcmc_parallel.Rd b/man/plot.mjmcmc_parallel.Rd index 844dac1168319c28edc72be25f8eea3dcceb767c..0a11c9258b86f1217c4264da86c4c495552f67ff 100644 --- a/man/plot.mjmcmc_parallel.Rd +++ b/man/plot.mjmcmc_parallel.Rd @@ -13,6 +13,14 @@ \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, matrix(rnorm(600), 100), 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..baf28bf0ad9c0f0c7e66c5635bb2ce56ec3292cf --- /dev/null +++ b/man/predict.bgnlm_model.Rd @@ -0,0 +1,55 @@ +% 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 + }, + ... +) +} +\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{...}{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..f154a4bc473412ef0057a8def9c2f46aa721a86e --- /dev/null +++ b/man/predict.gmjmcmc.Rd @@ -0,0 +1,51 @@ +% 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, + ... +) +} +\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{...}{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( + matrix(rnorm(600), 100), + P = 2, + gaussian.loglik, + loglik.alpha = gaussian.loglik.alpha, + 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..5679e4ca62dff6ee12940207a43eda04a7f21f85 100644 --- a/man/predict.gmjmcmc_merged.Rd +++ b/man/predict.gmjmcmc_merged.Rd @@ -2,9 +2,17 @@ % 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, + ... +) } \arguments{ \item{object}{The model to use.} @@ -13,10 +21,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{...}{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, + list(populations = "best", complex.measure = 2, tol = 0.0000001), + matrix(rnorm(600), 100), + P = 2, + gaussian.loglik, + loglik.alpha = gaussian.loglik.alpha, + 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..f2dd556cb2fb3ef8efa7ba58b7048ac2f2c87e78 --- /dev/null +++ b/man/predict.gmjmcmc_parallel.Rd @@ -0,0 +1,41 @@ +% 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), ...) +} +\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{...}{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, + list(populations = "best", complex.measure = 2, tol = 0.0000001), + matrix(rnorm(600), 100), + P = 2, + gaussian.loglik, + loglik.alpha = gaussian.loglik.alpha, + c("p0", "exp_dbl") +) +preds <- predict(result$results, matrix(rnorm(600), 100)) + +} diff --git a/man/predict.mjmcmc.Rd b/man/predict.mjmcmc.Rd new file mode 100644 index 0000000000000000000000000000000000000000..8d6c962a37054782bbb988e93ab6becee916aa28 --- /dev/null +++ b/man/predict.mjmcmc.Rd @@ -0,0 +1,32 @@ +% 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), ...) +} +\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{...}{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(matrix(rnorm(600), 100), gaussian.loglik) +preds <- predict(result, matrix(rnorm(500), 100)) + +} diff --git a/man/predict.mjmcmc_parallel.Rd b/man/predict.mjmcmc_parallel.Rd new file mode 100644 index 0000000000000000000000000000000000000000..cbacd449b801b581bb5cb9a7a364fb53b7a5248c --- /dev/null +++ b/man/predict.mjmcmc_parallel.Rd @@ -0,0 +1,32 @@ +% 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), ...) +} +\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{...}{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, matrix(rnorm(600), 100), gaussian.loglik) +preds <- predict(result, matrix(rnorm(500), 100)) + +} diff --git a/man/print.feature.Rd b/man/print.feature.Rd index 7731aab89659738cc860001dd9f825153d58d484..06eb37a72bc75ad51cc1201f5fed4f82acefba24 100644 --- a/man/print.feature.Rd +++ b/man/print.feature.Rd @@ -19,6 +19,14 @@ \item{...}{Not used.} } +\value{ +String representation of a feature +} \description{ Print method for "feature" class } +\examples{ +result <- gmjmcmc(matrix(rnorm(600), 100), P = 2, gaussian.loglik, NULL, 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..86c6d8165831b9cdc5121fac9af0f1ad39fc9e85 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,14 @@ 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(matrix(rnorm(600), 100), P = 2, gaussian.loglik, NULL, 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..5c6c70e2174f1c132f254b758814e8fba7a0a28a 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,14 @@ 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(matrix(rnorm(600), 100), P = 2, gaussian.loglik, NULL, 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..ca112c751666cc9e020af4c82f9ea1d032c97684 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,24 @@ \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(matrix(rnorm(600), 100), P = 2, gaussian.loglik, NULL, c("p0", "exp_dbl")) +summary(result, pop = "best") + +} diff --git a/man/summary.gmjmcmc_merged.Rd b/man/summary.gmjmcmc_merged.Rd index 20fb4e95064a624cb0f0f6137a5c10bf3b885a2d..b979eb95373885090f8b43a25bdcd92a44312b12 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,35 @@ \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, + list(populations = "best", complex.measure = 2, tol = 0.0000001), + matrix(rnorm(600), 100), + P = 2, + gaussian.loglik, + loglik.alpha = gaussian.loglik.alpha, + c("p0", "exp_dbl") +) +summary(result) + +} diff --git a/man/summary.mjmcmc.Rd b/man/summary.mjmcmc.Rd index c1127cc70b1e18cad709a6b2d791c940d7680e05..fde06a678d0ffe0850346596f60d33b3b908f819 100644 --- a/man/summary.mjmcmc.Rd +++ b/man/summary.mjmcmc.Rd @@ -1,18 +1,41 @@ % 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(matrix(rnorm(600), 100), gaussian.loglik) +summary(result) + +} diff --git a/man/summary.mjmcmc_parallel.Rd b/man/summary.mjmcmc_parallel.Rd index 3911a6c3710e15d4720da788c04e4d779e346560..fad3f4a63a936848ec192908256961c1ab97edfd 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,22 @@ \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, matrix(rnorm(600), 100), gaussian.loglik) +summary(result) + +} diff --git a/man/to23.Rd b/man/to23.Rd index a178f866de262bc764151ef11deda0ed663543ae..d71a0eb5377eff7d96f5ac60a6700013887580f3 100644 --- a/man/to23.Rd +++ b/man/to23.Rd @@ -15,3 +15,7 @@ x^2.3 \description{ To the 2.3 power function } +\examples{ +to23(2) + +} diff --git a/man/to25.Rd b/man/to25.Rd index ec77494311598a19e489c84d3092d0c2efff63c9..118c4622d7ad1fe69b0223654bf903876afaa694 100644 --- a/man/to25.Rd +++ b/man/to25.Rd @@ -15,3 +15,7 @@ x^(2.5) \description{ To 2.5 power } +\examples{ +to25(2) + +} diff --git a/man/to35.Rd b/man/to35.Rd index a4d8ce0ff34288af05d5fb5917a1d1be7b7c9665..50fe82bab149c8f6cd750064bba1757eeb077ec5 100644 --- a/man/to35.Rd +++ b/man/to35.Rd @@ -15,3 +15,7 @@ x^(3.5) \description{ To 3.5 power } +\examples{ +to35(2) + +} diff --git a/man/to72.Rd b/man/to72.Rd index 28293e94c1f69445e4c56341468eb5fb90ea131d..4f65c89c47bae34c5a262281c2e90475376e1392 100644 --- a/man/to72.Rd +++ b/man/to72.Rd @@ -15,3 +15,7 @@ x^(7/2) \description{ To the 7/2 power function } +\examples{ +to72(2) + +} 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_mjmcmc.R b/tests/testthat/test_mjmcmc.R index cca6672c6f1046494ee6ac90f87510ae0b390797..0257d461949927a75e7b243c6ab60cf71d017b9e 100644 --- a/tests/testthat/test_mjmcmc.R +++ b/tests/testthat/test_mjmcmc.R @@ -20,20 +20,35 @@ test_that("Testing MJMCMC algorithm", { 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])) + predm <- predict(resm, data[, -1, drop = FALSE]) - resg <- gmjmcmc(data, loglik.tester, NULL, c("p0", "exp.dbl")) + resg <- gmjmcmc(data, loglik.tester, NULL, c("p0", "exp_dbl")) summary(resg) plot(resg) - prediction <- predict(resg, cbind(1, data[, -1, drop = FALSE])) + prediction <- predict(resg, 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])) + pred_pm <- predict(respm, data[, -1, drop = FALSE]) - respg <- gmjmcmc.parallel(2, 2, NULL, data, loglik.tester, NULL, c("p0", "exp.dbl")) + 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])) + pred_pg <- predict(respg, data[, -1, drop = FALSE]) + + 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 + ) + + # Dummy expect to run the test + expect_true(is.list(fbms_result)) }) + diff --git a/tests_current/Ex10_Sec6_2.R b/tests_current/Ex10_Sec6_2.R new file mode 100644 index 0000000000000000000000000000000000000000..53e83a863f6e3fac6d2bdda838b8fafe8584dec6 --- /dev/null +++ b/tests_current/Ex10_Sec6_2.R @@ -0,0 +1,307 @@ +####################################################### +# +# Example 10 (Section 6.2): Zambia data set from the cAIC4 package +# +# Linear Mixed Model with Fractional Polynomials +# +# Marginal Likelihood computed with lme4, INLA and with RTMB +# +# This is the valid version for the JSS Paper +# +####################################################### + +library(tictoc) + +library(devtools) +devtools::install_github("jonlachmann/GMJMCMC@FBMS", force=T, build_vignettes=F) + +library(FBMS) +use.fbms = FALSE + + + +#install.packages("INLA",repos=c(getOption("repos"),INLA="https://inla.r-inla-download.org/R/stable"), dep=TRUE) +#options(repos=c( inlabruorg = "https://inlabru-org.r-universe.dev", INLA = "https://inla.r-inla-download.org/R/testing", CRAN = "https://cran.rstudio.com") ) +#install.packages("fmesher") + +library(lme4) +library(RTMB) +library(INLA) + +#install.packages("cAIC4") +#library(cAIC4) + +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) # Modifications and interactions! + +params <- gen.params.gmjmcmc(df) +params$feat$D <- 1 # Set depth of features to 1 (still allows for interactions) +params$loglik$r = 1/dim(df)[1] +params$feat$pop.max = 10 + +#specify indices for a random effect +params$loglik$dr = droplevels(Zambia$dr) # district ids for repeated measurements + + +#estimator function with lme4 + +mixed.model.loglik.lme4 <- function (y, x, model, complex, params) +{ + + if (sum(model) > 1) { + x.model = x[,model] + data <- data.frame(y, x = x.model[,-1], dr = params$dr) + +# mm <- NULL +# #importance with error handling for unstable libraries that one does not trust 100% +# tryCatch({ +# mm <- lmer(as.formula(paste0("y ~ 1 +",paste0(names(data)[2:(dim(data)[2]-1)],collapse = "+"), "+ (1 | dr)")), data = data, REML = FALSE) +# }, error = function(e) { +# # Handle the error by setting result to NULL +# mm <- NULL +# # One can also print a message or log the error if needed +# cat("An error in Estimation of MLIK occurred:", conditionMessage(e), "\n") +# }) + 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 = params$dr) + mm <- lmer(as.formula(paste0("y ~ 1 + (1 | dr)")), data = data, REML = FALSE) + } + + + # logarithm of model prior + if (length(params$r) == 0) params$r <- 1/dim(x)[1] # default value or parameter r + lp <- log_prior(params, complex) + + mloglik <- as.numeric(logLik(mm)) - 0.5*log(length(y)) * (dim(data)[2] - 2) #Laplace approximation for beta prior + + return(list(crit = mloglik + lp, coefs = fixef(mm))) +} + + +#estimator function with INLA + +params$loglik$INLA.num.threads = 10 # Number of threads used by INLA +#params$feat$keep.min = 0.2 + + +mixed.model.loglik.inla <- function (y, x, model, complex, params) +{ + if(sum(model)>1) + { + data1 = data.frame(y, as.matrix(x[,model]), params$dr) + formula1 = as.formula(paste0(names(data1)[1],"~",paste0(names(data1)[3:(dim(data1)[2]-1)],collapse = "+"),"+ f(params.dr,model = \"iid\")")) + } else + { + data1 = data.frame(y, params$dr) + formula1 = as.formula(paste0(names(data1)[1],"~","1 + f(params.dr,model = \"iid\")")) + } + + #to make sure inla is not stuck + inla.setOption(inla.timeout=30) + inla.setOption(num.threads=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(params$r) == 0) params$r <- 1/dim(x)[1] # default value or parameter r + lp <- log_prior(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)) + } +} + + +#estimator function with RTMB + +params$loglik$nr_dr = sum((table(Zambia$dr))>0) #number of districts (that is number of different random intercepts) + +mixed.model.loglik.rtmb <- function (y, x, model, complex, params) +{ + + z = model.matrix(y~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,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)) + +# ADREPORT(sd_dr) +# ADREPORT(sd_eps) + + return(nll) + } + + obj <- MakeADFun(nll , par, random = "u", silent = T ) +# obj <- MakeADFun(nll , par, random = "u") + opt <- nlminb ( obj$par , obj$fn , obj$gr, control = list(iter.max = 10)) + + # logarithm of model prior + if (length(params$r) == 0) params$r <- 1/dim(x)[1] # default value or parameter r + lp <- log_prior(params, complex) + +# if(length(beta)==0) { +# return(list(crit = -10000 + lp,coefs = rep(0,dim(data1)[2]-2))) +# } else { + 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) + +#result <- gmjmcmc(data = df, loglik.pi = mixed.model.loglik.inla, transforms = transforms, probs = probs, params = params, P = 3) + +#params$feat$pop.max = 10 + +tic() +if (use.fbms) { + result1a <- fbms(data = df, family = "custom", loglik.pi = mixed.model.loglik.lme4, method = "gmjmcmc", + transforms = transforms, N.init = 30, + probs = probs, params = params, P=3) +} else { + result1a <- gmjmcmc(data = df, loglik.pi = mixed.model.loglik.lme4, + transforms = transforms, N.init = 30, + probs = probs, params = params, P = 3) +} +time.lme4 = toc() + +plot(result1a) +summary(result1a, labels = names(df)[-1]) + + +tic() +if (use.fbms) { + result1b <- fbms(data = df, family = "custom", loglik.pi = mixed.model.loglik.inla, method = "gmjmcmc", + transforms = transforms, N.init = 30, + probs = probs, params = params, P=3) +} else { + result1b <- gmjmcmc(data = df, loglik.pi = mixed.model.loglik.inla, + transforms = transforms, N.init = 30, + probs = probs, params = params, P = 3) +} +time.inla = toc() + +tic() +if (use.fbms) { + result1c <- fbms(data = df, family = "custom", loglik.pi = mixed.model.loglik.rtmb, method = "gmjmcmc", + transforms = transforms, N.init = 30, + probs = probs, params = params, P=3) +} else { + result1c <- gmjmcmc(data = df, loglik.pi = mixed.model.loglik.rtmb, + transforms = transforms, N.init = 30, + probs = probs, params = params, P = 3) +} +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 +# +# + +set.seed(20062024) +params$feat$pop.max = 10 +result2a <- gmjmcmc.parallel(runs = 40, cores = 10, data = df, loglik.pi = mixed.model.loglik.lme4, transforms = transforms, N.init=100, probs = probs, params = params, P = 25) + +summary(result2a,tol = 0.05,labels=names(df)[-1]) + + +set.seed(21062024) +result2b <- gmjmcmc.parallel(runs = 120, cores = 40, data = df, loglik.pi = mixed.model.loglik.lme4, transforms = transforms, N.init=100, probs = probs, params = params, P = 25) + +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 <- gmjmcmc.parallel(runs = 200, cores = 40, data = df, loglik.pi = mixed.model.loglik.lme4, transforms = transforms, N.init=100, probs = probs, params = params, P = 25) + +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) + +params$loglik$INLA.num.threads = 1 # Number of threads used by INLA set to 1 +result2a <- gmjmcmc.parallel(runs = 20, cores = 20, data = df, loglik.pi = mixed.model.loglik.inla, transforms = transforms, N.init=30, probs = probs, params = params, P = 25) + +plot(result2a) +summary(result2a, labels = names(df)[-1]) + +#save.image("Ex9_Results2_parallel.RData") +#load("Ex9_Results_parallel.RData") + +params$feat$check.col = F + +set.seed(20062024) +params$loglik$INLA.num.threads = 1 # Number of threads used by INLA set to 1 +result2b <- gmjmcmc.parallel(runs = 100, cores = 20, data = df, loglik.pi = mixed.model.loglik.inla, transforms = transforms, N.init=16, probs = probs, params = params, P = 15) + +summary(result2b, labels = names(df)[-1]) + diff --git a/tests_current/Ex11_Sec6_3.R b/tests_current/Ex11_Sec6_3.R new file mode 100644 index 0000000000000000000000000000000000000000..113b3953f69c687e347823dc70c1e21f411e8054 --- /dev/null +++ b/tests_current/Ex11_Sec6_3.R @@ -0,0 +1,131 @@ +####################################################### +# +# Example 11 (Section 6.3): Epil data set from the INLA package +# +# Mixed Effect Poisson Model with Fractional Polynomials +# +# 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(INLA) +library(tictoc) +use.fbms = FALSE + +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) + + +#df$Trt.Base = df$Trt * df$Base +#df$Trt.Age = df$Trt * df$Age + +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(df) +params$feat$D <- 2 # Set depth of features to 2 (allow for interactions) +params$loglik$r = 1/dim(df)[1] + +#specify indices for a random effect +params$loglik$PID = data$Ind # patient ids for repeated measurements +params$loglik$INLA.num.threads = 10 # Number of threads used by INLA + +params$feat$keep.min = 0.2 + +params$greedy$steps = 2 +params$greedy$tries = 1 +params$sa$t.min = 0.1 +params$sa$dt = 10 + + + +#estimator function + +poisson.loglik.inla <- function (y, x, model, complex, params) +{ + + if(sum(model)>1) + { + data1 = data.frame(y, as.matrix(x[,model]), params$PID) + formula1 = as.formula(paste0(names(data1)[1],"~",paste0(names(data1)[3:(dim(data1)[2]-1)],collapse = "+"),"+ f(params.PID,model = \"iid\")")) + } else + { + data1 = data.frame(y, params$PID) + formula1 = as.formula(paste0(names(data1)[1],"~","1 + f(params.PID,model = \"iid\")")) + } + + #to make sure inla is not stuck + inla.setOption(inla.timeout=30) + inla.setOption(num.threads=params$INLA.num.threads) + + mod<-NULL + + #importance with error handling for unstable libraries that one does not trust 100% + 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 + # 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(params$r) == 0) params$r <- 1/dim(x)[1] # default value or parameter r + lp <- log_prior(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) + +if (use.fbms) { + result <- fbms(data = df, family = "custom", loglik.pi = poisson.loglik.inla, method = "gmjmcmc", + transforms = transforms, probs = probs, params = params, P=3) +} else { + result <- gmjmcmc(data = df, loglik.pi = poisson.loglik.inla, transforms = transforms, + probs = probs, params = params, P = 3) +} + +plot(result) +summary(result) + + + +set.seed(23052024) + +tic() +params$loglik$INLA.num.threads = 1 # Number of threads used by INLA set to 1 +if (use.fbms) { + result2 <- fbms(data = df, family = "custom", loglik.pi = poisson.loglik.inla, + method = "gmjmcmc.parallel", runs = 40, cores = 40, + transforms = transforms, probs = probs, params = params, P=25) +} else { + result2 <- gmjmcmc.parallel(runs = 40, cores = 40, data = df, loglik.pi = poisson.loglik.inla, + transforms = transforms, probs = probs, params = params, P = 25) +} +time.inla = toc() + +plot(result2) +summary(result2, labels = names(df)[-1], tol = 0.01) + + + diff --git a/tests_current/Ex12_Sec6_4.R b/tests_current/Ex12_Sec6_4.R new file mode 100644 index 0000000000000000000000000000000000000000..884f1d3a6236e8d7aa91ed48833a2cbbfa5bc938 --- /dev/null +++ b/tests_current/Ex12_Sec6_4.R @@ -0,0 +1,176 @@ +####################################################### +# +# Example 12 (Section 6.4): +# +# Subsampling +# +# Heart Disease Health Indicators Dataset” +# +# This is the valid version for the JSS Paper +# +####################################################### + +#install.packages("tictoc") +library(tictoc) + +library(devtools) +devtools::install_github("jonlachmann/GMJMCMC@FBMS", force=T, build_vignettes=F) +#install.packages("FBMS") +library(FBMS) +#library(devtools) +#devtools::install_github("jonlachmann/irls.sgd", force=T, build_vignettes=F) +library(irls.sgd) + + + +df = read.csv2(file = "/Users/aliaksandrhome/GMJMCMC/tests/heart_disease_health_indicators_BRFSS2015.csv",sep = ",",dec = ".") + +summary(df) +dim(df) + +#number of observations in the data + +n = dim(df)[1] + +#number of covariates + +p = dim(df)[2] - 1 + +params <- gen.params.gmjmcmc(data = df) +params$loglik$r = 0.5 +params$loglik$subs = 0.01 + + +transforms <- c("sigmoid","pm1","p0","p05","p2","p3") +probs <- gen.probs.gmjmcmc(transforms) + +logistic.posterior.bic.irlssgd <- function (y, x, model, complex, params) +{ + if (!is.null(params$crit)) { + mod <- glm.sgd(x[,model], y, binomial(), sgd.ctrl = list(start=params$coefs, subs=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=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)) + } + + # logarithm of marginal likelihood + mloglik <- -mod$deviance / 2 - 0.5 * log(length(y)) * (mod$rank - 1) + + # logarithm of model prior + if (length(params$r) == 0) params$r <- 1/dim(x)[1] # default value or parameter r + lp <- log_prior(params, complex) + crit <- mloglik + lp + + if (!is.null(params$crit) && params$crit > crit) { + return(list(crit = params$crit, coefs = params$coefs)) + } + + return(list(crit = crit, coefs = mod$coefficients)) +} + + + +############################ +# +# Testing runtime +# +############################ + +set.seed(100001) +tic() +# subsampling analysis +tmp1 <- gmjmcmc(df, logistic.posterior.bic.irlssgd, transforms = transforms, + params = params, P = 2, sub = T) +time1 = toc() + +set.seed(100002) +tic() +# regular analysis +tmp2 <- gmjmcmc(df, logistic.loglik, transforms = transforms, + params = params, P = 2) +time2 = toc() + +c(time1, time2) + +############################ +# +# More serious analysis +# +############################ + + +# with subsampling + +set.seed(100003) + +tic() +result <- gmjmcmc.parallel(runs = 10,cores = 10, data = df, + loglik.pi = logistic.posterior.bic.irlssgd, + transforms = transforms, params = params, P = 3, sub = T) +time3 = toc() + +summary(result) + +# without subsampling + + +set.seed(100004) + +tic() +result1a <- gmjmcmc.parallel(runs = 10,cores = 10, data = df, + loglik.pi = logistic.loglik, + transforms = transforms, params = params, P = 3) +time4 = toc() + +summary(result1a) + + + +############################ +# +# Probably too ambitious analysis +# +############################ + +# with subsampling + +set.seed(100005) +tic() +result2 <- gmjmcmc.parallel(runs = 40,cores = 40, data = df, + loglik.pi = logistic.posterior.bic.irlssgd, + transforms = transforms, params = params, P = 10, sub = T) +time5 = toc() +summary(result2) + + + +# regular analysis + + +set.seed(100006) + +tic() +result2a <- gmjmcmc.parallel(runs = 40,cores = 40, data = df, + loglik.pi = logistic.loglik, + transforms = transforms, params = params, P = 10) +time6 = toc() + + +summary(result2a) + + + +############################################################################ + +C = cor(df, use = "everything", + method = "spearman") + +corrplot::corrplot(C) + +apply((abs(C - diag(diag(C)))), 2, max) + +save.image("Ex11_Results.RData") + diff --git a/tests_current/Ex13_Sec6_5.R b/tests_current/Ex13_Sec6_5.R new file mode 100644 index 0000000000000000000000000000000000000000..ac47c5d2df8b4c2d0226bd656a4a2d1ffddb5323 --- /dev/null +++ b/tests_current/Ex13_Sec6_5.R @@ -0,0 +1,174 @@ +####################################################### +# +# Example 13 (Section 6.5): +# +# Cox Regression +# +# This is the valid version for the JSS Paper +# +####################################################### + +library(devtools) +devtools::install_github("jonlachmann/GMJMCMC@FBMS", force=T, build_vignettes=F) + +#install.packages("FBMS") +library(FBMS) +library(pec) #for the computation of cindex + +#install.packages("survival") +library(survival) + +setwd("/home/florian/FBMS/") + +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) +#system('rm whitehall1.zip') + + +df <- df1[, c(13, 14, 2:4, 6:8, 10:12)] +names(df) = c("time","cens",names(df)[3:ncol(df)]) + + +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 <- df.train$time + + +params <- gen.params.gmjmcmc(data = df.train[,-1]) +params$loglik$r = 0.5 +params$loglik$time = time #the time variable goes into the params structure + +params$feat$keep.min = 0.2 + +transforms <- c("p0","p2","p3","p05","pm05","pm1","pm2") +probs <- gen.probs.gmjmcmc(transforms) +#probs$gen <- c(1,1,0,1) + + +#specify the estimator function for cox +surv.pseudo.loglik = function(y, x, model, complex, params){ + + if(length(params$r)==0) + params$r = 0.5 + data <- data.frame(time = params$time, cens = y, as.matrix(x[,model]))[,-3] # Removing intercept + if(dim(data)[2]==2) + { + return(list(crit=-10000, 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(params$r) == 0) params$r <- 1/dim(x)[1] # default value or parameter r + lp <- log_prior(params, complex) + + return(list(crit = mloglik + lp, coefs = c(0,out$coefficients))) + + } + +} + +#Single chain analysis (just to illustrate that it works) +set.seed(5) +result <- gmjmcmc(data = df.train[,-1], loglik.pi = surv.pseudo.loglik, transforms = transforms, params = params, P = 5) + +summary(result,tol = 0.01,labels = names(df.train)[-c(1:2)],effects = c(0.025,0.5,0.975)) +summary(result) +summary(result,tol = 0.01,labels = names(df.train)[-c(1:2)]) + +linpreds.train <- predict(result,df.train[,-(1:2)], link = function(x) x) +linpreds <- predict(result,df.test[,-(1:2)], link = function(x) x) + +#plot(linpreds$aggr$mean) + +#Parallel version +set.seed(15) +probs$gen <- c(1,1,1,1) +result2 <- gmjmcmc.parallel(runs = 80, cores = 40, data = df.train[,-1], + loglik.pi = surv.pseudo.loglik, transforms = transforms, + probs = probs, params = params, P = 25) +summary(result2,tol = 0.01,labels = names(df.train)[-1],effects = c(0.025,0.5,0.975)) + +linpreds2.train <- predict(result2,df.train[,-(1:2)], link = function(x) x) +linpreds2 <- predict(result2,df.test[,-(1:2)], link = function(x) x) +#plot(linpreds2$aggr$mean) + + + +############################################# +#Parallel version only linear terms +set.seed(25) +probs$gen <- c(0,0,0,1) +result3 <- gmjmcmc.parallel(runs = 80, cores = 40, data = df.train[,-1], + loglik.pi = surv.pseudo.loglik, transforms = transforms, + probs = probs, params = params, P = 25) + +summary(result3,tol = 0.01,labels = names(df.train)[-(1:2)],effects = c(0.025,0.5,0.975)) + +linpreds3.train <- predict(result3,df.train[,-(1:2)], link = function(x) x) +linpreds3 <- predict(result3,df.test[,-(1:2)], link = function(x) x) +#plot(linpreds2$aggr$mean) + +############################################# +#Parallel version only fractional polynomials +set.seed(35) +probs$gen <- c(0,1,0,1) +result4 <- gmjmcmc.parallel(runs = 80, cores = 40, data = df.train[,-1], + loglik.pi = surv.pseudo.loglik, transforms = transforms, + probs = probs, params = params, P = 25) + +summary(result4,tol = 0.01,labels = names(df.train)[-(1:2)],effects = c(0.025,0.5,0.975)) + +linpreds4.train <- predict(result4,df.train[,-(1:2)], link = function(x) x) +linpreds4 <- predict(result4,df.test[,-(1:2)], link = function(x) x) +#plot(linpreds2$aggr$mean) + +# Compute cindex using package pec + +df.train$average.lin.pred1 <- linpreds.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 <- linpreds$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 + +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 +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 +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 + +round(unlist(c(cindex1, cindex2, cindex3, cindex4, cindex5, cindex6)),3) + + diff --git a/tests_current/Ex1_Sec3.R b/tests_current/Ex1_Sec3.R new file mode 100644 index 0000000000000000000000000000000000000000..b3d5a8bfb0a30414d745272279fdab341d8cc318 --- /dev/null +++ b/tests_current/Ex1_Sec3.R @@ -0,0 +1,430 @@ +################################################# +# +# Example 1: +# +# Kepler Example with the most recent database update +# +# This is the valid version for the JSS paper +# +################################################## + +#install.packages("FBMS") +#install.packages("devtools") +#library(devtools) +#devtools::install_github("jonlachmann/GMJMCMC@FBMS", force=T, build_vignettes=F) +library(FBMS) + +data <- read.csv("https://raw.githubusercontent.com/OpenExoplanetCatalogue/oec_tables/master/comma_separated/open_exoplanet_catalogue.txt") +data <- na.omit(data[,c("semimajoraxis","mass","radius","period","eccentricity","hoststar_mass","hoststar_radius","hoststar_metallicity","hoststar_temperature","binaryflag")]) +summary(data) + + +te.ind <- 540:939 +df.train = data[-te.ind,] +df.test = data[te.ind,] +n <- dim(df.train)[1] + +to3 <- function(x) x^3 +transforms <- c("sigmoid","sin_deg","exp_dbl","p0","troot","to3") + +# Logical to decide whether to perform analysis with fbms function +# If FALSE then gmjmcmc or gmjmcmc.parallel function is used +use.fbms = FALSE + +#################################################### +# +# single thread analysis (default values, Section 3.1) +# +#################################################### + +params <- gen.params.gmjmcmc(df.train) +params$loglik$var <- "unknown" + +params <- gen.params.gmjmcmc(df.train) +params$loglik$prior_beta <- "Jeffreys-BIC" +params$loglik$var <- 1 +params$loglik$family <- "gaussian" +params$loglik$r <- 1/n +result <- gmjmcmc.parallel(data = df.train,loglik.pi = fbms.mlik.master, transforms = transforms, params = params,cores = 10,runs = 40, P = 25) +summary(result) + + +params <- gen.params.gmjmcmc(df.train) +params$loglik$prior_beta <- "g-prior" +params$loglik$g <- n +params$loglik$family <- "gaussian" +params$loglik$r <- 1/n +result <- gmjmcmc.parallel(data = df.train,loglik.pi = fbms.mlik.master, transforms = transforms, params = params,cores = 10,runs = 40, P = 25) +summary(result) + + +params <- gen.params.gmjmcmc(df.train) +params$loglik$prior_beta <- "EB-local" +params$loglik$family <- "gaussian" +params$loglik$r <- 1/n +result <- gmjmcmc.parallel(data = df.train,loglik.pi = fbms.mlik.master, transforms = transforms, params = params,cores = 10,runs = 40, P = 25) +summary(result) + +params <- gen.params.gmjmcmc(df.train) +params$loglik$prior_beta <- "hyper-g" +params$loglik$family <- "gaussian" +params$loglik$a <- 3 +params$loglik$r <- 1/n +result <- gmjmcmc.parallel(data = df.train,loglik.pi = fbms.mlik.master, transforms = transforms, params = params,cores = 10,runs = 40, P = 25) +summary(result) + + +if (use.fbms) { + result.default <- fbms(formula = semimajoraxis ~ 1 + . , data = df.train, method = "gmjmcmc", transforms = transforms, params = params) +} else { + result.default <- gmjmcmc(df.train, transforms = transforms, params = params) +} +summary(result.default,labels = F) + + +preds <- predict(result.default, df.test[,-1], link = function(x) x) +sqrt(mean((preds$aggr$mean - df.test$semimajoraxis)^2)) + +#new additional ways to predict using MPM and best model +get.best.model(result = result.default) +preds <- predict(get.best.model(result.default), df.test[,-1]) +sqrt(mean((preds - df.test$semimajoraxis)^2)) + +get.mpm.model(result = result.default,y = df.test$semimajoraxis,x=df.test[,-1]) +preds <- predict(get.mpm.model(result.default,y = df.test$semimajoraxis,x=df.test[,-1]), df.test[,-1]) +sqrt(mean((preds - df.test$semimajoraxis)^2)) + +#################################################### +# +# single thread analysis (more iterations, Section 3.2) +# +#################################################### + + +set.seed(123) + +if (use.fbms) { + result.P50 <- fbms(data = df.train, method = "gmjmcmc", transforms = transforms, + P=50, N.init=1000, N.final=1000, params = params) +} else { + result.P50 <- gmjmcmc(df.train, transforms = transforms, + P=50, N.init=1000, N.final=1000, params = params) +} +summary(result.P50, labels = names(df.train)[-1]) + +#################################################### +# +# multiple thread analysis (Section 3.3) +# +#################################################### + +set.seed(123) +if (use.fbms) { + result_parallel <- fbms(data = df.train, method = "gmjmcmc.parallel", transforms = transforms, + runs = 40, cores = 10, P=25,params = params) +} else { + result_parallel <- gmjmcmc.parallel(runs = 40, cores = 10, data = df.train, loglik.pi = gaussian.loglik, + transforms = transforms, P=25,params = params) +} +summary(result_parallel, tol = 0.01) + + +####### fixed variance +params$loglik$var <- 1 +set.seed(124) +if (use.fbms) { + result_parallel_unitphi <- fbms(data = df.train, method = "gmjmcmc.parallel", transforms = transforms, + runs = 40, cores = 10, P=25,params = params) +} else { + result_parallel_unitphi <- gmjmcmc.parallel(runs = 40, cores = 10, data = df.train, loglik.pi = gaussian.loglik, + transforms = transforms, P=25,params = params) +} +summary(result_parallel_unitphi, tol = 0.01) + + +#g prior with g = n is perfect +gaussian.loglik.g <- function (y, x, model, complex, params) +{ + + 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) + + # logarithm of marginal likelihood + mloglik <- 0.5*(log(1.0 + params$g) * (dim(x)[1] - mod$rank) - log(1.0 + params$g * (1.0 - Rsquare)) * (dim(x)[1] - 1))*(mod$rank!=1) + + # logarithm of model prior + if (length(params$r) == 0) params$r <- 1/dim(x)[1] # default value or parameter r + lp <- log_prior(params, complex) + + return(list(crit = mloglik + lp, coefs = mod$coefficients)) +} + + +#default for N.final = N.init +params$loglik$g = n +set.seed(1) +if (use.fbms) { + result_parallel_g <- fbms(data = df.train,family = "custom", method = "gmjmcmc.parallel",loglik.pi = gaussian.loglik.g, transforms = transforms, + runs = 40, cores = 10, P=25,params = params) +} else { + result_parallel_g <- gmjmcmc.parallel(runs = 40, cores = 10, data = df.train, loglik.pi = gaussian.loglik.g, + transforms = transforms, P=25,params = params) +} +summary(result_parallel_g, tol = 0.01) +#################################################### +# +# Inspection of Results (Section 3.4) +# +#################################################### + +###################### +# summary + +summary(result.default) +summary(result.default, labels = names(df.train)[-1]) + +summary(result.P50) + +summary(result_parallel) +summary(result_parallel, tol = 0.01,labels = names(df.train)[-1]) + + +###################### +# plot + +pdf.train("result.pdf.train") +plot(result.default) +dev.off() + +plot(result.default) + + + +pdf.train("result.P50.pdf.train") +plot(result.P50) +dev.off() + +plot(result.P50) + + + +pdf.train("result_parallel.pdf.train") +plot(result_parallel) +dev.off() + +plot(result_parallel) +plot(result_parallel, 12) + +pdf.train("result_parallel_unitphi.pdf.train") +plot(result_parallel_unitphi) +dev.off() + +plot(result_parallel_unitphi) +plot(result_parallel_unitphi, 12) + + +###################### +# Prediction + +#preds <- predict(result, df.test[,-1], link = function(x) x) +preds <- predict(result.default, df.test[,-1]) + +pdf.train("prediction.pdf.train") +plot(preds$aggr$mean, df.test$semimajoraxis) +dev.off() + +plot(preds$aggr$mean, df.test$semimajoraxis) + +rmse.default <- sqrt(mean((preds$aggr$mean - df.test$semimajoraxis)^2)) + +############################### + + +#preds.P50 = predict(result.P50, df.test[,-1], link = function(x) x) +preds.P50 = predict(result.P50, df.test[,-1]) + +pdf.train("prediction.P50.pdf.train") +plot(preds.P50$aggr$mean, df.test$semimajoraxis) +dev.off() + +plot(preds.P50$aggr$mean, df.test$semimajoraxis) + +rmse.P50 <- sqrt(mean((preds.P50$aggr$mean - df.test$semimajoraxis)^2)) + + +############################### + + +preds.multi <- predict(result_parallel , df.test[,-1], link = function(x) x) + +pdf.train("pred_parallel.pdf.train") +plot(preds.multi$aggr$mean, df.test$semimajoraxis) +dev.off() + +rmse.parallel <- sqrt(mean((preds.multi$aggr$mean - df.test$semimajoraxis)^2)) + + +############################### + + +preds_unitphi <- predict(result_parallel_unitphi , df.test[,-1], link = function(x) x) + +pdf.train("pred_parallel.pdf.train") +plot(preds_unitphi$aggr$mean, df.test$semimajoraxis) +dev.off() + +rmse_unitphi <- sqrt(mean((preds_unitphi$aggr$mean - df.test$semimajoraxis)^2)) + + +############################### + + +preds_g <- predict(result_parallel_g , df.test[,-1], link = function(x) x) + +pdf.train("pred_parallel.pdf.train") +plot(preds_g$aggr$mean, df.test$semimajoraxis) +dev.off() + +rmse_g <- sqrt(mean((preds_g$aggr$mean - df.test$semimajoraxis)^2)) + +c(rmse.default, rmse.P50, rmse.parallel,rmse_unitphi,rmse_g) + + + +#let us test all priors from BAS ,see prior in ?bas.lm + +library(tictoc) +#just testing all priors I now added, time, etc. +for(prior in c("g-prior", + "hyper-g", + "hyper-g-laplace", + "hyper-g-n", + "AIC", + "BIC", + "ZS-null", + "ZS-full", + "EB-local", + "EB-global", + "JZS")) +{ + print(paste0("testing ",prior)) + params$loglik <- list(r = 1/dim(df.train)[1], betaprior = prior,alpha = max(dim(df.train)[1],(dim(df.train)[2])^2)) + + + #ours are stil a bit faster than the BAS ones, but BAS are relatively fine too + + tic() + result.default <- fbms(formula = semimajoraxis ~ 1 + . , data = df.train, method = "gmjmcmc.parallel",cores = 10, runs = 10, transforms = transforms, loglik.pi = lm.logpost.bas, params = params, P = 50) + time.res = toc() + preds <- predict(result.default, df.test[,-1], link = function(x) x) + print(summary(result.default)) + print(sqrt(mean((preds$aggr$mean - df.test$semimajoraxis)^2))) + print(time.res) +} + + +#default for N.final = N.init +params <- gen.params.gmjmcmc(df.train) +params$loglik$g <- dim(df.train)[1] +tic() +result.default <- fbms(formula = semimajoraxis ~ 1 + . , data = df.train, method = "gmjmcmc.parallel",cores = 10, runs = 10, transforms = transforms, loglik.pi = gaussian.loglik.g, params = params, P = 50) +time.res = toc() +preds <- predict(result.default, df.test[,-1], link = function(x) x) +print(summary(result.default)) +print(sqrt(mean((preds$aggr$mean - df.test$semimajoraxis)^2))) +print(time.res) + + + +#testing a bit BAS based stuff vs our implementation, g prior +lm.logpost.bas(y = df.train$semimajoraxis,x = cbind(1,df.train[,-1]),model = c(T,T,T,T,T,T,T,T,T,T),complex = list(oc = 10),params = list(r = 1/dim(df.train)[1], betaprior = "g-prior",alpha = min(dim(df.train)[1],(dim(df.train)[2])^2))) +gaussian.loglik.g(y = df.train$semimajoraxis,x = cbind(1,df.train[,-1]),model = c(T,T,T,T,T,T,T,T,T,T),complex = list(oc = 10),params = list(r = 1/dim(df.train)[1],g = min(dim(df.train)[1],(dim(df.train)[2])^2))) +#perfect agreement + +library(tictoc) +tic() +mean(sapply(1:100000,function(i)lm.logpost.bas(y = df.train$semimajoraxis,x = cbind(1,df.train[,-1]),model = c(T,T,T,T,T,T,T,T,T,T),complex = list(oc = 1),params = list(r = 1/dim(df.train)[1], betaprior = "g-prior",alpha = min(dim(df.train)[1],(dim(df.train)[2])^2)))$crit)) +toc() + +tic() +mean(sapply(1:100000,function(i)gaussian.loglik.g(y = df.train$semimajoraxis,x = cbind(1,df.train[,-1]),model = c(T,T,T,T,T,T,T,T,T,T),complex = list(oc = 1),params = list(r = 1/dim(df.train)[1],g = min(dim(df.train)[1],(dim(df.train)[2])^2)))$crit)) +toc() + +tic() +mean(sapply(1:100000,function(i)gaussian.loglik(y = df.train$semimajoraxis,x = cbind(1,df.train[,-1]),model = c(T,T,T,T,T,T,T,T,T,T),complex = list(oc = 1),params = list(r = 1/dim(df.train)[1], var = 1))$crit)) +toc() + +#BAS version is in fact quicker even than Jeffreys prior based implementation! + + +#testing a bit BAS based stuff vs our implementation, Jeffreys prior aka BIC() in BAS +lm.logpost.bas(y = df.train$semimajoraxis,x = cbind(1,df.train[,-1]),model = c(T,T,T,T,T,T,T,T,T),complex = list(oc = 0),params = list(r = 1/dim(df.train)[1], betaprior = "BIC",alpha = (dim(df.train)[1])))$crit - + lm.logpost.bas(y = df.train$semimajoraxis,x = cbind(1,df.train[,-1]),model = c(T,F,F,F,F,T,T,T,T),complex = list(oc = 0),params = list(r = 1/dim(df.train)[1], betaprior = "BIC",alpha = (dim(df.train)[1])))$crit + +#var of 1 +gaussian.loglik(y = df.train$semimajoraxis,x = cbind(1,df.train[,-1]),model = c(T,T,T,T,T,T,T,T,T),complex = list(oc = 0),params = list(r = 1/dim(df.train)[1],var = 1))$crit - + gaussian.loglik(y = df.train$semimajoraxis,x = cbind(1,df.train[,-1]),model = c(T,F,F,F,F,T,T,T,T),complex = list(oc = 0),params = list(r = 1/dim(df.train)[1],var = 1))$crit + + +#var unknown +gaussian.loglik(y = df.train$semimajoraxis,x = cbind(1,df.train[,-1]),model = c(T,T,T,T,T,T,T,T,T),complex = list(oc = 0),params = list(r = 1/dim(df.train)[1],var = "unknown"))$crit - + gaussian.loglik(y = df.train$semimajoraxis,x = cbind(1,df.train[,-1]),model = c(T,F,F,F,F,T,T,T,T),complex = list(oc = 0),params = list(r = 1/dim(df.train)[1],var = "unknown"))$crit + +-BIC(lm(semimajoraxis~.,df.train))/2 + BIC(lm(semimajoraxis~.,df.train[,-c(2,3,4,5)]))/2 + + + +for(prior in c("CH", "Hyper-g", "Uniform", "Jeffreys", "Beta-prime", "Benchmark", "TruncGamma", "ZS adapted", "Robust", "Hyper-g/n", "Intrinsic")) +{ + print(prior) + print(gaussian_tcch_log_likelihood(y = df.train$semimajoraxis,x = cbind(1,df.train[,-1]),model = c(T,T,T,T,T,T,T,T,T,T),complex = list(oc = 0),params = list(r = 1/dim(df.train)[1], prior_beta = prior))$crit- + gaussian_tcch_log_likelihood(y = df.train$semimajoraxis,x = cbind(1,df.train[,-1]),model = c(T,F,F,F,F,T,T,T,T),complex = list(oc = 0),params = list(r = 1/dim(df.train)[1], prior_beta = prior))$crit) + +} + +lm.logpost.bas(y = df.train$semimajoraxis,x = cbind(1,df.train[,-1]),model = c(T,T,T,T,T,T,T,T,T,T),complex = list(oc = 10),params = list(r = 1/dim(df.train)[1], betaprior = "g-prior",alpha = min(dim(df.train)[1],(dim(df.train)[2])^2))) + + + + + +#let us quickly test the Beroulli responses + +df.train$semimajoraxis = as.numeric(df.train$semimajoraxis>mean(df.train$semimajoraxis)) + + +glm.logpost.bas(y = df.train$semimajoraxis,x = cbind(1,df.train[,-1]),model = c(T,T,T,T,T,T,T,T,T),complex = list(oc = 0),params = list(r = 1/dim(df.train)[1], family = "binomial", betaprior = Jeffreys(),laplace = 1))$crit - + glm.logpost.bas(y = df.train$semimajoraxis,x = cbind(1,df.train[,-1]),model = c(T,F,F,F,F,T,T,T,T),complex = list(oc = 0),params = list(r = 1/dim(df.train)[1], family = "binomial", betaprior = Jeffreys(),laplace = 1))$crit + +# laplace or not does not matter, does not fully correspond to ours +glm.logpost.bas(y = df.train$semimajoraxis,x = cbind(1,df.train[,-1]),model = c(T,T,T,T,T,T,T,T,T),complex = list(oc = 0),params = list(r = 1/dim(df.train)[1], family = "binomial", betaprior = bic.prior((dim(df.train)[1])),laplace = 1))$crit - + glm.logpost.bas(y = df.train$semimajoraxis,x = cbind(1,df.train[,-1]),model = c(T,F,F,F,F,T,T,T,T),complex = list(oc = 0),params = list(r = 1/dim(df.train)[1], family = "binomial", betaprior = bic.prior((dim(df.train)[1])),laplace = 1))$crit + + +logistic.loglik(y = df.train$semimajoraxis,x = cbind(1,df.train[,-1]),model = c(T,T,T,T,T,T,T,T,T),complex = list(oc = 0),params = list(r = 1/dim(df.train)[1]))$crit - + logistic.loglik(y = df.train$semimajoraxis,x = cbind(1,df.train[,-1]),model = c(T,F,F,F,F,T,T,T,T),complex = list(oc = 0),params = list(r = 1/dim(df.train)[1]))$crit + + +-BIC(glm(semimajoraxis~.,df.train,family = "binomial"))/2 + BIC(glm(semimajoraxis~.,df.train[,-c(2,3,4,5)],family = "binomial"))/2 + + +tic() +mean(sapply(1:10000,function(i)glm.logpost.bas(y = df.train$semimajoraxis,x = cbind(1,df.train[,-1]),model = c(T,T,T,T,T,T,T,T,T),complex = list(oc = 0),params = list(r = 1/dim(df.train)[1], family = "binomial", betaprior = Jeffreys(),laplace = 1))$crit)) +toc() + +tic() +mean(sapply(1:10000,function(i)glm.logpost.bas(y = df.train$semimajoraxis,x = cbind(1,df.train[,-1]),model = c(T,T,T,T,T,T,T,T,T),complex = list(oc = 0),params = list(r = 1/dim(df.train)[1], family = "binomial", betaprior = bic.prior((dim(df.train)[1])),laplace = 1))$crit)) +toc() + +tic() +mean(sapply(1:10000,function(i)logistic.loglik(y = df.train$semimajoraxis,x = cbind(1,df.train[,-1]),model = c(T,T,T,T,T,T,T,T,T),complex = list(oc = 0),params = list(r = 1/dim(df.train)[1]))$crit)) +toc() + + diff --git a/tests_current/Ex2_Sec4_1.R b/tests_current/Ex2_Sec4_1.R new file mode 100644 index 0000000000000000000000000000000000000000..de32a6585f61aad2fc4c2922a7de9166edc2a6bb --- /dev/null +++ b/tests_current/Ex2_Sec4_1.R @@ -0,0 +1,123 @@ +####################################################### +# +# Example 2 (Section 4.1): +# +# Simulated data without any nonlinearities +# +# This is the valid version for the JSS Paper +# +####################################################### + +# Logical to decide whether to perform analysis with fbms function +# If FALSE then gmjmcmc or gmjmcmc.parallel function is used +use.fbms <- FALSE +stronger.singal <- FALSE + +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 + +set.seed(1002) + +correct.model <- sample(p.vec, k) +beta.k <- 1*ifelse(stronger.singal,10,1) + rnorm(k)/2 # Coefficents of the correct submodel + +beta <- c(rep(0, p)) +beta[correct.model] <- beta.k + +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)) + +correct.model +beta.k + + +to3 <- function(x) x^3 +transforms <- c("sigmoid","sin_deg","exp_dbl","p0","troot","to3") + +set.seed(123) +if (use.fbms) { + result <- result <- fbms(data = df, method = "gmjmcmc", + transforms = transforms, P = 40) +} else { + result <- gmjmcmc(df, gaussian.loglik, gaussian.loglik.alpha, transforms, P = 40) +} +summary(result) + + +set.seed(123) +if (use.fbms) { + result2 <- result <- fbms(data = df, method = "gmjmcmc", transforms = transforms, + N.init = 1000, N.final = 5000, P = 40) +} else { + result2 <- gmjmcmc(df, transforms = transforms, + N.init = 1000, N.final = 5000, P = 40) +} +summary(result2) + + + + +######################################################## +# +# Model which includes no non-linear effects +# +# + + +set.seed(123) + +probs.lin <- gen.probs.mjmcmc() + +params.lin <- gen.params.mjmcmc(df) +params.lin$loglik$r <- 1/dim(df)[1] + +#to set variance to unknown uncomment below +#params.lin$loglik$var <- "unknown" + +if (use.fbms) { + result.lin <- fbms(data = df, N = 5000) +} else { + result.lin <- mjmcmc(df, N = 5000, probs = probs.lin, + params = params.lin) + +} + + +plot(result.lin) +summary(result.lin) + +correct.model +beta.k + + +#The default value of N = 100 does not lead to the same result here +set.seed(123) + +if (use.fbms) { + result.lindef <- fbms(data = df) +} else { + result.lindef <- mjmcmc(df) +} + + +plot(result.lindef) +summary(result.lindef) + + +############################################################################### \ No newline at end of file diff --git a/tests_current/Ex3_Sec4_1.R b/tests_current/Ex3_Sec4_1.R new file mode 100644 index 0000000000000000000000000000000000000000..6089c74185225b76d2e0242f074fad8353aeedc0 --- /dev/null +++ b/tests_current/Ex3_Sec4_1.R @@ -0,0 +1,156 @@ +####################################################### +# +# Example 7 (Section 5.1): Sanger data again +# +# High dimensional analysis without nonlinearities +# +# Now using g prior for coefficients +# +# 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) +use.fbms = FALSE +run.parallel <- T + +data(SangerData2) +df = SangerData2 +#Rename columns +colnames(df) = c("y",paste0("x",1:(ncol(df)-1))) + +#Only linear terms/mutations +transforms = c("") +probs = gen.probs.gmjmcmc(transforms) +probs$gen = c(0,0,0,1) + + +# Candidates for the first MJMCMC round based on 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]) +params = gen.params.gmjmcmc(df) +params$feat$prel.filter <- ids + +params$feat$check.col <- T +params$feat$pop.max <- 50 + +#################################################### +# +# Here begin the changes to use Zellers g-prior +# +#################################################### +n = dim(df)[1]; p=dim(df)[2] +params$loglik$g <- max(n,p^2) # Using recommendation from Fernandez et al (2001) + +#this will be added to the package +log_prior <- function(params,complex){ + + pl <- log(params$r) * (sum(complex$oc)) + return(pl) +} + +gaussian.loglik.g <- function (y, x, model, complex, params) +{ + + 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) + + # logarithm of marginal likelihood + mloglik <- 0.5*(log(1.0 + params$g) * (dim(x)[1] - mod$rank) - log(1.0 + params$g * (1.0 - Rsquare)) * (dim(x)[1] - 1))*(mod$rank!=1) + + # logarithm of model prior + if (length(params$r) == 0) params$r <- 1/dim(x)[1] # default value or parameter r + lp <- log_prior(params, complex) + + return(list(crit = mloglik + lp, coefs = mod$coefficients)) +} + +##Parallel runs +if(run.parallel) +{ + set.seed(123) + if (use.fbms) { + result_parallel1=fbms(data=df,loglik.pi=gaussian.loglik.g,transforms=transforms, + probs=probs,params=params, + method="gmjmcmc.parallel", + P=50,N.init=1000,N.final=1000,runs=10,cores=10) + }else { + start = Sys.time() + result_parallel1=gmjmcmc.parallel(data=df,loglik.pi=gaussian.loglik.g,transforms=transforms, + probs=probs,params=params, + P=50,N.init=1000,N.final=1000,runs=10,cores=10) + end = Sys.time() + print(end-start) + } + save(result_parallel1,file="Ex3_parallel1.RData") + #load("Ex3_parallel1.RData") + + set.seed(1234) + if (use.fbms) { + result_parallel2=fbms(data=df,loglik.pi=gaussian.loglik.g,transforms=transforms, + probs=probs,params=params, + method="gmjmcmc.parallel", + P=50,N.init=1000,N.final=1000,runs=10,cores=10) + } else { + result_parallel2=gmjmcmc.parallel(data=df,loglik.pi=gaussian.loglik.g,transforms=transforms, + probs=probs,params=params, + P=50,N.init=1000,N.final=1000,runs=10,cores=10) + } + save(result_parallel2,file="Ex3_parallel2.RData") + #load("Ex3_parallel2.RData") + + set.seed(123456) + if (use.fbms) { + result_parallel3=fbms(data=df,loglik.pi=gaussian.loglik.g,transforms=transforms, + probs=probs,params=params, + method="gmjmcmc.parallel", + P=50,N.init=1000,N.final=1000,runs=10,cores=10) + } else { + result_parallel3=gmjmcmc.parallel(data=df,loglik.pi=gaussian.loglik.g,transforms=transforms, + probs=probs,params=params, + P=50,N.init=1000,N.final=1000,runs=10,cores=10) + } + save(result_parallel3,file="Ex3_parallel3.RData") + #load("Ex3_parallel2.RData") + + + ## Combine results from three runs + 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) + names.best = unique(c(res1$feats.strings,res2$feats.strings,res3$feats.strings)) + m = max(nrow(res1),nrow(res2),nrow(res3)) + while(nrow(res1)