(('re_slc_int_form',
'ordered_index',
'Estimate',
'cred.ub',
'cred.lb',
'sig',
'hyp'))
#' @importFrom utils combn
#' @importFrom stringr str_extract
<- (string){
stringr::str_extract(string, "\\-*\\d+\\.*\\d*")
}
rho_helper <- (object, cred = cred,....){
# cred lower bound
lb <- (1 - cred) / 2
# cred upper bound
ub <- 1 - lb
# posterior samples
post_samps <- (, object$melsm_fit)
# random effects cors
rhos <- (post_samps,( = "^rho", x = (post_samps))])
# posterior means
rhos_mu <- (rhos)
# posterior sds
rhos_sd <- (rhos, 2, )
# credible intervals
rhos_cred <- (rhos, 2, , (lb, ub))
# location model matrix names
re_loc_names <- ("location_", (object$model_matrices$re_loc_mm),sep = "")
# scale model matrix names
re_scl_names <- ("scale_", (object$model_matrices$re_scl_mm),sep = "")
# random effects names
re_names <- (re_loc_names, re_scl_names)
# number of random effects
total_res <- (re_loc_names) + (re_scl_names)
# rho index pairwise combinatinos
rho_index <- (((1:total_res, 2)))
# store names
cor_names <- ()
# correlation names
(i 1:(rho_index)){
cor_names[i]] <- ("rho_",
rho_index[i,1] - 1,
rho_index[i,2] - 1, ": ",
re_names[rho_index[i,1]], "_" ,
re_names[rho_index[i,2]], sep = "")
}
# rho summary
rho_summary <- (Post.mean = rhos_mu,
Post.sd = rhos_sd,
Cred.lb = rhos_cred[1,],
Cred.ub = rhos_cred[2,])
# add rho names
rho_summary <- (Correlations = (cor_names),
(rho_summary, 3))
# remove first column names
(rho_summary)[1] <- ""
# start: KM mixture
(object$mixture == "KM"){
# indicators
rhos_k <- post_samps,( = "^k", x = (post_samps))]
# one correlation
(((rhos_k))){
rhos_prob <- (((rhos_k)), 3)
rho_summary,6] <- rhos_prob
rho_summary,7] <- 1 - rhos_prob
(rho_summary)[6] <- "Pr.slab"
(rho_summary)[7] <- "Pr.spike"
# more than one correlations
} {
rhos_prob <- ((rhos_k), 3)
rho_summary[as.numeric(((rhos_prob))),6] <- rhos_prob
rho_summary[as.numeric(((rhos_prob))),7] <- 1 - rhos_prob
(rho_summary)[6] <- "Pr.slab"
(rho_summary)[7] <- "Pr.spike"
}
} # end KM mixture
# start SSVS mixture
if (object$mixture == "SSVS") {
# indicators
rhos_k <- (post_samps,( = "^k", x = (post_samps))])
# one correlations
if ((rhos_k)[2] == 1) {
# two components
if (object$k == 2) {
rhos_prob_k1 <- ((rhos_k == 1), 3)
rhos_prob_k2 <- ((rhos_k == 2), 3)
rho_summary,6] <- rhos_prob_k1
rho_summary,7] <- rhos_prob_k2
(rho_summary)[6] <- "Pr.k1"
(rho_summary)[7] <- "Pr.k2"
# three components
} {
rhos_prob_k1 <- ((rhos_k == 1), 3)
rhos_prob_k2 <- ((rhos_k == 2), 3)
rhos_prob_k3 <- ((rhos_k == 3), 3)
rho_summary,6] <- rhos_prob_k1
rho_summary,7] <- rhos_prob_k2
rho_summary,8] <- rhos_prob_k3
(rho_summary)[6] <- "Pr.k1"
(rho_summary)[7] <- "Pr.k2"
(rho_summary)[8] <- "Pr.k3"
}
# more than one correlation
} {
# two components
(object$k == 2){
rhos_prob_k1 <- ((rhos_k == 1), 3)
rhos_prob_k2 <- ((rhos_k == 2), 3)
rho_summary[as.numeric(((rhos_prob_k1))),6] <- rhos_prob_k1
rho_summary[as.numeric(((rhos_prob_k1))),7] <- rhos_prob_k2
(rho_summary)[6] <- "Pr.k1"
(rho_summary)[7] <- "Pr.k2"
# three components
} {
rhos_prob_k1 <- ((rhos_k == 1), 3)
rhos_prob_k2 <- ((rhos_k == 2), 3)
rhos_prob_k3 <- ((rhos_k == 3), 3)
rho_summary[as.numeric(((rhos_prob_k1))),6] <- rhos_prob_k1
rho_summary[as.numeric(((rhos_prob_k1))),7] <- rhos_prob_k2
rho_summary[as.numeric(((rhos_prob_k1))),8] <- rhos_prob_k3
(rho_summary)[6] <- "Pr.k1"
(rho_summary)[7] <- "Pr.k2"
(rho_summary)[8] <- "Pr.k3"
}
}
}
# remove first column name
rho_summary[is.na(rho_summary)] <- ""
# rho summary
rho_summary
}
# extract and summarise random effects SDs
tau_helper <- (object, cred = cred,){
# cred lower bound
lb <- (1 - cred) / 2
# cred upper bound
ub <- 1 - lb
# posterior samples
post_samps <- (, object$melsm_fit)
# random effects SDs
taus <- post_samps,( = "^Tau", x = (post_samps))]
# set 0s to NA (off-diagonal elements)
taus[taus == 0] <-
# remove NA
taus <- (((taus)))
# posterior means
taus_mu <- (taus)
# posterior sds
taus_sd <- (taus, 2, )
# credible intervals
taus_cred <- (taus, 2, , (lb, ub))
# location RE SD names
re_loc_names <- ("location_", (object$model_matrices$re_loc_mm),sep = "")
# scale RE SD names
re_scl_names <- ("scale_", (object$model_matrices$re_scl_mm),sep = "")
# re names
re_names <- (re_loc_names, re_scl_names)
# RE sd names
tau_names <- ("tau_", 0:((re_names)-1), ": ", re_names, sep = "")
# tau summary
tau_summary <- ((
Post.mean = taus_mu,
Post.sd = taus_sd,
Cred.lb = taus_cred[1,],
Cred.ub = taus_cred[2,]), 3)
# add RE SD names
tau_summary <- (tau_names, tau_summary)
# remove first column name
(tau_summary)[1] <- ""
# RE sd summary
tau_summary
}
# extract and summarise location fixed effects
beta_helper <- (object, cred = cred, ){
# cred lower bound
lb <- (1 - cred) / 2
# cred upper bound
ub <- 1 - lb
# posterior samples
post_samps <- (, object$melsm_fit)
# location fixed effects
betas <- (post_samps,( = "^beta", x = (post_samps))])
# posterior means
betas_mu <- (betas)
# posterior sds
betas_sd <- (betas, 2, )
# credible intervals
betas_cred <- (betas, 2, , (lb, ub))
# model matrix names
re_loc_names <- ("beta_", 0:((betas)-1), ": ", "location_",
(object$model_matrices$fe_loc_mm),sep = "")
# beta summary
beta_summary <- ((Post.mean = betas_mu,
Post.sd = betas_sd,
Cred.lb = betas_cred[1,],
Cred.ub = betas_cred[2,]), 3)
# add coefficient names
beta_summary <- (re_loc_names, beta_summary)
# remove first column name
(beta_summary)[1] <- ""
# beta summary
beta_summary
}
# extract and summarise scale fixed effects
eta_helper <- (object, cred = cred, ){
# cred lower bound
lb <- (1 - cred) / 2
# cred upper bound
ub <- 1 - lb
# posterior samples
post_samps <- (, object$melsm_fit)
# scale fixed effects
etas <- (post_samps,( = "^eta", x = (post_samps))])
# posterior means
etas_mu <- (etas)
# posterior sds
etas_sd <- (etas, 2, )
# credible interval
etas_cred <- (etas, 2, , (lb, ub))
# model matrix names
re_scl_names <- ("eta_", 0:((etas)-1), ": ",
" scale_", (object$model_matrices$fe_scl_mm),sep = "")
# eta summary
eta_summary <- ((Post.mean = etas_mu,
Post.sd = etas_sd,
Cred.lb = etas_cred[1,],
Cred.ub = etas_cred[2,]), 3)
# add coefficient names
eta_summary <- (re_scl_names, eta_summary)
# remove first column name
(eta_summary)[1] <- ""
# eta summary
eta_summary
}
hyp_helper <- (x, mixture,
cor_names, samps,
n_samps){
temp <- ()
(mixture == "SSVS"){
(i 1:(x)){
(( ("k1", x = x[i]) ) == 1 ){
tested_rho <- (stringr::str_extract_all( x[i], cor_names))
temp[i]] <- ("samps$`", tested_rho, "` == 1", sep = "")
} if ( ( ("k2", x = x[i]) ) == 1 ){
tested_rho <- (stringr::str_extract_all(x[i], cor_names))
temp[i]] <- ("samps$`", tested_rho, "` == 2", sep = "")
} if (( ("k3", x = x[i]) ) == 1 ){
tested_rho <- (stringr::str_extract_all( x[i], cor_names))
temp[i]] <- ("samps$`", tested_rho, "` == 3", sep = "")
} {
("error in hypothesis formulation")
}
}
} {
(i 1:(x)){
(( ("k1", x = x[i]) ) == 1 ){
tested_rho <- (stringr::str_extract_all( x[i], cor_names))
temp[i]] <- ("samps$`", tested_rho, "` == 0", sep = "")
} if ( ( ("k2", x = x[i]) ) == 1 ){
tested_rho <- (stringr::str_extract_all(x[i], cor_names))
temp[i]] <- ("samps$`", tested_rho, "` == 1", sep = "")
} {
("error in hypothesis formulation")
}
}
}
hyp_string <- ("samps[", (temp, collapse = " & "), ",]", sep = "")
H1_post_prob <- ((( = hyp_string))) / n_samps
H1_post_prob
}
