Skip to content

Commit

Permalink
rewrote nhmm parts using structs, renaming of variables, EM WIP
Browse files Browse the repository at this point in the history
  • Loading branch information
@helske
helske committed Nov 1, 2024
1 parent 4f0e445 commit 973b80a
Show file tree
Hide file tree
Showing 90 changed files with 3,881 additions and 2,424 deletions.
3 changes: 2 additions & 1 deletion DESCRIPTION
View file
Original file line number Diff line number Diff line change
Expand Up @@ -27,7 +27,8 @@ Description: Designed for fitting hidden (latent) Markov models and mixture
support for parallel computation. Documentation is available via several
vignettes, and the paper by Helske and Helske (2019, <doi:10.18637/jss.v088.i03>).
LazyData: true
LinkingTo:
LinkingTo:
nloptr,
Rcpp (>= 0.12.0),
RcppArmadillo
Depends:
Expand Down
136 changes: 68 additions & 68 deletions R/RcppExports.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -9,22 +9,6 @@ EMx <- function(transition_, emission_, init_, obs, nSymbols, coef_, X, numberOf
.Call(`_seqHMM_EMx`, transition_, emission_, init_, obs, nSymbols, coef_, X, numberOfStates, itermax, tol, trace, threads)
}

backward_nhmm_singlechannel <- function(eta_A, X_s, eta_B, X_o, obs) {
.Call(`_seqHMM_backward_nhmm_singlechannel`, eta_A, X_s, eta_B, X_o, obs)
}

backward_nhmm_multichannel <- function(eta_A, X_s, eta_B, X_o, obs, M) {
.Call(`_seqHMM_backward_nhmm_multichannel`, eta_A, X_s, eta_B, X_o, obs, M)
}

backward_mnhmm_singlechannel <- function(eta_A, X_s, eta_B, X_o, obs) {
.Call(`_seqHMM_backward_mnhmm_singlechannel`, eta_A, X_s, eta_B, X_o, obs)
}

backward_mnhmm_multichannel <- function(eta_A, X_s, eta_B, X_o, obs, M) {
.Call(`_seqHMM_backward_mnhmm_multichannel`, eta_A, X_s, eta_B, X_o, obs, M)
}

cost_matrix_singlechannel <- function(gamma_pi_est, gamma_pi_ref, gamma_A_est, gamma_A_ref, gamma_B_est, gamma_B_ref) {
.Call(`_seqHMM_cost_matrix_singlechannel`, gamma_pi_est, gamma_pi_ref, gamma_A_est, gamma_A_ref, gamma_B_est, gamma_B_ref)
}
Expand Down Expand Up @@ -61,22 +45,6 @@ fast_quantiles <- function(X, probs) {
.Call(`_seqHMM_fast_quantiles`, X, probs)
}

forward_nhmm_singlechannel <- function(eta_pi, X_i, eta_A, X_s, eta_B, X_o, obs) {
.Call(`_seqHMM_forward_nhmm_singlechannel`, eta_pi, X_i, eta_A, X_s, eta_B, X_o, obs)
}

forward_nhmm_multichannel <- function(eta_pi, X_i, eta_A, X_s, eta_B, X_o, obs, M) {
.Call(`_seqHMM_forward_nhmm_multichannel`, eta_pi, X_i, eta_A, X_s, eta_B, X_o, obs, M)
}

forward_mnhmm_singlechannel <- function(eta_pi, X_i, eta_A, X_s, eta_B, X_o, eta_omega, X_d, obs) {
.Call(`_seqHMM_forward_mnhmm_singlechannel`, eta_pi, X_i, eta_A, X_s, eta_B, X_o, eta_omega, X_d, obs)
}

forward_mnhmm_multichannel <- function(eta_pi, X_i, eta_A, X_s, eta_B, X_o, eta_omega, X_d, obs, M) {
.Call(`_seqHMM_forward_mnhmm_multichannel`, eta_pi, X_i, eta_A, X_s, eta_B, X_o, eta_omega, X_d, obs, M)
}

forwardbackward <- function(transition, emission, init, obs, forwardonly, threads) {
.Call(`_seqHMM_forwardbackward`, transition, emission, init, obs, forwardonly, threads)
}
Expand Down Expand Up @@ -205,76 +173,108 @@ log_objective <- function(transition, emission, init, obs, ANZ, BNZ, INZ, nSymbo
.Call(`_seqHMM_log_objective`, transition, emission, init, obs, ANZ, BNZ, INZ, nSymbols, threads)
}

log_objective_nhmm_singlechannel <- function(Qs, Qm, eta_pi, X_i, eta_A, X_s, eta_B, X_o, obs, iv_pi, iv_A, iv_B, tv_A, tv_B, Ti) {
.Call(`_seqHMM_log_objective_nhmm_singlechannel`, Qs, Qm, eta_pi, X_i, eta_A, X_s, eta_B, X_o, obs, iv_pi, iv_A, iv_B, tv_A, tv_B, Ti)
log_objectivex <- function(transition, emission, init, obs, ANZ, BNZ, INZ, nSymbols, coef, X, numberOfStates, threads) {
.Call(`_seqHMM_log_objectivex`, transition, emission, init, obs, ANZ, BNZ, INZ, nSymbols, coef, X, numberOfStates, threads)
}

log_objective_nhmm_multichannel <- function(Qs, Qm, eta_pi, X_i, eta_A, X_s, eta_B, X_o, obs, M, iv_pi, iv_A, iv_B, tv_A, tv_B, Ti) {
.Call(`_seqHMM_log_objective_nhmm_multichannel`, Qs, Qm, eta_pi, X_i, eta_A, X_s, eta_B, X_o, obs, M, iv_pi, iv_A, iv_B, tv_A, tv_B, Ti)
backward_nhmm_singlechannel <- function(eta_pi, X_pi, eta_A, X_A, eta_B, X_B, obs, Ti, iv_pi, iv_A, iv_B, tv_A, tv_B) {
.Call(`_seqHMM_backward_nhmm_singlechannel`, eta_pi, X_pi, eta_A, X_A, eta_B, X_B, obs, Ti, iv_pi, iv_A, iv_B, tv_A, tv_B)
}

log_objective_mnhmm_singlechannel <- function(Qs, Qm, Qd, eta_pi, X_i, eta_A, X_s, eta_B, X_o, eta_omega, X_d, obs, iv_pi, iv_A, iv_B, tv_A, tv_B, iv_omega, Ti) {
.Call(`_seqHMM_log_objective_mnhmm_singlechannel`, Qs, Qm, Qd, eta_pi, X_i, eta_A, X_s, eta_B, X_o, eta_omega, X_d, obs, iv_pi, iv_A, iv_B, tv_A, tv_B, iv_omega, Ti)
backward_nhmm_multichannel <- function(eta_pi, X_pi, eta_A, X_A, eta_B, X_B, obs, Ti, iv_pi, iv_A, iv_B, tv_A, tv_B) {
.Call(`_seqHMM_backward_nhmm_multichannel`, eta_pi, X_pi, eta_A, X_A, eta_B, X_B, obs, Ti, iv_pi, iv_A, iv_B, tv_A, tv_B)
}

log_objective_mnhmm_multichannel <- function(Qs, Qm, Qd, eta_pi, X_i, eta_A, X_s, eta_B, X_o, eta_omega, X_d, obs, M, iv_pi, iv_A, iv_B, tv_A, tv_B, iv_omega, Ti) {
.Call(`_seqHMM_log_objective_mnhmm_multichannel`, Qs, Qm, Qd, eta_pi, X_i, eta_A, X_s, eta_B, X_o, eta_omega, X_d, obs, M, iv_pi, iv_A, iv_B, tv_A, tv_B, iv_omega, Ti)
backward_mnhmm_singlechannel <- function(eta_omega, X_omega, eta_pi, X_pi, eta_A, X_A, eta_B, X_B, obs, Ti, iv_omega, iv_pi, iv_A, iv_B, tv_A, tv_B) {
.Call(`_seqHMM_backward_mnhmm_singlechannel`, eta_omega, X_omega, eta_pi, X_pi, eta_A, X_A, eta_B, X_B, obs, Ti, iv_omega, iv_pi, iv_A, iv_B, tv_A, tv_B)
}

log_objectivex <- function(transition, emission, init, obs, ANZ, BNZ, INZ, nSymbols, coef, X, numberOfStates, threads) {
.Call(`_seqHMM_log_objectivex`, transition, emission, init, obs, ANZ, BNZ, INZ, nSymbols, coef, X, numberOfStates, threads)
backward_mnhmm_multichannel <- function(eta_omega, X_omega, eta_pi, X_pi, eta_A, X_A, eta_B, X_B, obs, Ti, iv_omega, iv_pi, iv_A, iv_B, tv_A, tv_B) {
.Call(`_seqHMM_backward_mnhmm_multichannel`, eta_omega, X_omega, eta_pi, X_pi, eta_A, X_A, eta_B, X_B, obs, Ti, iv_omega, iv_pi, iv_A, iv_B, tv_A, tv_B)
}

objective <- function(transition, emission, init, obs, ANZ, BNZ, INZ, nSymbols, threads) {
.Call(`_seqHMM_objective`, transition, emission, init, obs, ANZ, BNZ, INZ, nSymbols, threads)
forward_nhmm_singlechannel <- function(eta_pi, X_pi, eta_A, X_A, eta_B, X_B, obs, Ti, iv_pi, iv_A, iv_B, tv_A, tv_B) {
.Call(`_seqHMM_forward_nhmm_singlechannel`, eta_pi, X_pi, eta_A, X_A, eta_B, X_B, obs, Ti, iv_pi, iv_A, iv_B, tv_A, tv_B)
}

objectivex <- function(transition, emission, init, obs, ANZ, BNZ, INZ, nSymbols, coef, X, numberOfStates, threads) {
.Call(`_seqHMM_objectivex`, transition, emission, init, obs, ANZ, BNZ, INZ, nSymbols, coef, X, numberOfStates, threads)
forward_nhmm_multichannel <- function(eta_pi, X_pi, eta_A, X_A, eta_B, X_B, obs, Ti, iv_pi, iv_A, iv_B, tv_A, tv_B) {
.Call(`_seqHMM_forward_nhmm_multichannel`, eta_pi, X_pi, eta_A, X_A, eta_B, X_B, obs, Ti, iv_pi, iv_A, iv_B, tv_A, tv_B)
}

simulate_nhmm_singlechannel <- function(eta_pi, X_i, eta_A, X_s, eta_B, X_o) {
.Call(`_seqHMM_simulate_nhmm_singlechannel`, eta_pi, X_i, eta_A, X_s, eta_B, X_o)
forward_mnhmm_singlechannel <- function(eta_omega, X_omega, eta_pi, X_pi, eta_A, X_A, eta_B, X_B, obs, Ti, iv_omega, iv_pi, iv_A, iv_B, tv_A, tv_B) {
.Call(`_seqHMM_forward_mnhmm_singlechannel`, eta_omega, X_omega, eta_pi, X_pi, eta_A, X_A, eta_B, X_B, obs, Ti, iv_omega, iv_pi, iv_A, iv_B, tv_A, tv_B)
}

simulate_nhmm_multichannel <- function(eta_pi, X_i, eta_A, X_s, eta_B, X_o, M) {
.Call(`_seqHMM_simulate_nhmm_multichannel`, eta_pi, X_i, eta_A, X_s, eta_B, X_o, M)
forward_mnhmm_multichannel <- function(eta_omega, X_omega, eta_pi, X_pi, eta_A, X_A, eta_B, X_B, obs, Ti, iv_omega, iv_pi, iv_A, iv_B, tv_A, tv_B) {
.Call(`_seqHMM_forward_mnhmm_multichannel`, eta_omega, X_omega, eta_pi, X_pi, eta_A, X_A, eta_B, X_B, obs, Ti, iv_omega, iv_pi, iv_A, iv_B, tv_A, tv_B)
}

simulate_mnhmm_singlechannel <- function(eta_pi, X_i, eta_A, X_s, eta_B, X_o, eta_omega, X_d) {
.Call(`_seqHMM_simulate_mnhmm_singlechannel`, eta_pi, X_i, eta_A, X_s, eta_B, X_o, eta_omega, X_d)
log_objective_nhmm_singlechannel <- function(eta_pi, X_pi, eta_A, X_A, eta_B, X_B, obs, iv_pi, iv_A, iv_B, tv_A, tv_B, Ti) {
.Call(`_seqHMM_log_objective_nhmm_singlechannel`, eta_pi, X_pi, eta_A, X_A, eta_B, X_B, obs, iv_pi, iv_A, iv_B, tv_A, tv_B, Ti)
}

simulate_mnhmm_multichannel <- function(eta_pi, X_i, eta_A, X_s, eta_B, X_o, eta_omega, X_d, M) {
.Call(`_seqHMM_simulate_mnhmm_multichannel`, eta_pi, X_i, eta_A, X_s, eta_B, X_o, eta_omega, X_d, M)
log_objective_nhmm_multichannel <- function(eta_pi, X_pi, eta_A, X_A, eta_B, X_B, obs, iv_pi, iv_A, iv_B, tv_A, tv_B, Ti) {
.Call(`_seqHMM_log_objective_nhmm_multichannel`, eta_pi, X_pi, eta_A, X_A, eta_B, X_B, obs, iv_pi, iv_A, iv_B, tv_A, tv_B, Ti)
}

softmax <- function(x) {
.Call(`_seqHMM_softmax`, x)
log_objective_mnhmm_singlechannel <- function(eta_omega, X_omega, eta_pi, X_pi, eta_A, X_A, eta_B, X_B, obs, iv_pi, iv_A, iv_B, tv_A, tv_B, iv_omega, Ti) {
.Call(`_seqHMM_log_objective_mnhmm_singlechannel`, eta_omega, X_omega, eta_pi, X_pi, eta_A, X_A, eta_B, X_B, obs, iv_pi, iv_A, iv_B, tv_A, tv_B, iv_omega, Ti)
}

varcoef <- function(coef, X) {
.Call(`_seqHMM_varcoef`, coef, X)
log_objective_mnhmm_multichannel <- function(eta_omega, X_omega, eta_pi, X_pi, eta_A, X_A, eta_B, X_B, obs, iv_pi, iv_A, iv_B, tv_A, tv_B, iv_omega, Ti) {
.Call(`_seqHMM_log_objective_mnhmm_multichannel`, eta_omega, X_omega, eta_pi, X_pi, eta_A, X_A, eta_B, X_B, obs, iv_pi, iv_A, iv_B, tv_A, tv_B, iv_omega, Ti)
}

viterbi <- function(transition, emission, init, obs) {
.Call(`_seqHMM_viterbi`, transition, emission, init, obs)
simulate_nhmm_singlechannel <- function(eta_pi, X_pi, eta_A, X_A, eta_B, X_B) {
.Call(`_seqHMM_simulate_nhmm_singlechannel`, eta_pi, X_pi, eta_A, X_A, eta_B, X_B)
}

simulate_nhmm_multichannel <- function(eta_pi, X_pi, eta_A, X_A, eta_B, X_B, M) {
.Call(`_seqHMM_simulate_nhmm_multichannel`, eta_pi, X_pi, eta_A, X_A, eta_B, X_B, M)
}

simulate_mnhmm_singlechannel <- function(eta_pi, X_pi, eta_A, X_A, eta_B, X_B, eta_omega, X_omega) {
.Call(`_seqHMM_simulate_mnhmm_singlechannel`, eta_pi, X_pi, eta_A, X_A, eta_B, X_B, eta_omega, X_omega)
}

simulate_mnhmm_multichannel <- function(eta_pi, X_pi, eta_A, X_A, eta_B, X_B, eta_omega, X_omega, M) {
.Call(`_seqHMM_simulate_mnhmm_multichannel`, eta_pi, X_pi, eta_A, X_A, eta_B, X_B, eta_omega, X_omega, M)
}

viterbi_nhmm_singlechannel <- function(eta_pi, X_pi, eta_A, X_A, eta_B, X_B, obs, Ti, iv_pi, iv_A, iv_B, tv_A, tv_B) {
.Call(`_seqHMM_viterbi_nhmm_singlechannel`, eta_pi, X_pi, eta_A, X_A, eta_B, X_B, obs, Ti, iv_pi, iv_A, iv_B, tv_A, tv_B)
}

viterbi_nhmm_multichannel <- function(eta_pi, X_pi, eta_A, X_A, eta_B, X_B, obs, Ti, iv_pi, iv_A, iv_B, tv_A, tv_B) {
.Call(`_seqHMM_viterbi_nhmm_multichannel`, eta_pi, X_pi, eta_A, X_A, eta_B, X_B, obs, Ti, iv_pi, iv_A, iv_B, tv_A, tv_B)
}

viterbi_mnhmm_singlechannel <- function(eta_omega, X_omega, eta_pi, X_pi, eta_A, X_A, eta_B, X_B, obs, Ti, iv_omega, iv_pi, iv_A, iv_B, tv_A, tv_B) {
.Call(`_seqHMM_viterbi_mnhmm_singlechannel`, eta_omega, X_omega, eta_pi, X_pi, eta_A, X_A, eta_B, X_B, obs, Ti, iv_omega, iv_pi, iv_A, iv_B, tv_A, tv_B)
}

viterbi_nhmm_singlechannel <- function(eta_pi, X_i, eta_A, X_s, eta_B, X_o, obs) {
.Call(`_seqHMM_viterbi_nhmm_singlechannel`, eta_pi, X_i, eta_A, X_s, eta_B, X_o, obs)
viterbi_mnhmm_multichannel <- function(eta_omega, X_omega, eta_pi, X_pi, eta_A, X_A, eta_B, X_B, obs, Ti, iv_omega, iv_pi, iv_A, iv_B, tv_A, tv_B) {
.Call(`_seqHMM_viterbi_mnhmm_multichannel`, eta_omega, X_omega, eta_pi, X_pi, eta_A, X_A, eta_B, X_B, obs, Ti, iv_omega, iv_pi, iv_A, iv_B, tv_A, tv_B)
}

viterbi_nhmm_multichannel <- function(eta_pi, X_i, eta_A, X_s, eta_B, X_o, obs, M) {
.Call(`_seqHMM_viterbi_nhmm_multichannel`, eta_pi, X_i, eta_A, X_s, eta_B, X_o, obs, M)
objective <- function(transition, emission, init, obs, ANZ, BNZ, INZ, nSymbols, threads) {
.Call(`_seqHMM_objective`, transition, emission, init, obs, ANZ, BNZ, INZ, nSymbols, threads)
}

objectivex <- function(transition, emission, init, obs, ANZ, BNZ, INZ, nSymbols, coef, X, numberOfStates, threads) {
.Call(`_seqHMM_objectivex`, transition, emission, init, obs, ANZ, BNZ, INZ, nSymbols, coef, X, numberOfStates, threads)
}

softmax <- function(x) {
.Call(`_seqHMM_softmax`, x)
}

viterbi_mnhmm_singlechannel <- function(eta_pi, X_i, eta_A, X_s, eta_B, X_o, eta_omega, X_d, obs) {
.Call(`_seqHMM_viterbi_mnhmm_singlechannel`, eta_pi, X_i, eta_A, X_s, eta_B, X_o, eta_omega, X_d, obs)
varcoef <- function(coef, X) {
.Call(`_seqHMM_varcoef`, coef, X)
}

viterbi_mnhmm_multichannel <- function(eta_pi, X_i, eta_A, X_s, eta_B, X_o, eta_omega, X_d, obs, M) {
.Call(`_seqHMM_viterbi_mnhmm_multichannel`, eta_pi, X_i, eta_A, X_s, eta_B, X_o, eta_omega, X_d, obs, M)
viterbi <- function(transition, emission, init, obs) {
.Call(`_seqHMM_viterbi`, transition, emission, init, obs)
}

viterbix <- function(transition, emission, init, obs, coef, X, numberOfStates) {
Expand Down
52 changes: 26 additions & 26 deletions R/ame.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -74,12 +74,12 @@ ame.nhmm <- function(
times <- colnames(model$observations[[1]])
symbol_names <- model$symbol_names
}
if (!attr(model$X_initial, "iv")) {
X1 <- model1$X_initial[, 1L, drop = FALSE]
X2 <- model2$X_initial[, 1L, drop = FALSE]
if (!attr(model$X_pi, "iv")) {
X1 <- model1$X_pi[, 1L, drop = FALSE]
X2 <- model2$X_pi[, 1L, drop = FALSE]
} else {
X1 <- model1$X_initial
X2 <- model2$X_initial
X1 <- model1$X_pi
X2 <- model2$X_pi
}
qs_pi <- get_pi_ame(model$boot$gamma_pi, X1, X2, probs)
colnames(qs_pi) <- paste0("q", 100 * probs)
Expand All @@ -92,16 +92,16 @@ ame.nhmm <- function(
),
qs_pi
)
model1$X_transition[attr(model$X_transition, "missing")] <- NA
model2$X_transition[attr(model$X_transition, "missing")] <- NA
if (!attr(model$X_transition, "iv")) {
X1 <- model1$X_transition[, 1L, , drop = FALSE]
X2 <- model2$X_transition[, 1L, , drop = FALSE]
model1$X_A[attr(model$X_A, "missing")] <- NA
model2$X_A[attr(model$X_A, "missing")] <- NA
if (!attr(model$X_A, "iv")) {
X1 <- model1$X_A[, 1L, , drop = FALSE]
X2 <- model2$X_A[, 1L, , drop = FALSE]
} else {
X1 <- model1$X_transition
X2 <- model2$X_transition
X1 <- model1$X_A
X2 <- model2$X_A
}
tv_A <- attr(model$X_transition, "tv")
tv_A <- attr(model$X_A, "tv")
S <- model$n_states
N <- model$n_sequences
T_ <- model$length_of_sequences
Expand All @@ -126,16 +126,16 @@ ame.nhmm <- function(
)
colnames(ame_A)[1] <- model$time_variable

model1$X_emission[attr(model$X_emission, "missing")] <- NA
model1$X_emission[attr(model$X_emission, "missing")] <- NA
if (!attr(model$X_emission, "iv")) {
X1 <- model1$X_emission[, 1L, drop = FALSE]
X2 <- model2$X_emission[, 1L, drop = FALSE]
model1$X_B[attr(model$X_B, "missing")] <- NA
model1$X_B[attr(model$X_B, "missing")] <- NA
if (!attr(model$X_B, "iv")) {
X1 <- model1$X_B[, 1L, drop = FALSE]
X2 <- model2$X_B[, 1L, drop = FALSE]
} else {
X1 <- model1$X_emission
X2 <- model2$X_emission
X1 <- model1$X_B
X2 <- model2$X_B
}
tv_B <- attr(model$X_emission, "tv")
tv_B <- attr(model$X_B, "tv")
M <- model$n_symbols
if (C == 1) {
qs_B <- get_B_ame(
Expand Down Expand Up @@ -216,12 +216,12 @@ ame.mnhmm <- function(
newdata[[variable]] <- values[2]
model2 <- update(model, newdata)

if (!attr(model$X_cluster, "iv")) {
X1 <- model1$X_cluster[, 1L, drop = FALSE]
X2 <- model2$X_cluster[, 1L, drop = FALSE]
if (!attr(model$X_omega, "iv")) {
X1 <- model1$X_omega[, 1L, drop = FALSE]
X2 <- model2$X_omega[, 1L, drop = FALSE]
} else {
X1 <- model1$X_cluster
X2 <- model2$X_cluster
X1 <- model1$X_omega
X2 <- model2$X_omega
}
qs_omega <- get_omega_ame(model$boot$gamma_omega, X1, X2, probs)
colnames(qs_omega) <- paste0("q", 100 * probs)
Expand Down
22 changes: 11 additions & 11 deletions R/bootstrap.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -9,11 +9,11 @@ bootstrap_model <- function(model) {
model$observations[[i]] <- model$observations[[i]][idx, , drop = FALSE]
}
}
model$X_initial <- model$X_initial[, idx, drop = FALSE]
model$X_transition <- model$X_transition[, , idx, drop = FALSE]
model$X_emission <- model$X_emission[, , idx, drop = FALSE]
if (!is.null(model$X_cluster)) {
model$X_cluster <- model$X_cluster[, idx, drop = FALSE]
model$X_pi <- model$X_pi[, idx, drop = FALSE]
model$X_A <- model$X_A[, , idx, drop = FALSE]
model$X_B <- model$X_B[, , idx, drop = FALSE]
if (!is.null(model$X_omega)) {
model$X_omega <- model$X_omega[, idx, drop = FALSE]
}
model$sequence_lengths <- model$sequence_lengths[idx]
model
Expand Down Expand Up @@ -97,13 +97,13 @@ bootstrap_coefs.nhmm <- function(model, B = 1000,
gamma_A <- replicate(B, gammas_mle$A, simplify = FALSE)
gamma_B <- replicate(B, gammas_mle$B, simplify = FALSE)

if (verbose) pb <- utils::txtProgressBar(min = 0, max = 100, style = 3)
if (verbose) pb <- utils::txtProgressBar(min = 0, max = B, style = 3)
if (method == "nonparametric") {
out <- future.apply::future_lapply(
seq_len(B), function(i) {
mod <- bootstrap_model(model)
fit <- fit_nhmm(mod, init, init_sd = 0, restarts = 0, ...)
if (verbose) utils::setTxtProgressBar(pb, 100 * i/B)
if (verbose) utils::setTxtProgressBar(pb, i)
permute_states(fit$gammas, gammas_mle)
}
)
Expand All @@ -124,7 +124,7 @@ bootstrap_coefs.nhmm <- function(model, B = 1000,
N, T_, M, S, formula_pi, formula_A, formula_B,
data = d, time, id, init)$model
fit <- fit_nhmm(mod, init, init_sd = 0, restarts = 0, ...)
if (verbose) utils::setTxtProgressBar(pb, 100 * i/B)
if (verbose) utils::setTxtProgressBar(pb, i)
fit$gammas <- permute_states(fit$gammas, gammas_mle)
}
)
Expand Down Expand Up @@ -152,7 +152,7 @@ bootstrap_coefs.mnhmm <- function(model, B = 1000,
gamma_B <- replicate(B, gammas_mle$B, simplify = FALSE)
gamma_omega <- replicate(B, gammas_mle$omega, simplify = FALSE)
D <- model$n_clusters
if (verbose) pb <- utils::txtProgressBar(min = 0, max = 100, style = 3)
if (verbose) pb <- utils::txtProgressBar(min = 0, max = B, style = 3)
if (method == "nonparametric") {
for (i in seq_len(B)) {
mod <- bootstrap_model(model)
Expand All @@ -171,7 +171,7 @@ bootstrap_coefs.mnhmm <- function(model, B = 1000,
gamma_A[[i]] <- fit$gammas$A
gamma_B[[i]] <- fit$gammas$B
gamma_omega[[i]] <- fit$gammas$omega
if (verbose) utils::setTxtProgressBar(pb, 100 * i/B)
if (verbose) utils::setTxtProgressBar(pb, i)
}
} else {
N <- model$n_sequences
Expand Down Expand Up @@ -204,7 +204,7 @@ bootstrap_coefs.mnhmm <- function(model, B = 1000,
gamma_A[[i]] <- fit$gammas$A
gamma_B[[i]] <- fit$gammas$B
gamma_omega[[i]] <- fit$gammas$omega
if (verbose) utils::setTxtProgressBar(pb, 100 * i/B)
if (verbose) utils::setTxtProgressBar(pb, i)
}
}
if (verbose) close(pb)
Expand Down
2 changes: 1 addition & 1 deletion R/build_nhmm.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -9,7 +9,7 @@ build_nhmm <- function(
out <- create_base_nhmm(
observations, data, time, id, n_states, state_names, channel_names,
initial_formula, transition_formula, emission_formula)
out[c("cluster_names", "n_clusters", "X_cluster")] <- NULL
out[c("cluster_names", "n_clusters", "X_omega")] <- NULL
structure(
out$model,
class = "nhmm",
Expand Down
Loading

0 comments on commit 973b80a

Please sign in to comment.