diff --git a/DESCRIPTION b/DESCRIPTION index 73216613..bdd5e489 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -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, ). LazyData: true -LinkingTo: +LinkingTo: + nloptr, Rcpp (>= 0.12.0), RcppArmadillo Depends: diff --git a/R/RcppExports.R b/R/RcppExports.R index 5fe4af39..63640921 100644 --- a/R/RcppExports.R +++ b/R/RcppExports.R @@ -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) } @@ -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) } @@ -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) { diff --git a/R/ame.R b/R/ame.R index bb56f9c2..25efed21 100644 --- a/R/ame.R +++ b/R/ame.R @@ -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) @@ -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 @@ -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( @@ -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) diff --git a/R/bootstrap.R b/R/bootstrap.R index 8855f3b2..4f402ca6 100644 --- a/R/bootstrap.R +++ b/R/bootstrap.R @@ -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 @@ -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) } ) @@ -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) } ) @@ -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) @@ -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 @@ -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) diff --git a/R/build_nhmm.R b/R/build_nhmm.R index 72556790..eb845f2e 100644 --- a/R/build_nhmm.R +++ b/R/build_nhmm.R @@ -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", diff --git a/R/coef.R b/R/coef.R index 015ac024..6b47ffe1 100644 --- a/R/coef.R +++ b/R/coef.R @@ -11,11 +11,11 @@ coef.nhmm <- function(object, probs, ...) { S <- object$n_states M <- object$n_symbols - coef_names <- attr(object$X_initial, "coef_names") + coef_names <- attr(object$X_pi, "coef_names") sd_pi_X <- rep( c( if(coef_names[1] == "(Intercept)") 1 else NULL, - attr(object$X_initial, "X_sd") + attr(object$X_pi, "X_sd") ), each = S ) gamma_pi <- data.frame( @@ -23,11 +23,11 @@ coef.nhmm <- function(object, probs, ...) { parameter = rep(coef_names, each = S), estimate = c(object$gammas$pi) / sd_pi_X ) - coef_names <- attr(object$X_transition, "coef_names") + coef_names <- attr(object$X_A, "coef_names") sd_A_X <- rep( c( if(coef_names[1] == "(Intercept)") 1 else NULL, - attr(object$X_transition, "X_sd") + attr(object$X_A, "X_sd") ), each = S^2 ) gamma_A <- data.frame( @@ -36,10 +36,10 @@ coef.nhmm <- function(object, probs, ...) { parameter = rep(coef_names, each = S^2), estimate = c(object$gammas$A) / sd_A_X ) - coef_names <- attr(object$X_emission, "coef_names") + coef_names <- attr(object$X_B, "coef_names") sd_B_X <- c( if(coef_names[1] == "(Intercept)") 1 else NULL, - attr(object$X_emission, "X_sd") + attr(object$X_B, "X_sd") ) if (object$n_channels == 1) { gamma_B <- data.frame( @@ -107,44 +107,44 @@ coef.mnhmm <- function(object, probs, ...) { M <- object$n_symbols D <- object$n_clusters object$state_names <- unname(object$state_names) - coef_names <- attr(object$X_initial, "coef_names") + coef_names <- attr(object$X_pi, "coef_names") sd_pi_X <- rep( c( if(coef_names[1] == "(Intercept)") 1 else NULL, - attr(object$X_initial, "X_sd") + attr(object$X_pi, "X_sd") ), each = S ) - K_i <- length(coef_names) + K_pi <- length(coef_names) gamma_pi <- data.frame( - cluster = rep(object$cluster_names, each = S * K_i), + cluster = rep(object$cluster_names, each = S * K_pi), state = unlist(object$state_names), parameter = rep(coef_names, each = S), estimate = unlist(object$gammas$pi) / sd_pi_X ) - coef_names <- attr(object$X_transition, "coef_names") + coef_names <- attr(object$X_A, "coef_names") sd_A_X <- rep( c( if(coef_names[1] == "(Intercept)") 1 else NULL, - attr(object$X_transition, "X_sd") + attr(object$X_A, "X_sd") ), each = S^2 ) - K_s <- length(coef_names) + K_A <- length(coef_names) gamma_A <- data.frame( - cluster = rep(object$cluster_names, each = S * S * K_s), + cluster = rep(object$cluster_names, each = S * S * K_A), state_from = unlist(object$state_names), state_to = rep(unlist(object$state_names), each = S), parameter = rep(coef_names, each = S * S), estimate = unlist(object$gammas$A) / sd_A_X ) - coef_names <- attr(object$X_emission, "coef_names") + coef_names <- attr(object$X_B, "coef_names") sd_B_X <- c( if(coef_names[1] == "(Intercept)") 1 else NULL, - attr(object$X_emission, "X_sd") + attr(object$X_B, "X_sd") ) - K_o <- length(coef_names) + K_B <- length(coef_names) if (object$n_channels == 1) { gamma_B <- data.frame( - cluster = rep(object$cluster_names, each = S * M * K_o), + cluster = rep(object$cluster_names, each = S * M * K_B), state = unlist(object$state_names), observation = rep(object$symbol_names, each = S), parameter = rep(coef_names, each = S * M), @@ -160,7 +160,7 @@ coef.mnhmm <- function(object, probs, ...) { lapply( seq_len(object$n_channels), function(i) { data.frame( - cluster = rep(object$cluster_names[d], each = S * M[i] * K_o), + cluster = rep(object$cluster_names[d], each = S * M[i] * K_B), state = object$state_names[[d]], observation = rep(object$symbol_names[[i]], each = S), parameter = rep(coef_names, each = S * M[i]), @@ -173,11 +173,11 @@ coef.mnhmm <- function(object, probs, ...) { ) ) } - coef_names <- attr(object$X_cluster, "coef_names") + coef_names <- attr(object$X_omega, "coef_names") sd_omega_X <- rep( c( if(coef_names[1] == "(Intercept)") 1 else NULL, - attr(object$X_cluster, "X_sd") + attr(object$X_omega, "X_sd") ), each = D ) gamma_omega <- data.frame( diff --git a/R/create_base_nhmm.R b/R/create_base_nhmm.R index cc445306..2125e377 100644 --- a/R/create_base_nhmm.R +++ b/R/create_base_nhmm.R @@ -130,14 +130,15 @@ create_base_nhmm <- function(observations, data, time, id, n_states, etas <- create_initial_values( list(gamma_pi = NULL, gamma_A = NULL, gamma_B = NULL, gamma_omega = NULL), n_states, n_symbols, 0, - length(pi$coef_names), length(A$coef_names), length(B$coef_names), - length(omega$coef_names), n_clusters + length(attr(pi$X, "coef_names")), length(attr(A$X, "coef_names")), + length(attr(B$X, "coef_names")), length(attr(omega$X, "coef_names")), n_clusters ) } else { etas <- create_initial_values( list(pi = NULL, A = NULL, B = NULL), n_states, n_symbols, 0, - length(pi$coef_names), length(A$coef_names), length(B$coef_names) + length(attr(pi$X, "coef_names")), length(attr(A$X, "coef_names")), + length(attr(B$X, "coef_names")) ) omega <- list(n_pars = 0, iv = FALSE, X_mean = NULL, X_sd = NULL) } @@ -146,10 +147,10 @@ create_base_nhmm <- function(observations, data, time, id, n_states, observations = observations, time_variable = if (is.null(time)) "time" else time, id_variable = if (is.null(id)) "id" else id, - X_initial = pi$X, - X_transition = A$X, - X_emission = B$X, - X_cluster = if(mixture) omega$X else NULL, + X_pi = pi$X, + X_A = A$X, + X_B = B$X, + X_omega = if(mixture) omega$X else NULL, initial_formula = pi$formula, transition_formula = A$formula, emission_formula = B$formula, diff --git a/R/create_initial_values.R b/R/create_initial_values.R index febecb1b..789e2abf 100644 --- a/R/create_initial_values.R +++ b/R/create_initial_values.R @@ -196,22 +196,22 @@ create_inits_matrix <- function(x, n, m, K, sd = 0) { z } -create_initial_values <- function(inits, S, M, init_sd, K_i, K_s, K_o, K_d = 0, +create_initial_values <- function(inits, S, M, init_sd, K_pi, K_A, K_B, K_omega = 0, D = 1) { if(!is.null(inits$initial_probs)) { if (D > 1) { pi <- lapply( seq_len(D), function(i) { - create_inits_vector(inits$initial_probs[[i]], S, K_i, init_sd) + create_inits_vector(inits$initial_probs[[i]], S, K_pi, init_sd) } ) } else { - pi <- create_inits_vector(inits$initial_probs, S, K_i, init_sd) + pi <- create_inits_vector(inits$initial_probs, S, K_pi, init_sd) } } else { pi <- create_eta_pi_inits( - inits$pi, S, K_i, init_sd, D + inits$pi, S, K_pi, init_sd, D ) } @@ -219,16 +219,16 @@ create_initial_values <- function(inits, S, M, init_sd, K_i, K_s, K_o, K_d = 0, if (D > 1) { A <- lapply( seq_len(D), function(i) { - create_inits_matrix(inits$transition_probs[[i]], S, S, K_s, init_sd) + create_inits_matrix(inits$transition_probs[[i]], S, S, K_A, init_sd) } ) } else { A <- create_inits_matrix( - inits$transition_probs, S, S, K_s, init_sd + inits$transition_probs, S, S, K_A, init_sd ) } } else { - A <- create_eta_A_inits(inits$A, S, K_s, init_sd, D) + A <- create_eta_A_inits(inits$A, S, K_A, init_sd, D) } if(!is.null(inits$emission_probs)) { @@ -238,13 +238,13 @@ create_initial_values <- function(inits, S, M, init_sd, K_i, K_s, K_o, K_d = 0, seq_len(D), function(i) { lapply(seq_len(length(M)), function(j) { create_inits_matrix( - inits$emission_probs[[i]][[j]], S, M[j], K_o, init_sd) + inits$emission_probs[[i]][[j]], S, M[j], K_B, init_sd) }) }) } else { B <- lapply( seq_len(D), function(i) { - create_inits_matrix(inits$emission_probs[[i]], S, M, K_o, init_sd) + create_inits_matrix(inits$emission_probs[[i]], S, M, K_B, init_sd) } ) } @@ -252,16 +252,16 @@ create_initial_values <- function(inits, S, M, init_sd, K_i, K_s, K_o, K_d = 0, if (length(M) > 1) { B <- lapply(seq_len(length(M)), function(j) { create_inits_matrix( - inits$emission_probs[[j]], S, M[j], K_o, init_sd) + inits$emission_probs[[j]], S, M[j], K_B, init_sd) }) } else { B <- create_inits_matrix( - inits$emission_probs, S, M, K_o, init_sd + inits$emission_probs, S, M, K_B, init_sd ) } } } else { - B <- create_eta_B_inits(inits$B, S, M, K_o, init_sd, D) + B <- create_eta_B_inits(inits$B, S, M, K_B, init_sd, D) } out <- list( pi = pi, @@ -271,11 +271,11 @@ create_initial_values <- function(inits, S, M, init_sd, K_i, K_s, K_o, K_d = 0, if (D > 1) { if(!is.null(inits$cluster_probs)) { omega <- create_inits_vector( - inits$cluster_probs, D, K_d, init_sd + inits$cluster_probs, D, K_omega, init_sd ) } else { omega <- create_eta_omega_inits( - inits$omega, D, K_d, init_sd + inits$omega, D, K_omega, init_sd ) } out$omega <- omega diff --git a/R/fit_mnhmm.R b/R/fit_mnhmm.R index 7b68e673..650142d6 100644 --- a/R/fit_mnhmm.R +++ b/R/fit_mnhmm.R @@ -31,57 +31,57 @@ fit_mnhmm <- function(model, inits, init_sd, restarts, n_s <- attr(model, "np_A") n_o <- attr(model, "np_B") n_d <- attr(model, "np_omega") - iv_pi <- attr(model$X_initial, "iv") - iv_A <- attr(model$X_transition, "iv") - iv_B <- attr(model$X_emission, "iv") - iv_omega <- attr(model$X_cluster, "iv") - tv_A <- attr(model$X_transition, "tv") - tv_B <- attr(model$X_emission, "tv") - X_i <- model$X_initial - X_s <- model$X_transition - X_o <- model$X_emission - X_d <- model$X_cluster - K_i <- nrow(X_i) - K_s <- nrow(X_s) - K_o <- nrow(X_o) - K_d <- nrow(X_d) + iv_pi <- attr(model$X_pi, "iv") + iv_A <- attr(model$X_A, "iv") + iv_B <- attr(model$X_B, "iv") + iv_omega <- attr(model$X_omega, "iv") + tv_A <- attr(model$X_A, "tv") + tv_B <- attr(model$X_B, "tv") + X_pi <- model$X_pi + X_A <- model$X_A + X_B <- model$X_B + X_omega <- model$X_omega + K_pi <- nrow(X_pi) + K_A <- nrow(X_A) + K_B <- nrow(X_B) + K_omega <- nrow(X_omega) Ti <- model$sequence_lengths n_obs <- nobs(model) dots <- list(...) if (isTRUE(dots$maxeval < 0)) { pars <- unlist(create_initial_values( - inits, S, M, init_sd, K_i, K_s, K_o, K_d, D + inits, S, M, init_sd, K_pi, K_A, K_B, K_omega, D )) model$etas$pi <- create_eta_pi_mnhmm( - pars[seq_len(n_i)], S, K_i, D + pars[seq_len(n_i)], S, K_pi, D ) model$gammas$pi <- c(eta_to_gamma_mat_field( model$etas$pi )) model$etas$A <- create_eta_A_mnhmm( - pars[n_i + seq_len(n_s)], S, K_s, D + pars[n_i + seq_len(n_s)], S, K_A, D ) model$gammas$A <- c(eta_to_gamma_cube_field( model$etas$A )) if (C == 1L) { model$etas$B <- create_eta_B_mnhmm( - pars[n_i + n_s + seq_len(n_o)], S, M, K_o, D + pars[n_i + n_s + seq_len(n_o)], S, M, K_B, D ) model$gammas$B <- c(eta_to_gamma_cube_field( model$etas$B )) } else { model$etas$B <- create_eta_multichannel_B_mnhmm( - pars[n_i + n_s + seq_len(n_o)], S, M, K_o, D + pars[n_i + n_s + seq_len(n_o)], S, M, K_B, D ) l <- lengths(model$etas$B) gamma_B <- c(eta_to_gamma_cube_field(unlist(model$etas$B, recursive = FALSE))) model$gammas$B <- split(gamma_B, rep(seq_along(l), l)) } model$etas$omega <- create_eta_omega_mnhmm( - pars[n_i + n_s + n_o + seq_len(n_d)], D, K_d + pars[n_i + n_s + n_o + seq_len(n_d)], D, K_omega ) model$gammas$omega <- eta_to_gamma_mat( model$etas$omega @@ -105,23 +105,19 @@ fit_mnhmm <- function(model, inits, init_sd, restarts, dots$check_derivatives <- FALSE if (C == 1L) { - Qs <- t(create_Q(S)) - Qm <- t(create_Q(M)) - Qd <- t(create_Q(D)) if (need_grad) { objectivef <- function(pars) { - eta_pi <- create_eta_pi_mnhmm(pars[seq_len(n_i)], S, K_i, D) - eta_A <- create_eta_A_mnhmm(pars[n_i + seq_len(n_s)], S, K_s, D) + eta_pi <- create_eta_pi_mnhmm(pars[seq_len(n_i)], S, K_pi, D) + eta_A <- create_eta_A_mnhmm(pars[n_i + seq_len(n_s)], S, K_A, D) eta_B <- create_eta_B_mnhmm( - pars[n_i + n_s + seq_len(n_o)], S, M, K_o, D + pars[n_i + n_s + seq_len(n_o)], S, M, K_B, D ) eta_omega <- create_eta_omega_mnhmm( - pars[n_i + n_s + n_o + seq_len(n_d)], D, K_d + pars[n_i + n_s + n_o + seq_len(n_d)], D, K_omega ) out <- 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 + eta_omega, X_omega, eta_pi, X_pi, eta_A, X_A, eta_B, X_B, + obs, iv_omega, iv_pi, iv_A, iv_B, tv_A, tv_B, Ti ) list( objective = - out$loglik / n_obs, @@ -130,46 +126,42 @@ fit_mnhmm <- function(model, inits, init_sd, restarts, } } else { objectivef <- function(pars) { - eta_pi <- create_eta_pi_mnhmm(pars[seq_len(n_i)], S, K_i, D) - eta_A <- create_eta_A_mnhmm(pars[n_i + seq_len(n_s)], S, K_s, D) + eta_pi <- create_eta_pi_mnhmm(pars[seq_len(n_i)], S, K_pi, D) + eta_A <- create_eta_A_mnhmm(pars[n_i + seq_len(n_s)], S, K_A, D) eta_B <- create_eta_B_mnhmm( - pars[n_i + n_s + seq_len(n_o)], S, M, K_o, D + pars[n_i + n_s + seq_len(n_o)], S, M, K_B, D ) eta_omega <- create_eta_omega_mnhmm( - pars[n_i + n_s + n_o + seq_len(n_d)], D, K_d + pars[n_i + n_s + n_o + seq_len(n_d)], D, K_omega ) out <- forward_mnhmm_singlechannel( - eta_pi, X_i, eta_A, X_s, eta_B, X_o, - eta_omega, X_d, obs + eta_omega, X_omega, eta_pi, X_pi, eta_A, X_A, eta_B, X_B, + obs, iv_omega, iv_pi, iv_A, iv_B, tv_A, tv_B, Ti ) - sum(apply(out[, T_, ], 2, logSumExp)) / n_obs } } } else { - Qs <- t(create_Q(S)) - Qm <- lapply(M, function(m) t(create_Q(m))) - Qd <- t(create_Q(D)) if (need_grad) { objectivef <- function(pars) { - eta_pi <- create_eta_pi_mnhmm(pars[seq_len(n_i)], S, K_i, D) + eta_pi <- create_eta_pi_mnhmm(pars[seq_len(n_i)], S, K_pi, D) eta_A <- create_eta_A_mnhmm( pars[n_i + seq_len(n_s)], - S, K_s, D + S, K_A, D ) eta_B <- unlist( create_eta_multichannel_B_mnhmm( - pars[n_i + n_s + seq_len(n_o)], S, M, K_o, D + pars[n_i + n_s + seq_len(n_o)], S, M, K_B, D ), recursive = FALSE ) eta_omega <- create_eta_omega_mnhmm( - pars[n_i + n_s + n_o + seq_len(n_d)], D, K_d + pars[n_i + n_s + n_o + seq_len(n_d)], D, K_omega ) out <- 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 + eta_omega, X_omega, eta_pi, X_pi, eta_A, X_A, eta_B, X_B, + obs, iv_omega, iv_pi, iv_A, iv_B, tv_A, tv_B, Ti ) list( objective = - out$loglik / n_obs, @@ -178,24 +170,24 @@ fit_mnhmm <- function(model, inits, init_sd, restarts, } } else { objectivef <- function(pars) { - eta_pi <- create_eta_pi_mnhmm(pars[seq_len(n_i)], S, K_i, D) + eta_pi <- create_eta_pi_mnhmm(pars[seq_len(n_i)], S, K_pi, D) eta_A <- create_eta_A_mnhmm( - pars[n_i + seq_len(n_s)], S, K_s, D + pars[n_i + seq_len(n_s)], S, K_A, D ) eta_B <- unlist( create_eta_multichannel_B_mnhmm( - pars[n_i + n_s + seq_len(n_o)], S, M, K_o, D + pars[n_i + n_s + seq_len(n_o)], S, M, K_B, D ), recursive = FALSE ) eta_omega <- create_eta_omega_mnhmm( - pars[n_i + n_s + n_o + seq_len(n_d)], D, K_d + pars[n_i + n_s + n_o + seq_len(n_d)], D, K_omega ) out <- forward_mnhmm_multichannel( - eta_pi, X_i, - eta_A, X_s, - eta_B, X_o, - eta_omega, X_d, + eta_pi, X_pi, + eta_A, X_A, + eta_B, X_B, + eta_omega, X_omega, obs, M) - sum(apply(out[, T_, ], 2, logSumExp)) / n_obs @@ -220,7 +212,7 @@ fit_mnhmm <- function(model, inits, init_sd, restarts, dots$control_restart$ftol_rel <- dots$ftol_rel out <- future.apply::future_lapply(seq_len(restarts), function(i) { init <- unlist(create_initial_values( - inits, S, M, init_sd, K_i, K_s, K_o, K_d, D + inits, S, M, init_sd, K_pi, K_A, K_B, K_omega, D )) nloptr( x0 = init, eval_f = objectivef, @@ -229,7 +221,7 @@ fit_mnhmm <- function(model, inits, init_sd, restarts, }, future.seed = TRUE) - logliks <- -unlist(lapply(out, "[[", "objective")) + logliks <- -unlist(lapply(out, "[[", "objective")) * n_obs return_codes <- unlist(lapply(out, "[[", "status")) successful <- which(return_codes > 0) optimum <- successful[which.max(logliks[successful])] @@ -239,7 +231,7 @@ fit_mnhmm <- function(model, inits, init_sd, restarts, } } else { init <- unlist(create_initial_values( - inits, S, M, init_sd, K_i, K_s, K_o, K_d, D + inits, S, M, init_sd, K_pi, K_A, K_B, K_omega, D )) } out <- nloptr( @@ -252,34 +244,34 @@ fit_mnhmm <- function(model, inits, init_sd, restarts, } pars <- out$solution model$etas$pi <- create_eta_pi_mnhmm( - pars[seq_len(n_i)], S, K_i, D + pars[seq_len(n_i)], S, K_pi, D ) model$gammas$pi <- c(eta_to_gamma_mat_field( model$etas$pi )) model$etas$A <- create_eta_A_mnhmm( - pars[n_i + seq_len(n_s)], S, K_s, D + pars[n_i + seq_len(n_s)], S, K_A, D ) model$gammas$A <- c(eta_to_gamma_cube_field( model$etas$A )) if (C == 1L) { model$etas$B <- create_eta_B_mnhmm( - pars[n_i + n_s + seq_len(n_o)], S, M, K_o, D + pars[n_i + n_s + seq_len(n_o)], S, M, K_B, D ) model$gammas$B <- c(eta_to_gamma_cube_field( model$etas$B )) } else { model$etas$B <- create_eta_multichannel_B_mnhmm( - pars[n_i + n_s + seq_len(n_o)], S, M, K_o, D + pars[n_i + n_s + seq_len(n_o)], S, M, K_B, D ) l <- lengths(model$etas$B) gamma_B <- c(eta_to_gamma_cube_field(unlist(model$etas$B, recursive = FALSE))) model$gammas$B <- split(gamma_B, rep(seq_along(l), l)) } model$etas$omega <- create_eta_omega_mnhmm( - pars[n_i + n_s + n_o + seq_len(n_d)], D, K_d + pars[n_i + n_s + n_o + seq_len(n_d)], D, K_omega ) model$gammas$omega <- eta_to_gamma_mat( model$etas$omega diff --git a/R/fit_model.R b/R/fit_model.R index 93206dda..daf41fdc 100644 --- a/R/fit_model.R +++ b/R/fit_model.R @@ -16,7 +16,7 @@ #' [nloptr()] (possibly after the EM and/or global steps). The default is `FALSE`. #' @param control_em Optional list of control parameters for the EM algorithm. #' Possible arguments are -#' * The maximum number of iterations, the default is 1000. Note that iteration +#' * `maxeval`\cr The maximum number of iterations, the default is 1000. Note that iteration #' counter starts with -1 so with `maxeval = 1` you get already two iterations. #' This is for backward compatibility reasons. #' * `print_level`\cr The level of printing. Possible values are 0 diff --git a/R/fit_nhmm.R b/R/fit_nhmm.R index e3c48df5..843630fc 100644 --- a/R/fit_nhmm.R +++ b/R/fit_nhmm.R @@ -29,37 +29,37 @@ fit_nhmm <- function(model, inits, init_sd, restarts, save_all_solutions = FALSE n_i <- attr(model, "np_pi") n_s <- attr(model, "np_A") n_o <- attr(model, "np_B") - iv_pi <- attr(model$X_initial, "iv") - iv_A <- attr(model$X_transition, "iv") - iv_B <- attr(model$X_emission, "iv") - tv_A <- attr(model$X_transition, "tv") - tv_B <- attr(model$X_emission, "tv") - X_i <- model$X_initial - X_s <- model$X_transition - X_o <- model$X_emission - K_i <- nrow(X_i) - K_s <- nrow(X_s) - K_o <- nrow(X_o) + iv_pi <- attr(model$X_pi, "iv") + iv_A <- attr(model$X_A, "iv") + iv_B <- attr(model$X_B, "iv") + tv_A <- attr(model$X_A, "tv") + tv_B <- attr(model$X_B, "tv") + X_pi <- model$X_pi + X_A <- model$X_A + X_B <- model$X_B + K_pi <- nrow(X_pi) + K_A <- nrow(X_A) + K_B <- nrow(X_B) Ti <- model$sequence_lengths n_obs <- nobs(model) dots <- list(...) if (isTRUE(dots$maxeval < 0)) { pars <- unlist(create_initial_values( - inits, S, M, init_sd, K_i, K_s, K_o + inits, S, M, init_sd, K_pi, K_A, K_B )) - model$etas$pi <- create_eta_pi_nhmm(pars[seq_len(n_i)], S, K_i) + model$etas$pi <- create_eta_pi_nhmm(pars[seq_len(n_i)], S, K_pi) model$gammas$pi <- eta_to_gamma_mat(model$etas$pi) - model$etas$A <- create_eta_A_nhmm(pars[n_i + seq_len(n_s)], S, K_s) + model$etas$A <- create_eta_A_nhmm(pars[n_i + seq_len(n_s)], S, K_A) model$gammas$A <- eta_to_gamma_cube(model$etas$A) if (C == 1L) { model$etas$B <- create_eta_B_nhmm( - pars[n_i + n_s + seq_len(n_o)], S, M, K_o + pars[n_i + n_s + seq_len(n_o)], S, M, K_B ) model$gammas$B <- eta_to_gamma_cube(model$etas$B) } else { model$etas$B <- create_eta_multichannel_B_nhmm( - pars[n_i + n_s + seq_len(n_o)], S, M, K_o + pars[n_i + n_s + seq_len(n_o)], S, M, K_B ) model$gammas$B <- eta_to_gamma_cube_field(model$etas$B) } @@ -84,17 +84,15 @@ fit_nhmm <- function(model, inits, init_sd, restarts, save_all_solutions = FALSE dots$check_derivatives <- FALSE if (C == 1L) { - Qs <- t(create_Q(S)) - Qm <- t(create_Q(M)) if (need_grad) { objectivef <- function(pars) { - eta_pi <- create_eta_pi_nhmm(pars[seq_len(n_i)], S, K_i) - eta_A <- create_eta_A_nhmm(pars[n_i + seq_len(n_s)], S, K_s) + eta_pi <- create_eta_pi_nhmm(pars[seq_len(n_i)], S, K_pi) + eta_A <- create_eta_A_nhmm(pars[n_i + seq_len(n_s)], S, K_A) eta_B <- create_eta_B_nhmm( - pars[n_i + n_s + seq_len(n_o)], S, M, K_o + pars[n_i + n_s + seq_len(n_o)], S, M, K_B ) out <- log_objective_nhmm_singlechannel( - Qs, Qm, eta_pi, X_i, eta_A, X_s, eta_B, X_o, obs, + eta_pi, X_pi, eta_A, X_A, eta_B, X_B, obs, iv_pi, iv_A, iv_B, tv_A, tv_B, Ti ) list( @@ -104,29 +102,27 @@ fit_nhmm <- function(model, inits, init_sd, restarts, save_all_solutions = FALSE } } else { objectivef <- function(pars) { - eta_pi <- create_eta_pi_nhmm(pars[seq_len(n_i)], S, K_i) - eta_A <- create_eta_A_nhmm(pars[n_i + seq_len(n_s)], S, K_s) + eta_pi <- create_eta_pi_nhmm(pars[seq_len(n_i)], S, K_pi) + eta_A <- create_eta_A_nhmm(pars[n_i + seq_len(n_s)], S, K_A) eta_B <- create_eta_B_nhmm( - pars[n_i + n_s + seq_len(n_o)], S, M, K_o + pars[n_i + n_s + seq_len(n_o)], S, M, K_B ) out <- forward_nhmm_singlechannel( - eta_pi, X_i, eta_A, X_s, eta_B, X_o, obs + eta_pi, X_pi, eta_A, X_A, eta_B, X_B, obs ) - sum(apply(out[, T_, ], 2, logSumExp)) / n_obs } } } else { - Qs <- t(create_Q(S)) - Qm <- lapply(M, function(m) t(create_Q(m))) if (need_grad) { objectivef <- function(pars) { - eta_pi <- create_eta_pi_nhmm(pars[seq_len(n_i)], S, K_i) - eta_A <- create_eta_A_nhmm(pars[n_i + seq_len(n_s)], S, K_s) + eta_pi <- create_eta_pi_nhmm(pars[seq_len(n_i)], S, K_pi) + eta_A <- create_eta_A_nhmm(pars[n_i + seq_len(n_s)], S, K_A) eta_B <- create_eta_multichannel_B_nhmm( - pars[n_i + n_s + seq_len(n_o)], S, M, K_o + pars[n_i + n_s + seq_len(n_o)], S, M, K_B ) out <- log_objective_nhmm_multichannel( - Qs, Qm, eta_pi, X_i, eta_A, X_s, eta_B, X_o, obs, M, + eta_pi, X_pi, eta_A, X_A, eta_B, X_B, obs, iv_pi, iv_A, iv_B, tv_A, tv_B, Ti ) list( @@ -136,13 +132,13 @@ fit_nhmm <- function(model, inits, init_sd, restarts, save_all_solutions = FALSE } } else { objectivef <- function(pars) { - eta_pi <- create_eta_pi_nhmm(pars[seq_len(n_i)], S, K_i) - eta_A <- create_eta_A_nhmm(pars[n_i + seq_len(n_s)], S, K_s) + eta_pi <- create_eta_pi_nhmm(pars[seq_len(n_i)], S, K_pi) + eta_A <- create_eta_A_nhmm(pars[n_i + seq_len(n_s)], S, K_A) eta_B <- create_eta_multichannel_B_nhmm( - pars[n_i + n_s + seq_len(n_o)], S, M, K_o + pars[n_i + n_s + seq_len(n_o)], S, M, K_B ) out <- forward_nhmm_multichannel( - eta_pi, X_i, eta_A, X_s, eta_B, X_o, obs, M + eta_pi, X_pi, eta_A, X_A, eta_B, X_B, obs ) - sum(apply(out[, T_, ], 2, logSumExp)) / n_obs } @@ -167,7 +163,7 @@ fit_nhmm <- function(model, inits, init_sd, restarts, save_all_solutions = FALSE out <- future.apply::future_lapply(seq_len(restarts), function(i) { init <- unlist(create_initial_values( - inits, S, M, init_sd, K_i, K_s, K_o + inits, S, M, init_sd, K_pi, K_A, K_B )) nloptr( x0 = init, eval_f = objectivef, @@ -186,7 +182,7 @@ fit_nhmm <- function(model, inits, init_sd, restarts, save_all_solutions = FALSE } } else { init <- unlist(create_initial_values( - inits, S, M, init_sd, K_i, K_s, K_o + inits, S, M, init_sd, K_pi, K_A, K_B )) } @@ -199,18 +195,18 @@ fit_nhmm <- function(model, inits, init_sd, restarts, save_all_solutions = FALSE warning_(paste("Optimization terminated due to error:", out$message)) } pars <- out$solution - model$etas$pi <- create_eta_pi_nhmm(pars[seq_len(n_i)], S, K_i) + model$etas$pi <- create_eta_pi_nhmm(pars[seq_len(n_i)], S, K_pi) model$gammas$pi <- eta_to_gamma_mat(model$etas$pi) - model$etas$A <- create_eta_A_nhmm(pars[n_i + seq_len(n_s)], S, K_s) + model$etas$A <- create_eta_A_nhmm(pars[n_i + seq_len(n_s)], S, K_A) model$gammas$A <- eta_to_gamma_cube(model$etas$A) if (C == 1L) { model$etas$B <- create_eta_B_nhmm( - pars[n_i + n_s + seq_len(n_o)], S, M, K_o + pars[n_i + n_s + seq_len(n_o)], S, M, K_B ) model$gammas$B <- eta_to_gamma_cube(model$etas$B) } else { model$etas$B <- create_eta_multichannel_B_nhmm( - pars[n_i + n_s + seq_len(n_o)], S, M, K_o + pars[n_i + n_s + seq_len(n_o)], S, M, K_B ) model$gammas$B <- eta_to_gamma_cube_field(model$etas$B) } diff --git a/R/forwardBackward.R b/R/forwardBackward.R index 957a11a7..f896ab1e 100644 --- a/R/forwardBackward.R +++ b/R/forwardBackward.R @@ -154,15 +154,22 @@ forward_backward.nhmm <- function(model, forward_only = FALSE, out <- list() if (model$n_channels == 1) { out$forward_probs <- forward_nhmm_singlechannel( - model$etas$pi, model$X_initial, - model$etas$A, model$X_transition, - model$etas$B, model$X_emission, - array(obsArray[1, , ], dim(obsArray)[2:3])) + model$etas$pi, model$X_pi, + model$etas$A, model$X_A, + model$etas$B, model$X_B, + array(obsArray[1, , ], dim(obsArray)[2:3]), + model$sequence_lengths, attr(model$X_pi, "iv"), + attr(model$X_A, "iv"), attr(model$X_B, "iv"), attr(model$X_A, "tv"), + attr(model$X_B, "tv")) if (!forward_only) { out$backward_probs <- backward_nhmm_singlechannel( - model$etas$A, model$X_transition, - model$etas$B, model$X_emission, - array(obsArray[1, , ], dim(obsArray)[2:3])) + model$etas$pi, model$X_pi, + model$etas$A, model$X_A, + model$etas$B, model$X_B, + array(obsArray[1, , ], dim(obsArray)[2:3]), + model$sequence_lengths, attr(model$X_pi, "iv"), + attr(model$X_A, "iv"), attr(model$X_B, "iv"), attr(model$X_A, "tv"), + attr(model$X_B, "tv")) } if (is.null(time_names <- colnames(model$observations))) { time_names <- seq_len(model$length_of_sequences) @@ -172,15 +179,21 @@ forward_backward.nhmm <- function(model, forward_only = FALSE, } } else { out$forward_probs <- forward_nhmm_multichannel( - model$etas$pi, model$X_initial, - model$etas$A, model$X_transition, - model$etas$B, model$X_emission, - obsArray, model$n_symbols) + model$etas$pi, model$X_pi, + model$etas$A, model$X_A, + model$etas$B, model$X_B, + obsArray, + model$sequence_lengths, attr(model$X_pi, "iv"), + attr(model$X_A, "iv"), attr(model$X_B, "iv"), attr(model$X_A, "tv"), + attr(model$X_B, "tv")) if (!forward_only) { out$backward_probs <- backward_nhmm_multichannel( - model$etas$A, model$X_transition, - model$etas$B, model$X_emission, - obsArray, model$n_symbols) + model$etas$pi, model$X_pi, + model$etas$A, model$X_A, + model$etas$B, model$X_B, + obsArray, model$sequence_lengths, attr(model$X_pi, "iv"), + attr(model$X_A, "iv"), attr(model$X_B, "iv"), attr(model$X_A, "tv"), + attr(model$X_B, "tv")) } if (is.null(time_names <- colnames(model$observations[[1]]))) { time_names <- seq_len(model$length_of_sequences) @@ -219,16 +232,24 @@ forward_backward.mnhmm <- function(model, forward_only = FALSE, out <- list() if (model$n_channels == 1) { out$forward_probs <- forward_mnhmm_singlechannel( - model$etas$pi, model$X_initial, - model$etas$A, model$X_transition, - model$etas$B, model$X_emission, - model$etas$omega, model$X_cluster, - array(obsArray, dim(obsArray)[2:3])) + model$etas$omega, model$X_omega, + model$etas$pi, model$X_pi, + model$etas$A, model$X_A, + model$etas$B, model$X_B, + array(obsArray, dim(obsArray)[2:3]), + model$sequence_lengths, attr(model$X_omega, "iv"), attr(model$X_pi, "iv"), + attr(model$X_A, "iv"), attr(model$X_B, "iv"), attr(model$X_A, "tv"), + attr(model$X_B, "tv")) if (!forward_only) { out$backward_probs <- backward_mnhmm_singlechannel( - model$etas$A, model$X_transition, - model$etas$B, model$X_emission, - array(obsArray, dim(obsArray)[2:3])) + model$etas$omega, model$X_omega, + model$etas$pi, model$X_pi, + model$etas$A, model$X_A, + model$etas$B, model$X_B, + array(obsArray, dim(obsArray)[2:3]), model$sequence_lengths, + attr(model$X_omega, "iv"), attr(model$X_pi, "iv"), + attr(model$X_A, "iv"), attr(model$X_B, "iv"), attr(model$X_A, "tv"), + attr(model$X_B, "tv")) } if (is.null(time_names <- colnames(model$observations))) { time_names <- seq_len(model$length_of_sequences) @@ -239,16 +260,24 @@ forward_backward.mnhmm <- function(model, forward_only = FALSE, } else { eta_B <- unlist(model$etas$B, recursive = FALSE) out$forward_probs <- forward_mnhmm_multichannel( - model$etas$pi, model$X_initial, - model$etas$A, model$X_transition, - eta_B, model$X_emission, - model$etas$omega, model$X_cluster, - obsArray, model$n_symbols) + model$etas$omega, model$X_omega, + model$etas$pi, model$X_pi, + model$etas$A, model$X_A, + eta_B, model$X_B, + obsArray, model$sequence_lengths, + attr(model$X_omega, "iv"), attr(model$X_pi, "iv"), + attr(model$X_A, "iv"), attr(model$X_B, "iv"), attr(model$X_A, "tv"), + attr(model$X_B, "tv")) if (!forward_only) { out$backward_probs <- backward_mnhmm_multichannel( - model$etas$A, model$X_transition, - eta_B, model$X_emission, - obsArray, model$n_symbols) + model$etas$omega, model$X_omega, + model$etas$pi, model$X_pi, + model$etas$A, model$X_A, + eta_B, model$X_B, + obsArray, model$sequence_lengths, + attr(model$X_omega, "iv"), attr(model$X_pi, "iv"), + attr(model$X_A, "iv"), attr(model$X_B, "iv"), attr(model$X_A, "tv"), + attr(model$X_B, "tv")) } if (is.null(time_names <- colnames(model$observations[[1]]))) { time_names <- seq_len(model$length_of_sequences) diff --git a/R/get_probs.R b/R/get_probs.R index e0f1d9a1..3b07a8b8 100644 --- a/R/get_probs.R +++ b/R/get_probs.R @@ -32,10 +32,10 @@ get_initial_probs.nhmm <- function(model, probs, ...) { } else { ids <- rownames(model$observations[[1]]) } - if (!attr(model$X_initial, "iv")) { - X <- model$X_initial[, 1L, drop = FALSE] + if (!attr(model$X_pi, "iv")) { + X <- model$X_pi[, 1L, drop = FALSE] } else { - X <- model$X_initial + X <- model$X_pi } d <- data.frame( id = rep(ids, each = model$n_states), @@ -94,7 +94,7 @@ get_initial_probs.mhmm <- function(model, ...) { get_transition_probs.nhmm <- function(model, probs, remove_voids = TRUE, ...) { S <- model$n_states T_ <- model$length_of_sequences - model$X_transition[attr(model$X_transition, "missing")] <- NA + model$X_A[attr(model$X_A, "missing")] <- NA if (model$n_channels == 1L) { ids <- rownames(model$observations) times <- colnames(model$observations) @@ -102,10 +102,10 @@ get_transition_probs.nhmm <- function(model, probs, remove_voids = TRUE, ...) { ids <- rownames(model$observations[[1]]) times <- colnames(model$observations[[1]]) } - if (!attr(model$X_transition, "iv")) { - X <- model$X_transition[, , 1L, drop = FALSE] + if (!attr(model$X_A, "iv")) { + X <- model$X_A[, , 1L, drop = FALSE] } else { - X <- model$X_transition + X <- model$X_A } d <- data.frame( id = rep(ids, each = S^2 * T_), @@ -113,7 +113,7 @@ get_transition_probs.nhmm <- function(model, probs, remove_voids = TRUE, ...) { state_from = model$state_names, state_to = rep(model$state_names, each = S), estimate = unlist(get_A_all( - model$gammas$A, X, attr(model$X_transition, "tv") + model$gammas$A, X, attr(model$X_A, "tv") )) ) d <- stats::setNames( @@ -133,7 +133,7 @@ get_transition_probs.nhmm <- function(model, probs, remove_voids = TRUE, ...) { ) qs <- get_A_qs( model$boot$gamma_A, - X, attr(model$X_transition, "tv"), probs + X, attr(model$X_A, "tv"), probs ) for(i in seq_along(probs)) { d[paste0("q", 100 * probs[i])] <- qs[, i] @@ -179,7 +179,7 @@ get_emission_probs.nhmm <- function(model, probs, remove_voids = TRUE, ...) { C <- model$n_channels T_ <- model$length_of_sequences M <- model$n_symbols - model$X_emission[attr(model$X_emission, "missing")] <- NA + model$X_B[attr(model$X_B, "missing")] <- NA if (C == 1L) { ids <- rownames(model$observations) times <- colnames(model$observations) @@ -190,10 +190,10 @@ get_emission_probs.nhmm <- function(model, probs, remove_voids = TRUE, ...) { times <- colnames(model$observations[[1]]) symbol_names <- model$symbol_names } - if (!attr(model$X_emission, "iv")) { - X <- model$X_emission[, , 1L, drop = FALSE] + if (!attr(model$X_B, "iv")) { + X <- model$X_B[, , 1L, drop = FALSE] } else { - X <- model$X_emission + X <- model$X_B } d <- do.call( rbind, @@ -205,7 +205,7 @@ get_emission_probs.nhmm <- function(model, probs, remove_voids = TRUE, ...) { channel = model$channel_names[i], observation = rep(symbol_names[[i]], each = S), estimate = unlist(get_B_all( - model$gammas$B[[i]], X, attr(model$X_emission, "tv") + model$gammas$B[[i]], X, attr(model$X_B, "tv") )) ) }) @@ -226,7 +226,7 @@ get_emission_probs.nhmm <- function(model, probs, remove_voids = TRUE, ...) { if (C == 1) { qs <- get_B_qs( model$boot$gamma_B, - X, attr(model$X_emission, "tv"), probs + X, attr(model$X_B, "tv"), probs ) } else { qs <- do.call( @@ -234,7 +234,7 @@ get_emission_probs.nhmm <- function(model, probs, remove_voids = TRUE, ...) { lapply(seq_len(C), function(i) { get_B_qs( lapply(model$boot$gamma_B, "[[", i), - X, attr(model$X_emission, "tv"), probs + X, attr(model$X_B, "tv"), probs ) }) ) @@ -284,10 +284,10 @@ get_cluster_probs.mnhmm <- function(model, probs, ...) { } else { ids <- rownames(model$observations[[1]]) } - if (!attr(model$X_cluster, "iv")) { - X <- model$X_cluster[, 1L, drop = FALSE] + if (!attr(model$X_omega, "iv")) { + X <- model$X_omega[, 1L, drop = FALSE] } else { - X <- model$X_cluster + X <- model$X_omega } d <- data.frame( cluster = model$cluster_names, diff --git a/R/hidden_paths.R b/R/hidden_paths.R index af774e14..f3887316 100644 --- a/R/hidden_paths.R +++ b/R/hidden_paths.R @@ -75,16 +75,22 @@ hidden_paths.nhmm <- function(model, respect_void = TRUE, ...) { obsArray <- create_obsArray(model) if (model$n_channels == 1) { out <- viterbi_nhmm_singlechannel( - model$etas$pi, model$X_initial, - model$etas$A, model$X_transition, - model$etas$B, model$X_emission, - obsArray[1, , ]) + model$etas$pi, model$X_pi, + model$etas$A, model$X_A, + model$etas$B, model$X_B, + obsArray[1, , ], model$sequence_lengths, + attr(model$X_pi, "iv"), + attr(model$X_A, "iv"), attr(model$X_B, "iv"), attr(model$X_A, "tv"), + attr(model$X_B, "tv")) } else { out <- viterbi_nhmm_multichannel( - model$etas$pi, model$X_initial, - model$etas$A, model$X_transition, - model$etas$B, model$X_emission, - obsArray, model$n_symbols) + model$etas$pi, model$X_pi, + model$etas$A, model$X_A, + model$etas$B, model$X_B, + obsArray, model$sequence_lengths, + attr(model$X_pi, "iv"), + attr(model$X_A, "iv"), attr(model$X_B, "iv"), attr(model$X_A, "tv"), + attr(model$X_B, "tv")) } create_mpp_seq(out, model, respect_void) } @@ -95,19 +101,28 @@ hidden_paths.mnhmm <- function(model, respect_void = TRUE, ...) { obsArray <- create_obsArray(model) if (model$n_channels == 1) { out <- viterbi_mnhmm_singlechannel( - model$etas$pi, model$X_initial, - model$etas$A, model$X_transition, - model$etas$B, model$X_emission, - model$etas$omega, model$X_cluster, - array(obsArray, dim(obsArray)[2:3])) + model$etas$omega, model$X_omega, + model$etas$pi, model$X_pi, + model$etas$A, model$X_A, + model$etas$B, model$X_B, + array(obsArray, dim(obsArray)[2:3]), model$sequence_lengths, + attr(model$X_omega, "iv"), attr(model$X_pi, "iv"), + attr(model$X_A, "iv"), attr(model$X_B, "iv"), attr(model$X_A, "tv"), + attr(model$X_B, "tv") + ) } else { + eta_B <- unlist(model$etas$B, recursive = FALSE) out <- viterbi_mnhmm_multichannel( - model$etas$pi, model$X_initial, - model$etas$A, model$X_transition, - unlist(model$etas$B, recursive = FALSE), - model$X_emission, - model$etas$omega, model$X_cluster, - obsArray, model$n_symbols) + model$etas$omega, model$X_omega, + model$etas$pi, model$X_pi, + model$etas$A, model$X_A, + eta_B, + model$X_B, + obsArray, model$sequence_lengths, + attr(model$X_omega, "iv"), attr(model$X_pi, "iv"), + attr(model$X_A, "iv"), attr(model$X_B, "iv"), attr(model$X_A, "tv"), + attr(model$X_B, "tv") + ) } if (identical(model$state_names[[1]], model$state_names[[2]])) { model$state_names <- paste0( diff --git a/R/model_matrix.R b/R/model_matrix.R index 6a158065..a8857363 100644 --- a/R/model_matrix.R +++ b/R/model_matrix.R @@ -39,7 +39,8 @@ model_matrix_initial_formula <- function(formula, data, n_sequences, data = data, na.action = stats::na.pass ) - cols <- which(colnames(X) != "(Intercept)") + coef_names <- colnames(X) + cols <- which(coef_names != "(Intercept)") if (missing(X_mean)) { X_mean <- X_sd <- TRUE } @@ -61,7 +62,6 @@ model_matrix_initial_formula <- function(formula, data, n_sequences, ) ) iv <- nrow(unique(X)) > 1L - coef_names <- colnames(X) n_pars <- (n_states - 1L) * ncol(X) } X <- t(X) @@ -93,7 +93,8 @@ model_matrix_transition_formula <- function(formula, data, n_sequences, data = data, na.action = stats::na.pass ) - cols <- which(colnames(X) != "(Intercept)") + coef_names <- colnames(X) + cols <- which(coef_names != "(Intercept)") if (missing(X_mean)) { X_mean <- X_sd <- TRUE } @@ -122,7 +123,6 @@ model_matrix_transition_formula <- function(formula, data, n_sequences, ) ) } - coef_names <- colnames(X) dim(X) <- c(length_of_sequences, n_sequences, ncol(X)) n_pars <- n_states * (n_states - 1L) * dim(X)[3] iv <- iv_X(X) @@ -163,7 +163,8 @@ model_matrix_emission_formula <- function(formula, data, n_sequences, data = data, na.action = stats::na.pass ) - cols <- which(colnames(X) != "(Intercept)") + coef_names <- colnames(X) + cols <- which(coef_names != "(Intercept)") if (missing(X_mean)) { X_mean <- X_sd <- TRUE } @@ -194,7 +195,7 @@ model_matrix_emission_formula <- function(formula, data, n_sequences, ) ) } - coef_names <- colnames(X) + dim(X) <- c(length_of_sequences, n_sequences, ncol(X)) n_pars <- sum(n_states * (n_symbols - 1L) * dim(X)[3]) iv <- iv_X(X) @@ -232,7 +233,8 @@ model_matrix_cluster_formula <- function(formula, data, n_sequences, n_clusters, data = data[data[[time]] == first_time_point, ], na.action = stats::na.pass ) - cols <- which(colnames(X) != "(Intercept)") #always first column(?) + coef_names <- colnames(X) + cols <- which(coef_names != "(Intercept)") if (missing(X_mean)) { X_mean <- X_sd <- TRUE } @@ -254,7 +256,6 @@ model_matrix_cluster_formula <- function(formula, data, n_sequences, n_clusters, ) ) iv <- nrow(unique(X)) > 1L - coef_names <- colnames(X) n_pars <- (n_clusters - 1L) * ncol(X) } X <- t(X) diff --git a/R/print.R b/R/print.R index 26c019c8..4c166237 100644 --- a/R/print.R +++ b/R/print.R @@ -25,7 +25,7 @@ print.hmm <- function(x, digits = 3, ...) { cat("\nNumber of sequences:", x$n_sequences) cat("\nNumber of time points:", x$length_of_sequences) cat("\nNumber of observed symbols:", paste(x$n_symbols, collapse = ", ")) - cat("\nNumber of hidden states:", x$n_states) + cat("\nNumber of hidden states:", x$n_states, "\n") print.listof(list( "Initial probabilities" = x$initial_probs, "Transition probabilities" = x$transition_probs, @@ -38,7 +38,7 @@ print.hmm <- function(x, digits = 3, ...) { cat("\nNumber of time points:", x$length_of_sequences) cat("\nNumber of observation channels:", x$n_channels) cat("\nNumber of observed symbols:", paste(x$n_symbols, collapse = ", ")) - cat("\nNumber of hidden states:", x$n_states) + cat("\nNumber of hidden states:", x$n_states, "\n") print.listof(list("Initial probabilities" = x$initial_probs), digits = digits, ...) cat("\n") print.listof(list("Transition probabilities" = x$transition_probs), digits = digits, ...) diff --git a/R/simulate_mnhmm.R b/R/simulate_mnhmm.R index f118f8c6..0306e3fe 100644 --- a/R/simulate_mnhmm.R +++ b/R/simulate_mnhmm.R @@ -78,8 +78,8 @@ simulate_mnhmm <- function( if (is.null(coefs$cluster_probs)) coefs$cluster_probs <- NULL } model$etas <- create_initial_values( - coefs, model$n_states, model$n_symbols, init_sd, nrow(model$X_initial), - nrow(model$X_transition), nrow(model$X_emission), nrow(model$X_cluster), + coefs, model$n_states, model$n_symbols, init_sd, nrow(model$X_pi), + nrow(model$X_A), nrow(model$X_B), nrow(model$X_omega), n_clusters ) model$gammas$pi <- c(eta_to_gamma_mat_field( @@ -104,17 +104,18 @@ simulate_mnhmm <- function( T_ <- model$length_of_sequences if (n_channels == 1L) { out <- simulate_mnhmm_singlechannel( - model$etas$pi, model$X_initial, - model$etas$A, model$X_transition, - model$etas$B, model$X_emission, - model$etas$omega, model$X_cluster + model$etas$pi, model$X_pi, + model$etas$A, model$X_A, + model$etas$B, model$X_B, + model$etas$omega, model$X_omega ) } else { + eta_B <- unlist(model$etas$B, recursive = FALSE) out <- simulate_mnhmm_multichannel( - model$etas$pi, model$X_initial, - model$etas$A, model$X_transition, - unlist(model$etas$B, recursive = FALSE), model$X_emission, - model$etas$omega, model$X_cluster, + model$etas$pi, model$X_pi, + model$etas$A, model$X_A, + eta_B, model$X_B, + model$etas$omega, model$X_omega, model$n_symbols ) } diff --git a/R/simulate_nhmm.R b/R/simulate_nhmm.R index fe0e8b0a..c87aa2f1 100644 --- a/R/simulate_nhmm.R +++ b/R/simulate_nhmm.R @@ -70,8 +70,8 @@ simulate_nhmm <- function( if (is.null(coefs$emission_probs)) coefs$emission_probs <- NULL } model$etas <- create_initial_values( - coefs, model$n_states, model$n_symbols, init_sd, nrow(model$X_initial), - nrow(model$X_transition), nrow(model$X_emission) + coefs, model$n_states, model$n_symbols, init_sd, nrow(model$X_pi), + nrow(model$X_A), nrow(model$X_B) ) model$gammas$pi <- eta_to_gamma_mat(model$etas$pi) model$gammas$A <- eta_to_gamma_cube(model$etas$A) @@ -82,15 +82,15 @@ simulate_nhmm <- function( } if (n_channels == 1L) { out <- simulate_nhmm_singlechannel( - model$etas$pi, model$X_initial, - model$etas$A, model$X_transition, - model$etas$B, model$X_emission + model$etas$pi, model$X_pi, + model$etas$A, model$X_A, + model$etas$B, model$X_B ) } else { out <- simulate_nhmm_multichannel( - model$etas$pi, model$X_initial, - model$etas$A, model$X_transition, - model$etas$B, model$X_emission, + model$etas$pi, model$X_pi, + model$etas$A, model$X_A, + model$etas$B, model$X_B, model$n_symbols ) } diff --git a/R/summary.nhmm.R b/R/summary.nhmm.R index 04f8c20f..cd8a5482 100644 --- a/R/summary.nhmm.R +++ b/R/summary.nhmm.R @@ -22,7 +22,7 @@ summary.nhmm <- function(object, ...) { #' @param object Non-homogeneous hidden Markov model of class `mnhmm`. summary.mnhmm <- function(object, ...) { cf <- coef(object) - pr <- exp(object$X_cluster %*% object$gammas$omega) + pr <- exp(object$X_omega %*% object$gammas$omega) prior_cluster_probabilities <- pr / rowSums(pr) pcp <- posterior_cluster_probabilities(object) mpc <- factor( diff --git a/R/update.R b/R/update.R index 81423592..8280133d 100644 --- a/R/update.R +++ b/R/update.R @@ -10,24 +10,24 @@ update.nhmm <- function(object, newdata, ...) { newdata <- .check_data(newdata, object$time_variable, object$id_variable) if (!is.null(object$data)) object$data <- newdata - object$X_initial <- model_matrix_initial_formula( + object$X_pi <- model_matrix_initial_formula( object$initial_formula, newdata, object$n_sequences, object$length_of_sequences, object$n_states, object$time_variable, object$id_variable, - attr(object$X_initial, "X_mean"), attr(object$X_initial, "X_sd") + attr(object$X_pi, "X_mean"), attr(object$X_pi, "X_sd") ) - object$X_transition <- model_matrix_transition_formula( + object$X_A <- model_matrix_transition_formula( object$transition_formula, newdata, object$n_sequences, object$length_of_sequences, object$n_states, object$time_variable, object$id_variable, object$sequence_lengths, - attr(object$X_transition, "X_mean"), attr(object$X_transition, "X_sd") + attr(object$X_A, "X_mean"), attr(object$X_A, "X_sd") ) - object$X_emission <- model_matrix_emission_formula( + object$X_B <- model_matrix_emission_formula( object$emission_formula, newdata, object$n_sequences, object$length_of_sequences, object$n_states, object$n_symbols, object$n_channels, object$time_variable, object$id_variable, object$sequence_lengths, - attr(object$X_emission, "X_mean"), attr(object$X_emission, "X_sd") + attr(object$X_B, "X_mean"), attr(object$X_B, "X_sd") ) object } @@ -36,29 +36,29 @@ update.nhmm <- function(object, newdata, ...) { update.mnhmm <- function(object, newdata, ...) { newdata <- .check_data(newdata, object$time_variable, object$id_variable) if (!is.null(object$data)) object$data <- newdata - object$X_initial <- model_matrix_initial_formula( + object$X_pi <- model_matrix_initial_formula( object$initial_formula, newdata, object$n_sequences, object$length_of_sequences, object$n_states, object$time_variable, object$id_variable, - attr(object$X_initial, "X_mean"), attr(object$X_initial, "X_sd") + attr(object$X_pi, "X_mean"), attr(object$X_pi, "X_sd") ) - object$X_transition <- model_matrix_transition_formula( + object$X_A <- model_matrix_transition_formula( object$transition_formula, newdata, object$n_sequences, object$length_of_sequences, object$n_states, object$time_variable, object$id_variable, object$sequence_lengths, - attr(object$X_transition, "X_mean"), attr(object$X_transition, "X_sd") + attr(object$X_A, "X_mean"), attr(object$X_A, "X_sd") ) - object$X_emission <- model_matrix_emission_formula( + object$X_B <- model_matrix_emission_formula( object$emission_formula, newdata, object$n_sequences, object$length_of_sequences, object$n_states, object$n_symbols, object$n_channels, object$time_variable, object$id_variable, object$sequence_lengths, - attr(object$X_emission, "X_mean"), attr(object$X_emission, "X_sd") + attr(object$X_B, "X_mean"), attr(object$X_B, "X_sd") ) - object$X_cluster <- model_matrix_cluster_formula( + object$X_omega <- model_matrix_cluster_formula( object$cluster_formula, newdata, object$n_sequences, object$n_clusters, object$time_variable, object$id_variable, - attr(object$X_cluster, "X_mean"), attr(object$X_cluster, "X_sd") + attr(object$X_omega, "X_mean"), attr(object$X_omega, "X_sd") ) object -} \ No newline at end of file +} diff --git a/manual/seqHMM.Rnw b/manual/seqHMM.Rnw index 1df36532..93b629cf 100644 --- a/manual/seqHMM.Rnw +++ b/manual/seqHMM.Rnw @@ -431,7 +431,7 @@ Next we will test the performance of the MLSL optimization by setting \texttt{gl <<'fitHMM_global', cache=TRUE>>= mc_fit_global <- fit_model(mc_hmm, em_step = FALSE, - global = TRUE, local = TRUE, threads = 4, + global = TRUE, local = TRUE, threads = 2, control_global = list(maxtime = 0, maxeval = 10000)) -mc_fit_global$global_results$objective diff --git a/src/EM.cpp b/src/EM.cpp index eb27e832..36d9bd1e 100644 --- a/src/EM.cpp +++ b/src/EM.cpp @@ -6,7 +6,7 @@ Rcpp::List EM(const arma::mat& transition_, const arma::cube& emission_, const arma::vec& init_, const arma::ucube& obs, const arma::uvec& nSymbols, int itermax, double tol, - int trace, unsigned int threads) { + int trace, arma::uword threads) { // Make sure we don't alter the original vec/mat/cube // needed for cube, in future maybe in other cases as well @@ -29,11 +29,11 @@ Rcpp::List EM(const arma::mat& transition_, const arma::cube& emission_, const a sumlogLik_new = 0; double max_sf = 1; - unsigned int error_code = 0; + arma::uword error_code = 0; #pragma omp parallel for if(obs.n_slices>=threads) schedule(static) reduction(+:sumlogLik_new) num_threads(threads) \ default(shared) // gcc9 needs sharing of zeros, but doesn't work on earlier compilers..shared(init, transition, obs, emission, delta, ksii, gamma, nSymbols, error_code, max_sf, arma::fill::zeros) - for (unsigned int k = 0; k < obs.n_slices; k++) { + for (arma::uword k = 0; k < obs.n_slices; k++) { if (error_code == 0) { arma::mat alpha(emission.n_rows, obs.n_cols); //m,n,k @@ -50,12 +50,12 @@ Rcpp::List EM(const arma::mat& transition_, const arma::cube& emission_, const a delta_k = alpha.col(0) % beta.col(0) / scales(0); if (obs.n_cols > 1) { - for (unsigned int j = 0; j < emission.n_rows; j++) { - for (unsigned int i = 0; i < emission.n_rows; i++) { + for (arma::uword j = 0; j < emission.n_rows; j++) { + for (arma::uword i = 0; i < emission.n_rows; i++) { if (transition(i, j) > 0.0) { - for (unsigned int t = 0; t < (obs.n_cols - 1); t++) { + for (arma::uword t = 0; t < (obs.n_cols - 1); t++) { double tmp = alpha(i, t) * transition(i, j) * beta(j, t + 1); - for (unsigned int r = 0; r < obs.n_rows; r++) { + for (arma::uword r = 0; r < obs.n_rows; r++) { tmp *= emission(j, obs(r, t + 1, k), r); } ksii_k(i, j) += tmp; @@ -65,11 +65,11 @@ Rcpp::List EM(const arma::mat& transition_, const arma::cube& emission_, const a } } } - for (unsigned int r = 0; r < emission.n_slices; r++) { - for (unsigned int l = 0; l < nSymbols(r); l++) { - for (unsigned int i = 0; i < emission.n_rows; i++) { + for (arma::uword r = 0; r < emission.n_slices; r++) { + for (arma::uword l = 0; l < nSymbols(r); l++) { + for (arma::uword i = 0; i < emission.n_rows; i++) { if (emission(i, l, r) > 0.0) { - for (unsigned int t = 0; t < obs.n_cols; t++) { + for (arma::uword t = 0; t < obs.n_cols; t++) { if (l == (obs(r, t, k))) { gamma_k(i, l, r) += alpha(i, t) * beta(i, t) / scales(t); } @@ -120,7 +120,7 @@ Rcpp::List EM(const arma::mat& transition_, const arma::cube& emission_, const a if (change > tol) { if (obs.n_cols > 1) { arma::vec rsums = sum(ksii, 1); - for (unsigned int kk = 0; kk < ksii.n_rows; kk++) { + for (arma::uword kk = 0; kk < ksii.n_rows; kk++) { if (rsums(kk) == 0) { rsums(kk) = 1; } @@ -128,7 +128,7 @@ Rcpp::List EM(const arma::mat& transition_, const arma::cube& emission_, const a ksii.each_col() /= rsums; transition = ksii; } - for (unsigned int r = 0; r < emission.n_slices; r++) { + for (arma::uword r = 0; r < emission.n_slices; r++) { gamma.slice(r).cols(0, nSymbols(r) - 1).each_col() /= sum( gamma.slice(r).cols(0, nSymbols(r) - 1), 1); emission.slice(r).cols(0, nSymbols(r) - 1) = gamma.slice(r).cols(0, nSymbols(r) - 1); diff --git a/src/EM2.cpp b/src/EM2.cpp new file mode 100644 index 00000000..18cf0d5f --- /dev/null +++ b/src/EM2.cpp @@ -0,0 +1,232 @@ +// // EM algorithm for HMMs, used for initial fit of NHMMs +// +// #include "eta_to_gamma.h" +// #include "softmax.h" +// #include "forward_nhmm.h" +// #include "backward_nhmm.h" +// +// // [[Rcpp::export]] +// Rcpp::List EM_nhmm_singlechannel( +// arma::mat& eta_pi, const arma::mat& X_pi, +// arma::cube& eta_A, const arma::cube& X_A, +// arma::cube& eta_B, const arma::cube& X_B, +// const arma::umat& obs, const bool iv_pi, const bool iv_A, const bool iv_B, +// const bool tv_A, const bool tv_B, const arma::uvec& Ti, +// arma::uword maxeval, double ftol_abs, double ftol_rel) { +// +// nhmm_sc model( +// eta_A.n_slices, X_pi, X_A, X_B, Ti, +// iv_pi, iv_A, iv_B, tv_A, tv_B, obs, eta_pi, eta_A, eta_B +// ); +// +// // EM-algorithm begins +// +// double relative_change = ftol_rel + 1.0; +// double absolute_change = ftol_abs + 1.0; +// arma::uword iter = 0; +// double ll_new = 0; +// double ll = -1e150; +// // initial values to probabilities +// arma::vec log_Pi = arma::log(softmax(eta_to_gamma(eta_pi))); +// arma::mat log_A(S, S); +// arma::mat log_B(S, M + 1); +// log_B.col(M).zeros(); +// arma::cube gamma_A = eta_to_gamma(eta_A); +// arma::cube gamma_B = eta_to_gamma(eta_B); +// for (arma::uword s = 0; s < S; s++) { +// log_A.row(s) = arma::log((softmax(gamma_A.slice(s)).t())); +// log_B.row(s).cols(0, M - 1) = arma::log(softmax(gamma_B.slice(s)).t()); +// } +// arma::vec Pi(S); +// arma::mat A(S, S); +// arma::mat B(S, M); +// arma::mat log_alpha(S, T); +// arma::mat log_beta(S, T); +// arma::mat log_py(S, T); +// arma::vec tmp_T(T); +// while ((relative_change > ftol_rel) && (absolute_change > ftol_abs) && (iter < maxeval)) { +// iter++; +// ll_new = 0; +// Pi.zeros(); +// A.zeros(); +// B.zeros(); +// for (arma::uword i = 0; i < N; i++) { +// for (arma::uword t = 0; t < Ti(i); t++) { +// log_py.col(t) = log_B.col(obs(t, i)); +// } +// univariate_forward_nhmm(log_alpha, log_Pi, log_A, log_py.cols(0, Ti(i) - 1)); +// univariate_backward_nhmm(log_beta, log_A, log_py.cols(0, Ti(i) - 1)); +// double ll_i = logSumExp(log_alpha.col(Ti(i) - 1)); +// ll_new += ll_i; +// +// // update parameters even if already converged +// // Pi +// Pi += arma::exp(log_alpha.col(0) + log_beta.col(0) - ll_i); +// // A +// for (arma::uword j = 0; j < S; j++) { +// for (arma::uword k = 0; k < S; k++) { +// for (arma::uword t = 0; t < (Ti(i) - 1); t++) { +// tmp_T(t) = log_alpha(k, t) + log_A(k, j) + log_beta(j, t + 1) + log_py(j, t + 1); +// } +// A(k, j) += exp(logSumExp(tmp_T.rows(0, Ti(i) - 2) - ll_i)); +// } +// } +// // B +// for (arma::uword m = 0; m < M; m++) { +// for (arma::uword s = 0; s < S; s++) { +// tmp_T.fill(-arma::datum::inf); +// for (arma::uword t = 0; t < Ti(i); t++) { +// if (m == obs(t, i)) { +// tmp_T(t) = log_alpha(s, t) + log_beta(s, t); +// } +// } +// B(s, m) += exp(logSumExp(tmp_T.rows(0, Ti(i) - 1) - ll_i)); +// } +// } +// } +// log_Pi = arma::log(Pi / arma::accu(Pi)); +// A.each_col() /= sum(A, 1); +// log_A = arma::log(A); +// B.cols(0, M - 1).each_col() /= sum(B.cols(0, M - 1), 1); +// log_B.cols(0, M - 1) = arma::log(B.cols(0, M - 1)); +// +// relative_change = (ll_new - ll) / (std::abs(ll) + 1e-8); +// absolute_change = (ll_new - ll) / n_obs; +// ll = ll_new; +// } +// Pi = arma::exp(log_Pi); +// A = arma::exp(log_A); +// B = arma::exp(log_B); +// // Final log-likelihood +// ll_new = 0; +// for (arma::uword i = 0; i < N; i++) { +// for (arma::uword t = 0; t < Ti(i); t++) { +// log_py.col(t) = log_B.col(obs(t, i)); +// } +// univariate_forward_nhmm(log_alpha, log_Pi, log_A, log_py.cols(0, Ti(i) - 1)); +// ll_new += logSumExp(log_alpha.col(Ti(i) - 1)); +// } +// return Rcpp::List::create( +// Rcpp::Named("initial_probs") = Rcpp::wrap(Pi), +// Rcpp::Named("transition_probs") = Rcpp::wrap(A), +// Rcpp::Named("emission_probs") = Rcpp::wrap(B.cols(0, M - 1)), +// Rcpp::Named("logLik") = ll_new, +// Rcpp::Named("iterations") = iter, +// Rcpp::Named("relative_change") = relative_change, +// Rcpp::Named("absolute_change") = absolute_change +// ); +// } +// // // // [[Rcpp::export]] +// // // Rcpp::List EM_nhmm_multichannel( +// // // const arma::mat& eta_pi, const arma::cube& eta_A, +// // // const arma::field& eta_B, const arma::ucube& obs, +// // // const arma::uvec& M, const arma::uvec& Ti, arma::uword itermax, +// // // double tol) { +// // // +// // // arma::uword T = obs.n_rows; +// // // arma::uword N = obs.n_cols; +// // // arma::uword S = eta_A.n_slices; +// // // arma::uword C = M.n_elem; +// // // arma::uword maxM = arma::max(M); +// // // EM-algorithm begins +// // // +// // // double change = tol + 1.0; +// // // arma::uword iter = 0; +// // // double ll_new = 0; +// // // double ll = -1e150; +// // // // initial values to probabilities +// // // arma::vec log_Pi = arma::log(softmax(eta_to_gamma(eta_pi))); +// // // arma::mat log_A(S, S); +// // // arma::mat log_B(S, M + 1); +// // // log_B.col(M).zeros(); +// // // arma::cube gamma_A = eta_to_gamma(eta_A); +// // // arma::cube gamma_B = eta_to_gamma(eta_B); +// // // for (arma::uword s = 0; s < S; s++) { +// // // log_A.row(s) = arma::log((softmax(gamma_A.slice(s)).t())); +// // // log_B.row(s).cols(0, M - 1) = arma::log(softmax(gamma_B.slice(s)).t()); +// // // } +// // // arma::vec Pi(S); +// // // arma::mat A(S, S); +// // // arma::mat B(S, M); +// // // arma::mat log_alpha(S, T); +// // // arma::mat log_beta(S, T); +// // // arma::mat log_py(S, T); +// // // arma::vec tmp_T(T); +// // // // ll = 0; +// // // // for (arma::uword i = 0; i < N; i++) { +// // // // for (arma::uword t = 0; t < Ti(i); t++) { +// // // // log_py.col(t) = log_B.col(obs(t, i)); +// // // // } +// // // // univariate_forward_nhmm(log_alpha, log_Pi, log_A, log_py.cols(0, Ti(i) - 1)); +// // // // ll += logSumExp(log_alpha.col(Ti(i) - 1)); +// // // // } +// // // while ((change > tol) && (iter < itermax)) { +// // // iter++; +// // // ll_new = 0; +// // // Pi.zeros(); +// // // A.zeros(); +// // // B.zeros(); +// // // for (arma::uword i = 0; i < N; i++) { +// // // for (arma::uword t = 0; t < Ti(i); t++) { +// // // log_py.col(t) = log_B.col(obs(t, i)); +// // // } +// // // univariate_forward_nhmm(log_alpha, log_Pi, log_A, log_py.cols(0, Ti(i) - 1)); +// // // univariate_backward_nhmm(log_beta, log_A, log_py.cols(0, Ti(i) - 1)); +// // // double ll_i = logSumExp(log_alpha.col(Ti(i) - 1)); +// // // ll_new += ll_i; +// // // +// // // // Pi +// // // Pi += arma::exp(log_alpha.col(0) + log_beta.col(0) - ll_i); +// // // // A +// // // for (arma::uword j = 0; j < S; j++) { +// // // for (arma::uword k = 0; k < S; k++) { +// // // for (arma::uword t = 0; t < (Ti(i) - 1); t++) { +// // // tmp_T(t) = log_alpha(k, t) + log_A(k, j) + log_beta(j, t + 1) + log_py(j, t + 1); +// // // } +// // // A(k, j) += exp(logSumExp(tmp_T.rows(0, Ti(i) - 2) - ll_i)); +// // // } +// // // } +// // // // B +// // // for (arma::uword m = 0; m < M; m++) { +// // // for (arma::uword s = 0; s < S; s++) { +// // // tmp_T.fill(-arma::datum::inf); +// // // for (arma::uword t = 0; t < Ti(i); t++) { +// // // if (m == obs(t, i)) { +// // // tmp_T(t) = log_alpha(s, t) + log_beta(s, t); +// // // } +// // // } +// // // B(s, m) += exp(logSumExp(tmp_T.rows(0, Ti(i) - 1) - ll_i)); +// // // } +// // // } +// // // } +// // // log_Pi = arma::log(Pi / arma::accu(Pi)); +// // // A.each_col() /= sum(A, 1); +// // // log_A = arma::log(A); +// // // B.cols(0, M - 1).each_col() /= sum(B.cols(0, M - 1), 1); +// // // log_B.cols(0, M - 1) = arma::log(B.cols(0, M - 1)); +// // // // ll_new = 0; +// // // // for (arma::uword i = 0; i < N; i++) { +// // // // for (arma::uword t = 0; t < Ti(i); t++) { +// // // // log_py.col(t) = log_B.col(obs(t, i)); +// // // // } +// // // // univariate_forward_nhmm(log_alpha, log_Pi, log_A, log_py.cols(0, Ti(i) - 1)); +// // // // ll_new += logSumExp(log_alpha.col(Ti(i) - 1)); +// // // // } +// // // +// // // change = (ll_new - ll) / (std::abs(ll) + 0.1); +// // // ll = ll_new; +// // // } +// // // Pi = arma::exp(log_Pi); +// // // A = arma::exp(log_A); +// // // B = arma::exp(log_B); +// // // // should compute the final log-likelihood using these values, +// // // // but not interested in that here +// // // return Rcpp::List::create( +// // // Rcpp::Named("initial_probs") = Rcpp::wrap(Pi), +// // // Rcpp::Named("transition_probs") = Rcpp::wrap(A), +// // // Rcpp::Named("emission_probs") = Rcpp::wrap(B.cols(0, M - 1)), +// // // Rcpp::Named("logLik") = ll, +// // // Rcpp::Named("iterations") = iter, +// // // Rcpp::Named("change") = change +// // // ); +// // // } diff --git a/src/EMx.cpp b/src/EMx.cpp index 2d362395..bf388d0d 100644 --- a/src/EMx.cpp +++ b/src/EMx.cpp @@ -7,7 +7,7 @@ // [[Rcpp::export]] Rcpp::List EMx(const arma::mat& transition_, const arma::cube& emission_, const arma::vec& init_, const arma::ucube& obs, const arma::uvec& nSymbols, const arma::mat& coef_, const arma::mat& X, - const arma::uvec& numberOfStates, int itermax, double tol, int trace, unsigned int threads) { + const arma::uvec& numberOfStates, int itermax, double tol, int trace, arma::uword threads) { // Make sure we don't alter the original vec/mat/cube // needed for cube, in future maybe in other cases as well @@ -24,7 +24,7 @@ Rcpp::List EMx(const arma::mat& transition_, const arma::cube& emission_, const weights.each_row() /= sum(weights, 0); arma::mat initk(emission.n_rows, obs.n_slices); - for (unsigned int k = 0; k < obs.n_slices; k++) { + for (arma::uword k = 0; k < obs.n_slices; k++) { initk.col(k) = init % reparma(weights.col(k), numberOfStates); } @@ -48,11 +48,11 @@ Rcpp::List EMx(const arma::mat& transition_, const arma::cube& emission_, const arma::mat bsi(emission.n_rows, obs.n_slices); sumlogLik_new = 0; double max_sf = 1; - unsigned int error_code = 0; + arma::uword error_code = 0; #pragma omp parallel for if(obs.n_slices >= threads) schedule(static) reduction(+:sumlogLik_new) num_threads(threads) \ default(shared) //shared(bsi, initk, transition, obs, emission, delta, ksii, gamma, nSymbols, error_code, max_sf, arma::fill::zeros) - for (unsigned int k = 0; k < obs.n_slices; k++) { + for (arma::uword k = 0; k < obs.n_slices; k++) { if (error_code == 0) { arma::mat alpha(emission.n_rows, obs.n_cols); //m,n,k @@ -68,12 +68,12 @@ Rcpp::List EMx(const arma::mat& transition_, const arma::cube& emission_, const arma::vec delta_k(emission.n_rows); delta_k = alpha.col(0) % beta.col(0) / scales(0); - for (unsigned int i = 0; i < emission.n_rows; i++) { - for (unsigned int j = 0; j < emission.n_rows; j++) { + for (arma::uword i = 0; i < emission.n_rows; i++) { + for (arma::uword j = 0; j < emission.n_rows; j++) { if (transition(i, j) > 0.0) { - for (unsigned int t = 0; t < (obs.n_cols - 1); t++) { + for (arma::uword t = 0; t < (obs.n_cols - 1); t++) { double tmp = alpha(i, t) * transition(i, j) * beta(j, t + 1); - for (unsigned int r = 0; r < obs.n_rows; r++) { + for (arma::uword r = 0; r < obs.n_rows; r++) { tmp *= emission(j, obs(r, t + 1, k), r); } ksii_k(i, j) += tmp; @@ -81,11 +81,11 @@ Rcpp::List EMx(const arma::mat& transition_, const arma::cube& emission_, const } } } - for (unsigned int r = 0; r < emission.n_slices; r++) { - for (unsigned int l = 0; l < nSymbols(r); l++) { - for (unsigned int i = 0; i < emission.n_rows; i++) { + for (arma::uword r = 0; r < emission.n_slices; r++) { + for (arma::uword l = 0; l < nSymbols(r); l++) { + for (arma::uword i = 0; i < emission.n_rows; i++) { if (emission(i, l, r) > 0.0) { - for (unsigned int t = 0; t < obs.n_cols; t++) { + for (arma::uword t = 0; t < obs.n_cols; t++) { if (l == (obs(r, t, k))) { double tmp = alpha(i, t) * beta(i, t) / scales(t); gamma_k(i, l, r) += tmp; @@ -96,7 +96,7 @@ Rcpp::List EMx(const arma::mat& transition_, const arma::cube& emission_, const } } - for (unsigned int j = 0; j < emission.n_rows; j++) { + for (arma::uword j = 0; j < emission.n_rows; j++) { bsi(j, k) = beta(j, 0) * initk(j, k); } @@ -139,7 +139,7 @@ Rcpp::List EMx(const arma::mat& transition_, const arma::cube& emission_, const } } if (change > tol) { - unsigned int error = optCoef(weights, obs, emission, bsi, coef, X, cumsumstate, + arma::uword error = optCoef(weights, obs, emission, bsi, coef, X, cumsumstate, numberOfStates, trace); if (error != 0) { return Rcpp::List::create(Rcpp::Named("error") = error); @@ -147,7 +147,7 @@ Rcpp::List EMx(const arma::mat& transition_, const arma::cube& emission_, const if (obs.n_cols > 1) { arma::vec rsums = sum(ksii, 1); - for (unsigned int kk = 0; kk < ksii.n_rows; kk++) { + for (arma::uword kk = 0; kk < ksii.n_rows; kk++) { if (rsums(kk) == 0) { rsums(kk) = 1; } @@ -155,20 +155,20 @@ Rcpp::List EMx(const arma::mat& transition_, const arma::cube& emission_, const ksii.each_col() /= rsums; transition = ksii; } - for (unsigned int r = 0; r < emission.n_slices; r++) { + for (arma::uword r = 0; r < emission.n_slices; r++) { gamma.slice(r).cols(0, nSymbols(r) - 1).each_col() /= sum( gamma.slice(r).cols(0, nSymbols(r) - 1), 1); emission.slice(r).cols(0, nSymbols(r) - 1) = gamma.slice(r).cols(0, nSymbols(r) - 1); } - for (unsigned int i = 0; i < numberOfStates.n_elem; i++) { + for (arma::uword i = 0; i < numberOfStates.n_elem; i++) { delta.subvec(cumsumstate(i) - numberOfStates(i), cumsumstate(i) - 1) /= arma::as_scalar( arma::accu(delta.subvec(cumsumstate(i) - numberOfStates(i), cumsumstate(i) - 1))); } init = delta; - for (unsigned int k = 0; k < obs.n_slices; k++) { + for (arma::uword k = 0; k < obs.n_slices; k++) { initk.col(k) = init % reparma(weights.col(k), numberOfStates); } } diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp index c3f980ea..de90e40d 100644 --- a/src/RcppExports.cpp +++ b/src/RcppExports.cpp @@ -12,7 +12,7 @@ Rcpp::Rostream& Rcpp::Rcerr = Rcpp::Rcpp_cerr_get(); #endif // EM -Rcpp::List EM(const arma::mat& transition_, const arma::cube& emission_, const arma::vec& init_, const arma::ucube& obs, const arma::uvec& nSymbols, int itermax, double tol, int trace, unsigned int threads); +Rcpp::List EM(const arma::mat& transition_, const arma::cube& emission_, const arma::vec& init_, const arma::ucube& obs, const arma::uvec& nSymbols, int itermax, double tol, int trace, arma::uword threads); RcppExport SEXP _seqHMM_EM(SEXP transition_SEXP, SEXP emission_SEXP, SEXP init_SEXP, SEXP obsSEXP, SEXP nSymbolsSEXP, SEXP itermaxSEXP, SEXP tolSEXP, SEXP traceSEXP, SEXP threadsSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; @@ -25,13 +25,13 @@ BEGIN_RCPP Rcpp::traits::input_parameter< int >::type itermax(itermaxSEXP); Rcpp::traits::input_parameter< double >::type tol(tolSEXP); Rcpp::traits::input_parameter< int >::type trace(traceSEXP); - Rcpp::traits::input_parameter< unsigned int >::type threads(threadsSEXP); + Rcpp::traits::input_parameter< arma::uword >::type threads(threadsSEXP); rcpp_result_gen = Rcpp::wrap(EM(transition_, emission_, init_, obs, nSymbols, itermax, tol, trace, threads)); return rcpp_result_gen; END_RCPP } // EMx -Rcpp::List EMx(const arma::mat& transition_, const arma::cube& emission_, const arma::vec& init_, const arma::ucube& obs, const arma::uvec& nSymbols, const arma::mat& coef_, const arma::mat& X, const arma::uvec& numberOfStates, int itermax, double tol, int trace, unsigned int threads); +Rcpp::List EMx(const arma::mat& transition_, const arma::cube& emission_, const arma::vec& init_, const arma::ucube& obs, const arma::uvec& nSymbols, const arma::mat& coef_, const arma::mat& X, const arma::uvec& numberOfStates, int itermax, double tol, int trace, arma::uword threads); RcppExport SEXP _seqHMM_EMx(SEXP transition_SEXP, SEXP emission_SEXP, SEXP init_SEXP, SEXP obsSEXP, SEXP nSymbolsSEXP, SEXP coef_SEXP, SEXP XSEXP, SEXP numberOfStatesSEXP, SEXP itermaxSEXP, SEXP tolSEXP, SEXP traceSEXP, SEXP threadsSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; @@ -47,73 +47,11 @@ BEGIN_RCPP Rcpp::traits::input_parameter< int >::type itermax(itermaxSEXP); Rcpp::traits::input_parameter< double >::type tol(tolSEXP); Rcpp::traits::input_parameter< int >::type trace(traceSEXP); - Rcpp::traits::input_parameter< unsigned int >::type threads(threadsSEXP); + Rcpp::traits::input_parameter< arma::uword >::type threads(threadsSEXP); rcpp_result_gen = Rcpp::wrap(EMx(transition_, emission_, init_, obs, nSymbols, coef_, X, numberOfStates, itermax, tol, trace, threads)); return rcpp_result_gen; END_RCPP } -// backward_nhmm_singlechannel -arma::cube backward_nhmm_singlechannel(const arma::cube& eta_A, const arma::cube& X_s, const arma::cube& eta_B, const arma::cube& X_o, const arma::umat& obs); -RcppExport SEXP _seqHMM_backward_nhmm_singlechannel(SEXP eta_ASEXP, SEXP X_sSEXP, SEXP eta_BSEXP, SEXP X_oSEXP, SEXP obsSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::cube& >::type eta_A(eta_ASEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type X_s(X_sSEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type eta_B(eta_BSEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type X_o(X_oSEXP); - Rcpp::traits::input_parameter< const arma::umat& >::type obs(obsSEXP); - rcpp_result_gen = Rcpp::wrap(backward_nhmm_singlechannel(eta_A, X_s, eta_B, X_o, obs)); - return rcpp_result_gen; -END_RCPP -} -// backward_nhmm_multichannel -arma::cube backward_nhmm_multichannel(const arma::cube& eta_A, const arma::cube& X_s, const arma::field& eta_B, const arma::cube& X_o, const arma::ucube& obs, const arma::uvec M); -RcppExport SEXP _seqHMM_backward_nhmm_multichannel(SEXP eta_ASEXP, SEXP X_sSEXP, SEXP eta_BSEXP, SEXP X_oSEXP, SEXP obsSEXP, SEXP MSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::cube& >::type eta_A(eta_ASEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type X_s(X_sSEXP); - Rcpp::traits::input_parameter< const arma::field& >::type eta_B(eta_BSEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type X_o(X_oSEXP); - Rcpp::traits::input_parameter< const arma::ucube& >::type obs(obsSEXP); - Rcpp::traits::input_parameter< const arma::uvec >::type M(MSEXP); - rcpp_result_gen = Rcpp::wrap(backward_nhmm_multichannel(eta_A, X_s, eta_B, X_o, obs, M)); - return rcpp_result_gen; -END_RCPP -} -// backward_mnhmm_singlechannel -arma::cube backward_mnhmm_singlechannel(const arma::field& eta_A, const arma::cube& X_s, const arma::field& eta_B, const arma::cube& X_o, const arma::umat& obs); -RcppExport SEXP _seqHMM_backward_mnhmm_singlechannel(SEXP eta_ASEXP, SEXP X_sSEXP, SEXP eta_BSEXP, SEXP X_oSEXP, SEXP obsSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::field& >::type eta_A(eta_ASEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type X_s(X_sSEXP); - Rcpp::traits::input_parameter< const arma::field& >::type eta_B(eta_BSEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type X_o(X_oSEXP); - Rcpp::traits::input_parameter< const arma::umat& >::type obs(obsSEXP); - rcpp_result_gen = Rcpp::wrap(backward_mnhmm_singlechannel(eta_A, X_s, eta_B, X_o, obs)); - return rcpp_result_gen; -END_RCPP -} -// backward_mnhmm_multichannel -arma::cube backward_mnhmm_multichannel(const arma::field& eta_A, const arma::cube& X_s, const arma::field& eta_B, const arma::cube& X_o, const arma::ucube& obs, const arma::uvec M); -RcppExport SEXP _seqHMM_backward_mnhmm_multichannel(SEXP eta_ASEXP, SEXP X_sSEXP, SEXP eta_BSEXP, SEXP X_oSEXP, SEXP obsSEXP, SEXP MSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::field& >::type eta_A(eta_ASEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type X_s(X_sSEXP); - Rcpp::traits::input_parameter< const arma::field& >::type eta_B(eta_BSEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type X_o(X_oSEXP); - Rcpp::traits::input_parameter< const arma::ucube& >::type obs(obsSEXP); - Rcpp::traits::input_parameter< const arma::uvec >::type M(MSEXP); - rcpp_result_gen = Rcpp::wrap(backward_mnhmm_multichannel(eta_A, X_s, eta_B, X_o, obs, M)); - return rcpp_result_gen; -END_RCPP -} // cost_matrix_singlechannel arma::mat cost_matrix_singlechannel(const arma::mat& gamma_pi_est, const arma::mat& gamma_pi_ref, const arma::cube& gamma_A_est, const arma::cube& gamma_A_ref, const arma::cube& gamma_B_est, const arma::cube& gamma_B_ref); RcppExport SEXP _seqHMM_cost_matrix_singlechannel(SEXP gamma_pi_estSEXP, SEXP gamma_pi_refSEXP, SEXP gamma_A_estSEXP, SEXP gamma_A_refSEXP, SEXP gamma_B_estSEXP, SEXP gamma_B_refSEXP) { @@ -159,12 +97,12 @@ BEGIN_RCPP END_RCPP } // create_Q -arma::mat create_Q(const unsigned int n); +arma::mat create_Q(const arma::uword n); RcppExport SEXP _seqHMM_create_Q(SEXP nSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const unsigned int >::type n(nSEXP); + Rcpp::traits::input_parameter< const arma::uword >::type n(nSEXP); rcpp_result_gen = Rcpp::wrap(create_Q(n)); return rcpp_result_gen; END_RCPP @@ -225,82 +163,8 @@ BEGIN_RCPP return rcpp_result_gen; END_RCPP } -// forward_nhmm_singlechannel -arma::cube forward_nhmm_singlechannel(const arma::mat& eta_pi, const arma::mat& X_i, const arma::cube& eta_A, const arma::cube& X_s, const arma::cube& eta_B, const arma::cube& X_o, const arma::umat& obs); -RcppExport SEXP _seqHMM_forward_nhmm_singlechannel(SEXP eta_piSEXP, SEXP X_iSEXP, SEXP eta_ASEXP, SEXP X_sSEXP, SEXP eta_BSEXP, SEXP X_oSEXP, SEXP obsSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::mat& >::type eta_pi(eta_piSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type X_i(X_iSEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type eta_A(eta_ASEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type X_s(X_sSEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type eta_B(eta_BSEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type X_o(X_oSEXP); - Rcpp::traits::input_parameter< const arma::umat& >::type obs(obsSEXP); - rcpp_result_gen = Rcpp::wrap(forward_nhmm_singlechannel(eta_pi, X_i, eta_A, X_s, eta_B, X_o, obs)); - return rcpp_result_gen; -END_RCPP -} -// forward_nhmm_multichannel -arma::cube forward_nhmm_multichannel(const arma::mat& eta_pi, const arma::mat& X_i, const arma::cube& eta_A, const arma::cube& X_s, const arma::field& eta_B, const arma::cube& X_o, const arma::ucube& obs, const arma::uvec M); -RcppExport SEXP _seqHMM_forward_nhmm_multichannel(SEXP eta_piSEXP, SEXP X_iSEXP, SEXP eta_ASEXP, SEXP X_sSEXP, SEXP eta_BSEXP, SEXP X_oSEXP, SEXP obsSEXP, SEXP MSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::mat& >::type eta_pi(eta_piSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type X_i(X_iSEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type eta_A(eta_ASEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type X_s(X_sSEXP); - Rcpp::traits::input_parameter< const arma::field& >::type eta_B(eta_BSEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type X_o(X_oSEXP); - Rcpp::traits::input_parameter< const arma::ucube& >::type obs(obsSEXP); - Rcpp::traits::input_parameter< const arma::uvec >::type M(MSEXP); - rcpp_result_gen = Rcpp::wrap(forward_nhmm_multichannel(eta_pi, X_i, eta_A, X_s, eta_B, X_o, obs, M)); - return rcpp_result_gen; -END_RCPP -} -// forward_mnhmm_singlechannel -arma::cube forward_mnhmm_singlechannel(const arma::field& eta_pi, const arma::mat& X_i, const arma::field& eta_A, const arma::cube& X_s, const arma::field& eta_B, const arma::cube& X_o, const arma::mat& eta_omega, const arma::mat& X_d, const arma::umat& obs); -RcppExport SEXP _seqHMM_forward_mnhmm_singlechannel(SEXP eta_piSEXP, SEXP X_iSEXP, SEXP eta_ASEXP, SEXP X_sSEXP, SEXP eta_BSEXP, SEXP X_oSEXP, SEXP eta_omegaSEXP, SEXP X_dSEXP, SEXP obsSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::field& >::type eta_pi(eta_piSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type X_i(X_iSEXP); - Rcpp::traits::input_parameter< const arma::field& >::type eta_A(eta_ASEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type X_s(X_sSEXP); - Rcpp::traits::input_parameter< const arma::field& >::type eta_B(eta_BSEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type X_o(X_oSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type eta_omega(eta_omegaSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type X_d(X_dSEXP); - Rcpp::traits::input_parameter< const arma::umat& >::type obs(obsSEXP); - rcpp_result_gen = Rcpp::wrap(forward_mnhmm_singlechannel(eta_pi, X_i, eta_A, X_s, eta_B, X_o, eta_omega, X_d, obs)); - return rcpp_result_gen; -END_RCPP -} -// forward_mnhmm_multichannel -arma::cube forward_mnhmm_multichannel(const arma::field& eta_pi, const arma::mat& X_i, const arma::field& eta_A, const arma::cube& X_s, const arma::field& eta_B, const arma::cube& X_o, const arma::mat& eta_omega, const arma::mat& X_d, const arma::ucube& obs, const arma::uvec M); -RcppExport SEXP _seqHMM_forward_mnhmm_multichannel(SEXP eta_piSEXP, SEXP X_iSEXP, SEXP eta_ASEXP, SEXP X_sSEXP, SEXP eta_BSEXP, SEXP X_oSEXP, SEXP eta_omegaSEXP, SEXP X_dSEXP, SEXP obsSEXP, SEXP MSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::field& >::type eta_pi(eta_piSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type X_i(X_iSEXP); - Rcpp::traits::input_parameter< const arma::field& >::type eta_A(eta_ASEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type X_s(X_sSEXP); - Rcpp::traits::input_parameter< const arma::field& >::type eta_B(eta_BSEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type X_o(X_oSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type eta_omega(eta_omegaSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type X_d(X_dSEXP); - Rcpp::traits::input_parameter< const arma::ucube& >::type obs(obsSEXP); - Rcpp::traits::input_parameter< const arma::uvec >::type M(MSEXP); - rcpp_result_gen = Rcpp::wrap(forward_mnhmm_multichannel(eta_pi, X_i, eta_A, X_s, eta_B, X_o, eta_omega, X_d, obs, M)); - return rcpp_result_gen; -END_RCPP -} // forwardbackward -Rcpp::List forwardbackward(const arma::mat& transition, const arma::cube& emission, const arma::vec& init, const arma::ucube& obs, bool forwardonly, unsigned int threads); +Rcpp::List forwardbackward(const arma::mat& transition, const arma::cube& emission, const arma::vec& init, const arma::ucube& obs, bool forwardonly, arma::uword threads); RcppExport SEXP _seqHMM_forwardbackward(SEXP transitionSEXP, SEXP emissionSEXP, SEXP initSEXP, SEXP obsSEXP, SEXP forwardonlySEXP, SEXP threadsSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; @@ -310,13 +174,13 @@ BEGIN_RCPP Rcpp::traits::input_parameter< const arma::vec& >::type init(initSEXP); Rcpp::traits::input_parameter< const arma::ucube& >::type obs(obsSEXP); Rcpp::traits::input_parameter< bool >::type forwardonly(forwardonlySEXP); - Rcpp::traits::input_parameter< unsigned int >::type threads(threadsSEXP); + Rcpp::traits::input_parameter< arma::uword >::type threads(threadsSEXP); rcpp_result_gen = Rcpp::wrap(forwardbackward(transition, emission, init, obs, forwardonly, threads)); return rcpp_result_gen; END_RCPP } // forwardbackwardx -Rcpp::List forwardbackwardx(const arma::mat& transition, const arma::cube& emission, const arma::vec& init, const arma::ucube obs, const arma::mat& coef, const arma::mat& X, const arma::uvec& numberOfStates, bool forwardonly, unsigned int threads); +Rcpp::List forwardbackwardx(const arma::mat& transition, const arma::cube& emission, const arma::vec& init, const arma::ucube obs, const arma::mat& coef, const arma::mat& X, const arma::uvec& numberOfStates, bool forwardonly, arma::uword threads); RcppExport SEXP _seqHMM_forwardbackwardx(SEXP transitionSEXP, SEXP emissionSEXP, SEXP initSEXP, SEXP obsSEXP, SEXP coefSEXP, SEXP XSEXP, SEXP numberOfStatesSEXP, SEXP forwardonlySEXP, SEXP threadsSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; @@ -329,7 +193,7 @@ BEGIN_RCPP Rcpp::traits::input_parameter< const arma::mat& >::type X(XSEXP); Rcpp::traits::input_parameter< const arma::uvec& >::type numberOfStates(numberOfStatesSEXP); Rcpp::traits::input_parameter< bool >::type forwardonly(forwardonlySEXP); - Rcpp::traits::input_parameter< unsigned int >::type threads(threadsSEXP); + Rcpp::traits::input_parameter< arma::uword >::type threads(threadsSEXP); rcpp_result_gen = Rcpp::wrap(forwardbackwardx(transition, emission, init, obs, coef, X, numberOfStates, forwardonly, threads)); return rcpp_result_gen; END_RCPP @@ -599,7 +463,7 @@ BEGIN_RCPP END_RCPP } // logLikHMM -Rcpp::NumericVector logLikHMM(const arma::mat& transition, const arma::cube& emission, const arma::vec& init, const arma::ucube& obs, unsigned int threads); +Rcpp::NumericVector logLikHMM(const arma::mat& transition, const arma::cube& emission, const arma::vec& init, const arma::ucube& obs, arma::uword threads); RcppExport SEXP _seqHMM_logLikHMM(SEXP transitionSEXP, SEXP emissionSEXP, SEXP initSEXP, SEXP obsSEXP, SEXP threadsSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; @@ -608,13 +472,13 @@ BEGIN_RCPP Rcpp::traits::input_parameter< const arma::cube& >::type emission(emissionSEXP); Rcpp::traits::input_parameter< const arma::vec& >::type init(initSEXP); Rcpp::traits::input_parameter< const arma::ucube& >::type obs(obsSEXP); - Rcpp::traits::input_parameter< unsigned int >::type threads(threadsSEXP); + Rcpp::traits::input_parameter< arma::uword >::type threads(threadsSEXP); rcpp_result_gen = Rcpp::wrap(logLikHMM(transition, emission, init, obs, threads)); return rcpp_result_gen; END_RCPP } // logLikMixHMM -Rcpp::NumericVector logLikMixHMM(const arma::mat& transition, const arma::cube& emission, const arma::vec& init, const arma::ucube& obs, const arma::mat& coef, const arma::mat& X, const arma::uvec& numberOfStates, unsigned int threads); +Rcpp::NumericVector logLikMixHMM(const arma::mat& transition, const arma::cube& emission, const arma::vec& init, const arma::ucube& obs, const arma::mat& coef, const arma::mat& X, const arma::uvec& numberOfStates, arma::uword threads); RcppExport SEXP _seqHMM_logLikMixHMM(SEXP transitionSEXP, SEXP emissionSEXP, SEXP initSEXP, SEXP obsSEXP, SEXP coefSEXP, SEXP XSEXP, SEXP numberOfStatesSEXP, SEXP threadsSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; @@ -626,7 +490,7 @@ BEGIN_RCPP Rcpp::traits::input_parameter< const arma::mat& >::type coef(coefSEXP); Rcpp::traits::input_parameter< const arma::mat& >::type X(XSEXP); Rcpp::traits::input_parameter< const arma::uvec& >::type numberOfStates(numberOfStatesSEXP); - Rcpp::traits::input_parameter< unsigned int >::type threads(threadsSEXP); + Rcpp::traits::input_parameter< arma::uword >::type threads(threadsSEXP); rcpp_result_gen = Rcpp::wrap(logLikMixHMM(transition, emission, init, obs, coef, X, numberOfStates, threads)); return rcpp_result_gen; END_RCPP @@ -643,7 +507,7 @@ BEGIN_RCPP END_RCPP } // log_EM -Rcpp::List log_EM(const arma::mat& transition_, const arma::cube& emission_, const arma::vec& init_, const arma::ucube& obs, const arma::uvec& nSymbols, int itermax, double tol, int trace, unsigned int threads); +Rcpp::List log_EM(const arma::mat& transition_, const arma::cube& emission_, const arma::vec& init_, const arma::ucube& obs, const arma::uvec& nSymbols, int itermax, double tol, int trace, arma::uword threads); RcppExport SEXP _seqHMM_log_EM(SEXP transition_SEXP, SEXP emission_SEXP, SEXP init_SEXP, SEXP obsSEXP, SEXP nSymbolsSEXP, SEXP itermaxSEXP, SEXP tolSEXP, SEXP traceSEXP, SEXP threadsSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; @@ -656,13 +520,13 @@ BEGIN_RCPP Rcpp::traits::input_parameter< int >::type itermax(itermaxSEXP); Rcpp::traits::input_parameter< double >::type tol(tolSEXP); Rcpp::traits::input_parameter< int >::type trace(traceSEXP); - Rcpp::traits::input_parameter< unsigned int >::type threads(threadsSEXP); + Rcpp::traits::input_parameter< arma::uword >::type threads(threadsSEXP); rcpp_result_gen = Rcpp::wrap(log_EM(transition_, emission_, init_, obs, nSymbols, itermax, tol, trace, threads)); return rcpp_result_gen; END_RCPP } // log_EMx -Rcpp::List log_EMx(const arma::mat& transition_, const arma::cube& emission_, const arma::vec& init_, const arma::ucube& obs, const arma::uvec& nSymbols, const arma::mat& coef_, const arma::mat& X, const arma::uvec& numberOfStates, int itermax, double tol, int trace, unsigned int threads); +Rcpp::List log_EMx(const arma::mat& transition_, const arma::cube& emission_, const arma::vec& init_, const arma::ucube& obs, const arma::uvec& nSymbols, const arma::mat& coef_, const arma::mat& X, const arma::uvec& numberOfStates, int itermax, double tol, int trace, arma::uword threads); RcppExport SEXP _seqHMM_log_EMx(SEXP transition_SEXP, SEXP emission_SEXP, SEXP init_SEXP, SEXP obsSEXP, SEXP nSymbolsSEXP, SEXP coef_SEXP, SEXP XSEXP, SEXP numberOfStatesSEXP, SEXP itermaxSEXP, SEXP tolSEXP, SEXP traceSEXP, SEXP threadsSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; @@ -678,13 +542,13 @@ BEGIN_RCPP Rcpp::traits::input_parameter< int >::type itermax(itermaxSEXP); Rcpp::traits::input_parameter< double >::type tol(tolSEXP); Rcpp::traits::input_parameter< int >::type trace(traceSEXP); - Rcpp::traits::input_parameter< unsigned int >::type threads(threadsSEXP); + Rcpp::traits::input_parameter< arma::uword >::type threads(threadsSEXP); rcpp_result_gen = Rcpp::wrap(log_EMx(transition_, emission_, init_, obs, nSymbols, coef_, X, numberOfStates, itermax, tol, trace, threads)); return rcpp_result_gen; END_RCPP } // log_forwardbackward -Rcpp::List log_forwardbackward(const arma::mat& transition_, const arma::cube& emission_, const arma::vec& init_, const arma::ucube& obs, bool forwardonly, unsigned int threads); +Rcpp::List log_forwardbackward(const arma::mat& transition_, const arma::cube& emission_, const arma::vec& init_, const arma::ucube& obs, bool forwardonly, arma::uword threads); RcppExport SEXP _seqHMM_log_forwardbackward(SEXP transition_SEXP, SEXP emission_SEXP, SEXP init_SEXP, SEXP obsSEXP, SEXP forwardonlySEXP, SEXP threadsSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; @@ -694,13 +558,13 @@ BEGIN_RCPP Rcpp::traits::input_parameter< const arma::vec& >::type init_(init_SEXP); Rcpp::traits::input_parameter< const arma::ucube& >::type obs(obsSEXP); Rcpp::traits::input_parameter< bool >::type forwardonly(forwardonlySEXP); - Rcpp::traits::input_parameter< unsigned int >::type threads(threadsSEXP); + Rcpp::traits::input_parameter< arma::uword >::type threads(threadsSEXP); rcpp_result_gen = Rcpp::wrap(log_forwardbackward(transition_, emission_, init_, obs, forwardonly, threads)); return rcpp_result_gen; END_RCPP } // log_forwardbackwardx -Rcpp::List log_forwardbackwardx(const arma::mat& transition_, const arma::cube& emission_, const arma::vec& init_, const arma::ucube& obs, const arma::mat& coef, const arma::mat& X, const arma::uvec& numberOfStates, bool forwardonly, unsigned int threads); +Rcpp::List log_forwardbackwardx(const arma::mat& transition_, const arma::cube& emission_, const arma::vec& init_, const arma::ucube& obs, const arma::mat& coef, const arma::mat& X, const arma::uvec& numberOfStates, bool forwardonly, arma::uword threads); RcppExport SEXP _seqHMM_log_forwardbackwardx(SEXP transition_SEXP, SEXP emission_SEXP, SEXP init_SEXP, SEXP obsSEXP, SEXP coefSEXP, SEXP XSEXP, SEXP numberOfStatesSEXP, SEXP forwardonlySEXP, SEXP threadsSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; @@ -713,13 +577,13 @@ BEGIN_RCPP Rcpp::traits::input_parameter< const arma::mat& >::type X(XSEXP); Rcpp::traits::input_parameter< const arma::uvec& >::type numberOfStates(numberOfStatesSEXP); Rcpp::traits::input_parameter< bool >::type forwardonly(forwardonlySEXP); - Rcpp::traits::input_parameter< unsigned int >::type threads(threadsSEXP); + Rcpp::traits::input_parameter< arma::uword >::type threads(threadsSEXP); rcpp_result_gen = Rcpp::wrap(log_forwardbackwardx(transition_, emission_, init_, obs, coef, X, numberOfStates, forwardonly, threads)); return rcpp_result_gen; END_RCPP } // log_logLikHMM -Rcpp::NumericVector log_logLikHMM(const arma::mat& transition_, const arma::cube& emission_, const arma::vec& init_, const arma::ucube& obs, unsigned int threads); +Rcpp::NumericVector log_logLikHMM(const arma::mat& transition_, const arma::cube& emission_, const arma::vec& init_, const arma::ucube& obs, arma::uword threads); RcppExport SEXP _seqHMM_log_logLikHMM(SEXP transition_SEXP, SEXP emission_SEXP, SEXP init_SEXP, SEXP obsSEXP, SEXP threadsSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; @@ -728,13 +592,13 @@ BEGIN_RCPP Rcpp::traits::input_parameter< const arma::cube& >::type emission_(emission_SEXP); Rcpp::traits::input_parameter< const arma::vec& >::type init_(init_SEXP); Rcpp::traits::input_parameter< const arma::ucube& >::type obs(obsSEXP); - Rcpp::traits::input_parameter< unsigned int >::type threads(threadsSEXP); + Rcpp::traits::input_parameter< arma::uword >::type threads(threadsSEXP); rcpp_result_gen = Rcpp::wrap(log_logLikHMM(transition_, emission_, init_, obs, threads)); return rcpp_result_gen; END_RCPP } // log_logLikMixHMM -Rcpp::NumericVector log_logLikMixHMM(arma::mat transition, arma::cube emission, arma::vec init, const arma::ucube& obs, const arma::mat& coef, const arma::mat& X, const arma::uvec& numberOfStates, unsigned int threads); +Rcpp::NumericVector log_logLikMixHMM(arma::mat transition, arma::cube emission, arma::vec init, const arma::ucube& obs, const arma::mat& coef, const arma::mat& X, const arma::uvec& numberOfStates, arma::uword threads); RcppExport SEXP _seqHMM_log_logLikMixHMM(SEXP transitionSEXP, SEXP emissionSEXP, SEXP initSEXP, SEXP obsSEXP, SEXP coefSEXP, SEXP XSEXP, SEXP numberOfStatesSEXP, SEXP threadsSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; @@ -746,13 +610,13 @@ BEGIN_RCPP Rcpp::traits::input_parameter< const arma::mat& >::type coef(coefSEXP); Rcpp::traits::input_parameter< const arma::mat& >::type X(XSEXP); Rcpp::traits::input_parameter< const arma::uvec& >::type numberOfStates(numberOfStatesSEXP); - Rcpp::traits::input_parameter< unsigned int >::type threads(threadsSEXP); + Rcpp::traits::input_parameter< arma::uword >::type threads(threadsSEXP); rcpp_result_gen = Rcpp::wrap(log_logLikMixHMM(transition, emission, init, obs, coef, X, numberOfStates, threads)); return rcpp_result_gen; END_RCPP } // log_objective -Rcpp::List log_objective(const arma::mat& transition, const arma::cube& emission, const arma::vec& init, const arma::ucube& obs, const arma::umat& ANZ, const arma::ucube& BNZ, const arma::uvec& INZ, arma::uvec& nSymbols, unsigned int threads); +Rcpp::List log_objective(const arma::mat& transition, const arma::cube& emission, const arma::vec& init, const arma::ucube& obs, const arma::umat& ANZ, const arma::ucube& BNZ, const arma::uvec& INZ, arma::uvec& nSymbols, arma::uword threads); RcppExport SEXP _seqHMM_log_objective(SEXP transitionSEXP, SEXP emissionSEXP, SEXP initSEXP, SEXP obsSEXP, SEXP ANZSEXP, SEXP BNZSEXP, SEXP INZSEXP, SEXP nSymbolsSEXP, SEXP threadsSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; @@ -765,362 +629,570 @@ BEGIN_RCPP Rcpp::traits::input_parameter< const arma::ucube& >::type BNZ(BNZSEXP); Rcpp::traits::input_parameter< const arma::uvec& >::type INZ(INZSEXP); Rcpp::traits::input_parameter< arma::uvec& >::type nSymbols(nSymbolsSEXP); - Rcpp::traits::input_parameter< unsigned int >::type threads(threadsSEXP); + Rcpp::traits::input_parameter< arma::uword >::type threads(threadsSEXP); rcpp_result_gen = Rcpp::wrap(log_objective(transition, emission, init, obs, ANZ, BNZ, INZ, nSymbols, threads)); return rcpp_result_gen; END_RCPP } -// log_objective_nhmm_singlechannel -Rcpp::List log_objective_nhmm_singlechannel(const arma::mat& Qs, const arma::mat& Qm, const arma::mat& eta_pi, const arma::mat& X_i, const arma::cube& eta_A, const arma::cube& X_s, const arma::cube& eta_B, const arma::cube& X_o, const arma::umat& obs, const bool iv_pi, const bool iv_A, const bool iv_B, const bool tv_A, const bool tv_B, const arma::uvec& Ti); -RcppExport SEXP _seqHMM_log_objective_nhmm_singlechannel(SEXP QsSEXP, SEXP QmSEXP, SEXP eta_piSEXP, SEXP X_iSEXP, SEXP eta_ASEXP, SEXP X_sSEXP, SEXP eta_BSEXP, SEXP X_oSEXP, SEXP obsSEXP, SEXP iv_piSEXP, SEXP iv_ASEXP, SEXP iv_BSEXP, SEXP tv_ASEXP, SEXP tv_BSEXP, SEXP TiSEXP) { +// log_objectivex +Rcpp::List log_objectivex(const arma::mat& transition, const arma::cube& emission, const arma::vec& init, const arma::ucube& obs, const arma::umat& ANZ, const arma::ucube& BNZ, const arma::uvec& INZ, const arma::uvec& nSymbols, const arma::mat& coef, const arma::mat& X, const arma::uvec& numberOfStates, arma::uword threads); +RcppExport SEXP _seqHMM_log_objectivex(SEXP transitionSEXP, SEXP emissionSEXP, SEXP initSEXP, SEXP obsSEXP, SEXP ANZSEXP, SEXP BNZSEXP, SEXP INZSEXP, SEXP nSymbolsSEXP, SEXP coefSEXP, SEXP XSEXP, SEXP numberOfStatesSEXP, SEXP threadsSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::mat& >::type Qs(QsSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type Qm(QmSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type eta_pi(eta_piSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type X_i(X_iSEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type eta_A(eta_ASEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type X_s(X_sSEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type eta_B(eta_BSEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type X_o(X_oSEXP); + Rcpp::traits::input_parameter< const arma::mat& >::type transition(transitionSEXP); + Rcpp::traits::input_parameter< const arma::cube& >::type emission(emissionSEXP); + Rcpp::traits::input_parameter< const arma::vec& >::type init(initSEXP); + Rcpp::traits::input_parameter< const arma::ucube& >::type obs(obsSEXP); + Rcpp::traits::input_parameter< const arma::umat& >::type ANZ(ANZSEXP); + Rcpp::traits::input_parameter< const arma::ucube& >::type BNZ(BNZSEXP); + Rcpp::traits::input_parameter< const arma::uvec& >::type INZ(INZSEXP); + Rcpp::traits::input_parameter< const arma::uvec& >::type nSymbols(nSymbolsSEXP); + Rcpp::traits::input_parameter< const arma::mat& >::type coef(coefSEXP); + Rcpp::traits::input_parameter< const arma::mat& >::type X(XSEXP); + Rcpp::traits::input_parameter< const arma::uvec& >::type numberOfStates(numberOfStatesSEXP); + Rcpp::traits::input_parameter< arma::uword >::type threads(threadsSEXP); + rcpp_result_gen = Rcpp::wrap(log_objectivex(transition, emission, init, obs, ANZ, BNZ, INZ, nSymbols, coef, X, numberOfStates, threads)); + return rcpp_result_gen; +END_RCPP +} +// backward_nhmm_singlechannel +arma::cube backward_nhmm_singlechannel(arma::mat& eta_pi, const arma::mat& X_pi, arma::cube& eta_A, const arma::cube& X_A, arma::cube& eta_B, const arma::cube& X_B, const arma::umat& obs, const arma::uvec Ti, const bool iv_pi, const bool iv_A, const bool iv_B, const bool tv_A, const bool tv_B); +RcppExport SEXP _seqHMM_backward_nhmm_singlechannel(SEXP eta_piSEXP, SEXP X_piSEXP, SEXP eta_ASEXP, SEXP X_ASEXP, SEXP eta_BSEXP, SEXP X_BSEXP, SEXP obsSEXP, SEXP TiSEXP, SEXP iv_piSEXP, SEXP iv_ASEXP, SEXP iv_BSEXP, SEXP tv_ASEXP, SEXP tv_BSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< arma::mat& >::type eta_pi(eta_piSEXP); + Rcpp::traits::input_parameter< const arma::mat& >::type X_pi(X_piSEXP); + Rcpp::traits::input_parameter< arma::cube& >::type eta_A(eta_ASEXP); + Rcpp::traits::input_parameter< const arma::cube& >::type X_A(X_ASEXP); + Rcpp::traits::input_parameter< arma::cube& >::type eta_B(eta_BSEXP); + Rcpp::traits::input_parameter< const arma::cube& >::type X_B(X_BSEXP); Rcpp::traits::input_parameter< const arma::umat& >::type obs(obsSEXP); + Rcpp::traits::input_parameter< const arma::uvec >::type Ti(TiSEXP); Rcpp::traits::input_parameter< const bool >::type iv_pi(iv_piSEXP); Rcpp::traits::input_parameter< const bool >::type iv_A(iv_ASEXP); Rcpp::traits::input_parameter< const bool >::type iv_B(iv_BSEXP); Rcpp::traits::input_parameter< const bool >::type tv_A(tv_ASEXP); Rcpp::traits::input_parameter< const bool >::type tv_B(tv_BSEXP); - Rcpp::traits::input_parameter< const arma::uvec& >::type Ti(TiSEXP); - rcpp_result_gen = Rcpp::wrap(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)); + rcpp_result_gen = Rcpp::wrap(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)); return rcpp_result_gen; END_RCPP } -// log_objective_nhmm_multichannel -Rcpp::List log_objective_nhmm_multichannel(const arma::mat& Qs, const arma::field& Qm, const arma::mat& eta_pi, const arma::mat& X_i, const arma::cube& eta_A, const arma::cube& X_s, const arma::field& eta_B, const arma::cube& X_o, const arma::ucube& obs, const arma::uvec& M, const bool iv_pi, const bool iv_A, const bool iv_B, const bool tv_A, const bool tv_B, const arma::uvec& Ti); -RcppExport SEXP _seqHMM_log_objective_nhmm_multichannel(SEXP QsSEXP, SEXP QmSEXP, SEXP eta_piSEXP, SEXP X_iSEXP, SEXP eta_ASEXP, SEXP X_sSEXP, SEXP eta_BSEXP, SEXP X_oSEXP, SEXP obsSEXP, SEXP MSEXP, SEXP iv_piSEXP, SEXP iv_ASEXP, SEXP iv_BSEXP, SEXP tv_ASEXP, SEXP tv_BSEXP, SEXP TiSEXP) { +// backward_nhmm_multichannel +arma::cube backward_nhmm_multichannel(arma::mat& eta_pi, const arma::mat& X_pi, arma::cube& eta_A, const arma::cube& X_A, arma::field& eta_B, const arma::cube& X_B, const arma::ucube& obs, const arma::uvec Ti, const bool iv_pi, const bool iv_A, const bool iv_B, const bool tv_A, const bool tv_B); +RcppExport SEXP _seqHMM_backward_nhmm_multichannel(SEXP eta_piSEXP, SEXP X_piSEXP, SEXP eta_ASEXP, SEXP X_ASEXP, SEXP eta_BSEXP, SEXP X_BSEXP, SEXP obsSEXP, SEXP TiSEXP, SEXP iv_piSEXP, SEXP iv_ASEXP, SEXP iv_BSEXP, SEXP tv_ASEXP, SEXP tv_BSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::mat& >::type Qs(QsSEXP); - Rcpp::traits::input_parameter< const arma::field& >::type Qm(QmSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type eta_pi(eta_piSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type X_i(X_iSEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type eta_A(eta_ASEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type X_s(X_sSEXP); - Rcpp::traits::input_parameter< const arma::field& >::type eta_B(eta_BSEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type X_o(X_oSEXP); + Rcpp::traits::input_parameter< arma::mat& >::type eta_pi(eta_piSEXP); + Rcpp::traits::input_parameter< const arma::mat& >::type X_pi(X_piSEXP); + Rcpp::traits::input_parameter< arma::cube& >::type eta_A(eta_ASEXP); + Rcpp::traits::input_parameter< const arma::cube& >::type X_A(X_ASEXP); + Rcpp::traits::input_parameter< arma::field& >::type eta_B(eta_BSEXP); + Rcpp::traits::input_parameter< const arma::cube& >::type X_B(X_BSEXP); Rcpp::traits::input_parameter< const arma::ucube& >::type obs(obsSEXP); - Rcpp::traits::input_parameter< const arma::uvec& >::type M(MSEXP); + Rcpp::traits::input_parameter< const arma::uvec >::type Ti(TiSEXP); Rcpp::traits::input_parameter< const bool >::type iv_pi(iv_piSEXP); Rcpp::traits::input_parameter< const bool >::type iv_A(iv_ASEXP); Rcpp::traits::input_parameter< const bool >::type iv_B(iv_BSEXP); Rcpp::traits::input_parameter< const bool >::type tv_A(tv_ASEXP); Rcpp::traits::input_parameter< const bool >::type tv_B(tv_BSEXP); - Rcpp::traits::input_parameter< const arma::uvec& >::type Ti(TiSEXP); - rcpp_result_gen = Rcpp::wrap(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)); + rcpp_result_gen = Rcpp::wrap(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)); return rcpp_result_gen; END_RCPP } -// log_objective_mnhmm_singlechannel -Rcpp::List log_objective_mnhmm_singlechannel(const arma::mat& Qs, const arma::mat& Qm, const arma::mat& Qd, const arma::field& eta_pi, const arma::mat& X_i, const arma::field& eta_A, const arma::cube& X_s, const arma::field& eta_B, const arma::cube& X_o, const arma::mat& eta_omega, const arma::mat& X_d, const arma::umat& obs, const bool iv_pi, const bool iv_A, const bool iv_B, const bool tv_A, const bool tv_B, const bool iv_omega, const arma::uvec& Ti); -RcppExport SEXP _seqHMM_log_objective_mnhmm_singlechannel(SEXP QsSEXP, SEXP QmSEXP, SEXP QdSEXP, SEXP eta_piSEXP, SEXP X_iSEXP, SEXP eta_ASEXP, SEXP X_sSEXP, SEXP eta_BSEXP, SEXP X_oSEXP, SEXP eta_omegaSEXP, SEXP X_dSEXP, SEXP obsSEXP, SEXP iv_piSEXP, SEXP iv_ASEXP, SEXP iv_BSEXP, SEXP tv_ASEXP, SEXP tv_BSEXP, SEXP iv_omegaSEXP, SEXP TiSEXP) { +// backward_mnhmm_singlechannel +arma::cube backward_mnhmm_singlechannel(arma::mat& eta_omega, const arma::mat& X_omega, arma::field& eta_pi, const arma::mat& X_pi, arma::field& eta_A, const arma::cube& X_A, arma::field& eta_B, const arma::cube& X_B, const arma::umat& obs, const arma::uvec Ti, const bool iv_omega, const bool iv_pi, const bool iv_A, const bool iv_B, const bool tv_A, const bool tv_B); +RcppExport SEXP _seqHMM_backward_mnhmm_singlechannel(SEXP eta_omegaSEXP, SEXP X_omegaSEXP, SEXP eta_piSEXP, SEXP X_piSEXP, SEXP eta_ASEXP, SEXP X_ASEXP, SEXP eta_BSEXP, SEXP X_BSEXP, SEXP obsSEXP, SEXP TiSEXP, SEXP iv_omegaSEXP, SEXP iv_piSEXP, SEXP iv_ASEXP, SEXP iv_BSEXP, SEXP tv_ASEXP, SEXP tv_BSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::mat& >::type Qs(QsSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type Qm(QmSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type Qd(QdSEXP); - Rcpp::traits::input_parameter< const arma::field& >::type eta_pi(eta_piSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type X_i(X_iSEXP); - Rcpp::traits::input_parameter< const arma::field& >::type eta_A(eta_ASEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type X_s(X_sSEXP); - Rcpp::traits::input_parameter< const arma::field& >::type eta_B(eta_BSEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type X_o(X_oSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type eta_omega(eta_omegaSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type X_d(X_dSEXP); + Rcpp::traits::input_parameter< arma::mat& >::type eta_omega(eta_omegaSEXP); + Rcpp::traits::input_parameter< const arma::mat& >::type X_omega(X_omegaSEXP); + Rcpp::traits::input_parameter< arma::field& >::type eta_pi(eta_piSEXP); + Rcpp::traits::input_parameter< const arma::mat& >::type X_pi(X_piSEXP); + Rcpp::traits::input_parameter< arma::field& >::type eta_A(eta_ASEXP); + Rcpp::traits::input_parameter< const arma::cube& >::type X_A(X_ASEXP); + Rcpp::traits::input_parameter< arma::field& >::type eta_B(eta_BSEXP); + Rcpp::traits::input_parameter< const arma::cube& >::type X_B(X_BSEXP); Rcpp::traits::input_parameter< const arma::umat& >::type obs(obsSEXP); + Rcpp::traits::input_parameter< const arma::uvec >::type Ti(TiSEXP); + Rcpp::traits::input_parameter< const bool >::type iv_omega(iv_omegaSEXP); Rcpp::traits::input_parameter< const bool >::type iv_pi(iv_piSEXP); Rcpp::traits::input_parameter< const bool >::type iv_A(iv_ASEXP); Rcpp::traits::input_parameter< const bool >::type iv_B(iv_BSEXP); Rcpp::traits::input_parameter< const bool >::type tv_A(tv_ASEXP); Rcpp::traits::input_parameter< const bool >::type tv_B(tv_BSEXP); + rcpp_result_gen = Rcpp::wrap(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)); + return rcpp_result_gen; +END_RCPP +} +// backward_mnhmm_multichannel +arma::cube backward_mnhmm_multichannel(arma::mat& eta_omega, const arma::mat& X_omega, arma::field& eta_pi, const arma::mat& X_pi, arma::field& eta_A, const arma::cube& X_A, arma::field& eta_B, const arma::cube& X_B, const arma::ucube& obs, const arma::uvec Ti, const bool iv_omega, const bool iv_pi, const bool iv_A, const bool iv_B, const bool tv_A, const bool tv_B); +RcppExport SEXP _seqHMM_backward_mnhmm_multichannel(SEXP eta_omegaSEXP, SEXP X_omegaSEXP, SEXP eta_piSEXP, SEXP X_piSEXP, SEXP eta_ASEXP, SEXP X_ASEXP, SEXP eta_BSEXP, SEXP X_BSEXP, SEXP obsSEXP, SEXP TiSEXP, SEXP iv_omegaSEXP, SEXP iv_piSEXP, SEXP iv_ASEXP, SEXP iv_BSEXP, SEXP tv_ASEXP, SEXP tv_BSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< arma::mat& >::type eta_omega(eta_omegaSEXP); + Rcpp::traits::input_parameter< const arma::mat& >::type X_omega(X_omegaSEXP); + Rcpp::traits::input_parameter< arma::field& >::type eta_pi(eta_piSEXP); + Rcpp::traits::input_parameter< const arma::mat& >::type X_pi(X_piSEXP); + Rcpp::traits::input_parameter< arma::field& >::type eta_A(eta_ASEXP); + Rcpp::traits::input_parameter< const arma::cube& >::type X_A(X_ASEXP); + Rcpp::traits::input_parameter< arma::field& >::type eta_B(eta_BSEXP); + Rcpp::traits::input_parameter< const arma::cube& >::type X_B(X_BSEXP); + Rcpp::traits::input_parameter< const arma::ucube& >::type obs(obsSEXP); + Rcpp::traits::input_parameter< const arma::uvec >::type Ti(TiSEXP); Rcpp::traits::input_parameter< const bool >::type iv_omega(iv_omegaSEXP); - Rcpp::traits::input_parameter< const arma::uvec& >::type Ti(TiSEXP); - rcpp_result_gen = Rcpp::wrap(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)); + Rcpp::traits::input_parameter< const bool >::type iv_pi(iv_piSEXP); + Rcpp::traits::input_parameter< const bool >::type iv_A(iv_ASEXP); + Rcpp::traits::input_parameter< const bool >::type iv_B(iv_BSEXP); + Rcpp::traits::input_parameter< const bool >::type tv_A(tv_ASEXP); + Rcpp::traits::input_parameter< const bool >::type tv_B(tv_BSEXP); + rcpp_result_gen = Rcpp::wrap(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)); return rcpp_result_gen; END_RCPP } -// log_objective_mnhmm_multichannel -Rcpp::List log_objective_mnhmm_multichannel(const arma::mat& Qs, const arma::field& Qm, const arma::mat& Qd, const arma::field& eta_pi, const arma::mat& X_i, const arma::field& eta_A, const arma::cube& X_s, const arma::field& eta_B, const arma::cube& X_o, const arma::mat& eta_omega, const arma::mat& X_d, const arma::ucube& obs, const arma::uvec& M, const bool iv_pi, const bool iv_A, const bool iv_B, const bool tv_A, const bool tv_B, const bool iv_omega, const arma::uvec& Ti); -RcppExport SEXP _seqHMM_log_objective_mnhmm_multichannel(SEXP QsSEXP, SEXP QmSEXP, SEXP QdSEXP, SEXP eta_piSEXP, SEXP X_iSEXP, SEXP eta_ASEXP, SEXP X_sSEXP, SEXP eta_BSEXP, SEXP X_oSEXP, SEXP eta_omegaSEXP, SEXP X_dSEXP, SEXP obsSEXP, SEXP MSEXP, SEXP iv_piSEXP, SEXP iv_ASEXP, SEXP iv_BSEXP, SEXP tv_ASEXP, SEXP tv_BSEXP, SEXP iv_omegaSEXP, SEXP TiSEXP) { +// forward_nhmm_singlechannel +arma::cube forward_nhmm_singlechannel(arma::mat& eta_pi, const arma::mat& X_pi, arma::cube& eta_A, const arma::cube& X_A, arma::cube& eta_B, const arma::cube& X_B, const arma::umat& obs, const arma::uvec Ti, const bool iv_pi, const bool iv_A, const bool iv_B, const bool tv_A, const bool tv_B); +RcppExport SEXP _seqHMM_forward_nhmm_singlechannel(SEXP eta_piSEXP, SEXP X_piSEXP, SEXP eta_ASEXP, SEXP X_ASEXP, SEXP eta_BSEXP, SEXP X_BSEXP, SEXP obsSEXP, SEXP TiSEXP, SEXP iv_piSEXP, SEXP iv_ASEXP, SEXP iv_BSEXP, SEXP tv_ASEXP, SEXP tv_BSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::mat& >::type Qs(QsSEXP); - Rcpp::traits::input_parameter< const arma::field& >::type Qm(QmSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type Qd(QdSEXP); - Rcpp::traits::input_parameter< const arma::field& >::type eta_pi(eta_piSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type X_i(X_iSEXP); - Rcpp::traits::input_parameter< const arma::field& >::type eta_A(eta_ASEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type X_s(X_sSEXP); - Rcpp::traits::input_parameter< const arma::field& >::type eta_B(eta_BSEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type X_o(X_oSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type eta_omega(eta_omegaSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type X_d(X_dSEXP); + Rcpp::traits::input_parameter< arma::mat& >::type eta_pi(eta_piSEXP); + Rcpp::traits::input_parameter< const arma::mat& >::type X_pi(X_piSEXP); + Rcpp::traits::input_parameter< arma::cube& >::type eta_A(eta_ASEXP); + Rcpp::traits::input_parameter< const arma::cube& >::type X_A(X_ASEXP); + Rcpp::traits::input_parameter< arma::cube& >::type eta_B(eta_BSEXP); + Rcpp::traits::input_parameter< const arma::cube& >::type X_B(X_BSEXP); + Rcpp::traits::input_parameter< const arma::umat& >::type obs(obsSEXP); + Rcpp::traits::input_parameter< const arma::uvec >::type Ti(TiSEXP); + Rcpp::traits::input_parameter< const bool >::type iv_pi(iv_piSEXP); + Rcpp::traits::input_parameter< const bool >::type iv_A(iv_ASEXP); + Rcpp::traits::input_parameter< const bool >::type iv_B(iv_BSEXP); + Rcpp::traits::input_parameter< const bool >::type tv_A(tv_ASEXP); + Rcpp::traits::input_parameter< const bool >::type tv_B(tv_BSEXP); + rcpp_result_gen = Rcpp::wrap(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)); + return rcpp_result_gen; +END_RCPP +} +// forward_nhmm_multichannel +arma::cube forward_nhmm_multichannel(arma::mat& eta_pi, const arma::mat& X_pi, arma::cube& eta_A, const arma::cube& X_A, arma::field& eta_B, const arma::cube& X_B, const arma::ucube& obs, const arma::uvec Ti, const bool iv_pi, const bool iv_A, const bool iv_B, const bool tv_A, const bool tv_B); +RcppExport SEXP _seqHMM_forward_nhmm_multichannel(SEXP eta_piSEXP, SEXP X_piSEXP, SEXP eta_ASEXP, SEXP X_ASEXP, SEXP eta_BSEXP, SEXP X_BSEXP, SEXP obsSEXP, SEXP TiSEXP, SEXP iv_piSEXP, SEXP iv_ASEXP, SEXP iv_BSEXP, SEXP tv_ASEXP, SEXP tv_BSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< arma::mat& >::type eta_pi(eta_piSEXP); + Rcpp::traits::input_parameter< const arma::mat& >::type X_pi(X_piSEXP); + Rcpp::traits::input_parameter< arma::cube& >::type eta_A(eta_ASEXP); + Rcpp::traits::input_parameter< const arma::cube& >::type X_A(X_ASEXP); + Rcpp::traits::input_parameter< arma::field& >::type eta_B(eta_BSEXP); + Rcpp::traits::input_parameter< const arma::cube& >::type X_B(X_BSEXP); Rcpp::traits::input_parameter< const arma::ucube& >::type obs(obsSEXP); - Rcpp::traits::input_parameter< const arma::uvec& >::type M(MSEXP); + Rcpp::traits::input_parameter< const arma::uvec >::type Ti(TiSEXP); + Rcpp::traits::input_parameter< const bool >::type iv_pi(iv_piSEXP); + Rcpp::traits::input_parameter< const bool >::type iv_A(iv_ASEXP); + Rcpp::traits::input_parameter< const bool >::type iv_B(iv_BSEXP); + Rcpp::traits::input_parameter< const bool >::type tv_A(tv_ASEXP); + Rcpp::traits::input_parameter< const bool >::type tv_B(tv_BSEXP); + rcpp_result_gen = Rcpp::wrap(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)); + return rcpp_result_gen; +END_RCPP +} +// forward_mnhmm_singlechannel +arma::cube forward_mnhmm_singlechannel(arma::mat& eta_omega, const arma::mat& X_omega, arma::field& eta_pi, const arma::mat& X_pi, arma::field& eta_A, const arma::cube& X_A, arma::field& eta_B, const arma::cube& X_B, const arma::umat& obs, const arma::uvec Ti, const bool iv_omega, const bool iv_pi, const bool iv_A, const bool iv_B, const bool tv_A, const bool tv_B); +RcppExport SEXP _seqHMM_forward_mnhmm_singlechannel(SEXP eta_omegaSEXP, SEXP X_omegaSEXP, SEXP eta_piSEXP, SEXP X_piSEXP, SEXP eta_ASEXP, SEXP X_ASEXP, SEXP eta_BSEXP, SEXP X_BSEXP, SEXP obsSEXP, SEXP TiSEXP, SEXP iv_omegaSEXP, SEXP iv_piSEXP, SEXP iv_ASEXP, SEXP iv_BSEXP, SEXP tv_ASEXP, SEXP tv_BSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< arma::mat& >::type eta_omega(eta_omegaSEXP); + Rcpp::traits::input_parameter< const arma::mat& >::type X_omega(X_omegaSEXP); + Rcpp::traits::input_parameter< arma::field& >::type eta_pi(eta_piSEXP); + Rcpp::traits::input_parameter< const arma::mat& >::type X_pi(X_piSEXP); + Rcpp::traits::input_parameter< arma::field& >::type eta_A(eta_ASEXP); + Rcpp::traits::input_parameter< const arma::cube& >::type X_A(X_ASEXP); + Rcpp::traits::input_parameter< arma::field& >::type eta_B(eta_BSEXP); + Rcpp::traits::input_parameter< const arma::cube& >::type X_B(X_BSEXP); + Rcpp::traits::input_parameter< const arma::umat& >::type obs(obsSEXP); + Rcpp::traits::input_parameter< const arma::uvec >::type Ti(TiSEXP); + Rcpp::traits::input_parameter< const bool >::type iv_omega(iv_omegaSEXP); Rcpp::traits::input_parameter< const bool >::type iv_pi(iv_piSEXP); Rcpp::traits::input_parameter< const bool >::type iv_A(iv_ASEXP); Rcpp::traits::input_parameter< const bool >::type iv_B(iv_BSEXP); Rcpp::traits::input_parameter< const bool >::type tv_A(tv_ASEXP); Rcpp::traits::input_parameter< const bool >::type tv_B(tv_BSEXP); + rcpp_result_gen = Rcpp::wrap(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)); + return rcpp_result_gen; +END_RCPP +} +// forward_mnhmm_multichannel +arma::cube forward_mnhmm_multichannel(arma::mat& eta_omega, const arma::mat& X_omega, arma::field& eta_pi, const arma::mat& X_pi, arma::field& eta_A, const arma::cube& X_A, arma::field& eta_B, const arma::cube& X_B, const arma::ucube& obs, const arma::uvec Ti, const bool iv_omega, const bool iv_pi, const bool iv_A, const bool iv_B, const bool tv_A, const bool tv_B); +RcppExport SEXP _seqHMM_forward_mnhmm_multichannel(SEXP eta_omegaSEXP, SEXP X_omegaSEXP, SEXP eta_piSEXP, SEXP X_piSEXP, SEXP eta_ASEXP, SEXP X_ASEXP, SEXP eta_BSEXP, SEXP X_BSEXP, SEXP obsSEXP, SEXP TiSEXP, SEXP iv_omegaSEXP, SEXP iv_piSEXP, SEXP iv_ASEXP, SEXP iv_BSEXP, SEXP tv_ASEXP, SEXP tv_BSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< arma::mat& >::type eta_omega(eta_omegaSEXP); + Rcpp::traits::input_parameter< const arma::mat& >::type X_omega(X_omegaSEXP); + Rcpp::traits::input_parameter< arma::field& >::type eta_pi(eta_piSEXP); + Rcpp::traits::input_parameter< const arma::mat& >::type X_pi(X_piSEXP); + Rcpp::traits::input_parameter< arma::field& >::type eta_A(eta_ASEXP); + Rcpp::traits::input_parameter< const arma::cube& >::type X_A(X_ASEXP); + Rcpp::traits::input_parameter< arma::field& >::type eta_B(eta_BSEXP); + Rcpp::traits::input_parameter< const arma::cube& >::type X_B(X_BSEXP); + Rcpp::traits::input_parameter< const arma::ucube& >::type obs(obsSEXP); + Rcpp::traits::input_parameter< const arma::uvec >::type Ti(TiSEXP); Rcpp::traits::input_parameter< const bool >::type iv_omega(iv_omegaSEXP); + Rcpp::traits::input_parameter< const bool >::type iv_pi(iv_piSEXP); + Rcpp::traits::input_parameter< const bool >::type iv_A(iv_ASEXP); + Rcpp::traits::input_parameter< const bool >::type iv_B(iv_BSEXP); + Rcpp::traits::input_parameter< const bool >::type tv_A(tv_ASEXP); + Rcpp::traits::input_parameter< const bool >::type tv_B(tv_BSEXP); + rcpp_result_gen = Rcpp::wrap(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)); + return rcpp_result_gen; +END_RCPP +} +// log_objective_nhmm_singlechannel +Rcpp::List log_objective_nhmm_singlechannel(arma::mat& eta_pi, const arma::mat& X_pi, arma::cube& eta_A, const arma::cube& X_A, arma::cube& eta_B, const arma::cube& X_B, const arma::umat& obs, const bool iv_pi, const bool iv_A, const bool iv_B, const bool tv_A, const bool tv_B, const arma::uvec& Ti); +RcppExport SEXP _seqHMM_log_objective_nhmm_singlechannel(SEXP eta_piSEXP, SEXP X_piSEXP, SEXP eta_ASEXP, SEXP X_ASEXP, SEXP eta_BSEXP, SEXP X_BSEXP, SEXP obsSEXP, SEXP iv_piSEXP, SEXP iv_ASEXP, SEXP iv_BSEXP, SEXP tv_ASEXP, SEXP tv_BSEXP, SEXP TiSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< arma::mat& >::type eta_pi(eta_piSEXP); + Rcpp::traits::input_parameter< const arma::mat& >::type X_pi(X_piSEXP); + Rcpp::traits::input_parameter< arma::cube& >::type eta_A(eta_ASEXP); + Rcpp::traits::input_parameter< const arma::cube& >::type X_A(X_ASEXP); + Rcpp::traits::input_parameter< arma::cube& >::type eta_B(eta_BSEXP); + Rcpp::traits::input_parameter< const arma::cube& >::type X_B(X_BSEXP); + Rcpp::traits::input_parameter< const arma::umat& >::type obs(obsSEXP); + Rcpp::traits::input_parameter< const bool >::type iv_pi(iv_piSEXP); + Rcpp::traits::input_parameter< const bool >::type iv_A(iv_ASEXP); + Rcpp::traits::input_parameter< const bool >::type iv_B(iv_BSEXP); + Rcpp::traits::input_parameter< const bool >::type tv_A(tv_ASEXP); + Rcpp::traits::input_parameter< const bool >::type tv_B(tv_BSEXP); Rcpp::traits::input_parameter< const arma::uvec& >::type Ti(TiSEXP); - rcpp_result_gen = Rcpp::wrap(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)); + rcpp_result_gen = Rcpp::wrap(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)); return rcpp_result_gen; END_RCPP } -// log_objectivex -Rcpp::List log_objectivex(const arma::mat& transition, const arma::cube& emission, const arma::vec& init, const arma::ucube& obs, const arma::umat& ANZ, const arma::ucube& BNZ, const arma::uvec& INZ, const arma::uvec& nSymbols, const arma::mat& coef, const arma::mat& X, const arma::uvec& numberOfStates, unsigned int threads); -RcppExport SEXP _seqHMM_log_objectivex(SEXP transitionSEXP, SEXP emissionSEXP, SEXP initSEXP, SEXP obsSEXP, SEXP ANZSEXP, SEXP BNZSEXP, SEXP INZSEXP, SEXP nSymbolsSEXP, SEXP coefSEXP, SEXP XSEXP, SEXP numberOfStatesSEXP, SEXP threadsSEXP) { +// log_objective_nhmm_multichannel +Rcpp::List log_objective_nhmm_multichannel(arma::mat& eta_pi, const arma::mat& X_pi, arma::cube& eta_A, const arma::cube& X_A, arma::field& eta_B, const arma::cube& X_B, const arma::ucube& obs, const bool iv_pi, const bool iv_A, const bool iv_B, const bool tv_A, const bool tv_B, const arma::uvec& Ti); +RcppExport SEXP _seqHMM_log_objective_nhmm_multichannel(SEXP eta_piSEXP, SEXP X_piSEXP, SEXP eta_ASEXP, SEXP X_ASEXP, SEXP eta_BSEXP, SEXP X_BSEXP, SEXP obsSEXP, SEXP iv_piSEXP, SEXP iv_ASEXP, SEXP iv_BSEXP, SEXP tv_ASEXP, SEXP tv_BSEXP, SEXP TiSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::mat& >::type transition(transitionSEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type emission(emissionSEXP); - Rcpp::traits::input_parameter< const arma::vec& >::type init(initSEXP); + Rcpp::traits::input_parameter< arma::mat& >::type eta_pi(eta_piSEXP); + Rcpp::traits::input_parameter< const arma::mat& >::type X_pi(X_piSEXP); + Rcpp::traits::input_parameter< arma::cube& >::type eta_A(eta_ASEXP); + Rcpp::traits::input_parameter< const arma::cube& >::type X_A(X_ASEXP); + Rcpp::traits::input_parameter< arma::field& >::type eta_B(eta_BSEXP); + Rcpp::traits::input_parameter< const arma::cube& >::type X_B(X_BSEXP); Rcpp::traits::input_parameter< const arma::ucube& >::type obs(obsSEXP); - Rcpp::traits::input_parameter< const arma::umat& >::type ANZ(ANZSEXP); - Rcpp::traits::input_parameter< const arma::ucube& >::type BNZ(BNZSEXP); - Rcpp::traits::input_parameter< const arma::uvec& >::type INZ(INZSEXP); - Rcpp::traits::input_parameter< const arma::uvec& >::type nSymbols(nSymbolsSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type coef(coefSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type X(XSEXP); - Rcpp::traits::input_parameter< const arma::uvec& >::type numberOfStates(numberOfStatesSEXP); - Rcpp::traits::input_parameter< unsigned int >::type threads(threadsSEXP); - rcpp_result_gen = Rcpp::wrap(log_objectivex(transition, emission, init, obs, ANZ, BNZ, INZ, nSymbols, coef, X, numberOfStates, threads)); + Rcpp::traits::input_parameter< const bool >::type iv_pi(iv_piSEXP); + Rcpp::traits::input_parameter< const bool >::type iv_A(iv_ASEXP); + Rcpp::traits::input_parameter< const bool >::type iv_B(iv_BSEXP); + Rcpp::traits::input_parameter< const bool >::type tv_A(tv_ASEXP); + Rcpp::traits::input_parameter< const bool >::type tv_B(tv_BSEXP); + Rcpp::traits::input_parameter< const arma::uvec& >::type Ti(TiSEXP); + rcpp_result_gen = Rcpp::wrap(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)); return rcpp_result_gen; END_RCPP } -// objective -Rcpp::List objective(const arma::mat& transition, const arma::cube& emission, const arma::vec& init, arma::ucube& obs, const arma::umat& ANZ, const arma::ucube& BNZ, const arma::uvec& INZ, const arma::uvec& nSymbols, unsigned int threads); -RcppExport SEXP _seqHMM_objective(SEXP transitionSEXP, SEXP emissionSEXP, SEXP initSEXP, SEXP obsSEXP, SEXP ANZSEXP, SEXP BNZSEXP, SEXP INZSEXP, SEXP nSymbolsSEXP, SEXP threadsSEXP) { +// log_objective_mnhmm_singlechannel +Rcpp::List log_objective_mnhmm_singlechannel(arma::mat& eta_omega, const arma::mat& X_omega, arma::field& eta_pi, const arma::mat& X_pi, arma::field& eta_A, const arma::cube& X_A, arma::field& eta_B, const arma::cube& X_B, const arma::umat& obs, const bool iv_pi, const bool iv_A, const bool iv_B, const bool tv_A, const bool tv_B, const bool iv_omega, const arma::uvec& Ti); +RcppExport SEXP _seqHMM_log_objective_mnhmm_singlechannel(SEXP eta_omegaSEXP, SEXP X_omegaSEXP, SEXP eta_piSEXP, SEXP X_piSEXP, SEXP eta_ASEXP, SEXP X_ASEXP, SEXP eta_BSEXP, SEXP X_BSEXP, SEXP obsSEXP, SEXP iv_piSEXP, SEXP iv_ASEXP, SEXP iv_BSEXP, SEXP tv_ASEXP, SEXP tv_BSEXP, SEXP iv_omegaSEXP, SEXP TiSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::mat& >::type transition(transitionSEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type emission(emissionSEXP); - Rcpp::traits::input_parameter< const arma::vec& >::type init(initSEXP); - Rcpp::traits::input_parameter< arma::ucube& >::type obs(obsSEXP); - Rcpp::traits::input_parameter< const arma::umat& >::type ANZ(ANZSEXP); - Rcpp::traits::input_parameter< const arma::ucube& >::type BNZ(BNZSEXP); - Rcpp::traits::input_parameter< const arma::uvec& >::type INZ(INZSEXP); - Rcpp::traits::input_parameter< const arma::uvec& >::type nSymbols(nSymbolsSEXP); - Rcpp::traits::input_parameter< unsigned int >::type threads(threadsSEXP); - rcpp_result_gen = Rcpp::wrap(objective(transition, emission, init, obs, ANZ, BNZ, INZ, nSymbols, threads)); + Rcpp::traits::input_parameter< arma::mat& >::type eta_omega(eta_omegaSEXP); + Rcpp::traits::input_parameter< const arma::mat& >::type X_omega(X_omegaSEXP); + Rcpp::traits::input_parameter< arma::field& >::type eta_pi(eta_piSEXP); + Rcpp::traits::input_parameter< const arma::mat& >::type X_pi(X_piSEXP); + Rcpp::traits::input_parameter< arma::field& >::type eta_A(eta_ASEXP); + Rcpp::traits::input_parameter< const arma::cube& >::type X_A(X_ASEXP); + Rcpp::traits::input_parameter< arma::field& >::type eta_B(eta_BSEXP); + Rcpp::traits::input_parameter< const arma::cube& >::type X_B(X_BSEXP); + Rcpp::traits::input_parameter< const arma::umat& >::type obs(obsSEXP); + Rcpp::traits::input_parameter< const bool >::type iv_pi(iv_piSEXP); + Rcpp::traits::input_parameter< const bool >::type iv_A(iv_ASEXP); + Rcpp::traits::input_parameter< const bool >::type iv_B(iv_BSEXP); + Rcpp::traits::input_parameter< const bool >::type tv_A(tv_ASEXP); + Rcpp::traits::input_parameter< const bool >::type tv_B(tv_BSEXP); + Rcpp::traits::input_parameter< const bool >::type iv_omega(iv_omegaSEXP); + Rcpp::traits::input_parameter< const arma::uvec& >::type Ti(TiSEXP); + rcpp_result_gen = Rcpp::wrap(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)); return rcpp_result_gen; END_RCPP } -// objectivex -Rcpp::List objectivex(const arma::mat& transition, const arma::cube& emission, const arma::vec& init, const arma::ucube& obs, const arma::umat& ANZ, const arma::ucube& BNZ, const arma::uvec& INZ, const arma::uvec& nSymbols, const arma::mat& coef, const arma::mat& X, arma::uvec& numberOfStates, unsigned int threads); -RcppExport SEXP _seqHMM_objectivex(SEXP transitionSEXP, SEXP emissionSEXP, SEXP initSEXP, SEXP obsSEXP, SEXP ANZSEXP, SEXP BNZSEXP, SEXP INZSEXP, SEXP nSymbolsSEXP, SEXP coefSEXP, SEXP XSEXP, SEXP numberOfStatesSEXP, SEXP threadsSEXP) { +// log_objective_mnhmm_multichannel +Rcpp::List log_objective_mnhmm_multichannel(arma::mat& eta_omega, const arma::mat& X_omega, arma::field& eta_pi, const arma::mat& X_pi, arma::field& eta_A, const arma::cube& X_A, arma::field& eta_B, const arma::cube& X_B, const arma::ucube& obs, const bool iv_pi, const bool iv_A, const bool iv_B, const bool tv_A, const bool tv_B, const bool iv_omega, const arma::uvec& Ti); +RcppExport SEXP _seqHMM_log_objective_mnhmm_multichannel(SEXP eta_omegaSEXP, SEXP X_omegaSEXP, SEXP eta_piSEXP, SEXP X_piSEXP, SEXP eta_ASEXP, SEXP X_ASEXP, SEXP eta_BSEXP, SEXP X_BSEXP, SEXP obsSEXP, SEXP iv_piSEXP, SEXP iv_ASEXP, SEXP iv_BSEXP, SEXP tv_ASEXP, SEXP tv_BSEXP, SEXP iv_omegaSEXP, SEXP TiSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::mat& >::type transition(transitionSEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type emission(emissionSEXP); - Rcpp::traits::input_parameter< const arma::vec& >::type init(initSEXP); + Rcpp::traits::input_parameter< arma::mat& >::type eta_omega(eta_omegaSEXP); + Rcpp::traits::input_parameter< const arma::mat& >::type X_omega(X_omegaSEXP); + Rcpp::traits::input_parameter< arma::field& >::type eta_pi(eta_piSEXP); + Rcpp::traits::input_parameter< const arma::mat& >::type X_pi(X_piSEXP); + Rcpp::traits::input_parameter< arma::field& >::type eta_A(eta_ASEXP); + Rcpp::traits::input_parameter< const arma::cube& >::type X_A(X_ASEXP); + Rcpp::traits::input_parameter< arma::field& >::type eta_B(eta_BSEXP); + Rcpp::traits::input_parameter< const arma::cube& >::type X_B(X_BSEXP); Rcpp::traits::input_parameter< const arma::ucube& >::type obs(obsSEXP); - Rcpp::traits::input_parameter< const arma::umat& >::type ANZ(ANZSEXP); - Rcpp::traits::input_parameter< const arma::ucube& >::type BNZ(BNZSEXP); - Rcpp::traits::input_parameter< const arma::uvec& >::type INZ(INZSEXP); - Rcpp::traits::input_parameter< const arma::uvec& >::type nSymbols(nSymbolsSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type coef(coefSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type X(XSEXP); - Rcpp::traits::input_parameter< arma::uvec& >::type numberOfStates(numberOfStatesSEXP); - Rcpp::traits::input_parameter< unsigned int >::type threads(threadsSEXP); - rcpp_result_gen = Rcpp::wrap(objectivex(transition, emission, init, obs, ANZ, BNZ, INZ, nSymbols, coef, X, numberOfStates, threads)); + Rcpp::traits::input_parameter< const bool >::type iv_pi(iv_piSEXP); + Rcpp::traits::input_parameter< const bool >::type iv_A(iv_ASEXP); + Rcpp::traits::input_parameter< const bool >::type iv_B(iv_BSEXP); + Rcpp::traits::input_parameter< const bool >::type tv_A(tv_ASEXP); + Rcpp::traits::input_parameter< const bool >::type tv_B(tv_BSEXP); + Rcpp::traits::input_parameter< const bool >::type iv_omega(iv_omegaSEXP); + Rcpp::traits::input_parameter< const arma::uvec& >::type Ti(TiSEXP); + rcpp_result_gen = Rcpp::wrap(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)); return rcpp_result_gen; END_RCPP } // simulate_nhmm_singlechannel -Rcpp::List simulate_nhmm_singlechannel(const arma::mat& eta_pi, const arma::mat& X_i, const arma::cube& eta_A, const arma::cube& X_s, const arma::cube& eta_B, const arma::cube& X_o); -RcppExport SEXP _seqHMM_simulate_nhmm_singlechannel(SEXP eta_piSEXP, SEXP X_iSEXP, SEXP eta_ASEXP, SEXP X_sSEXP, SEXP eta_BSEXP, SEXP X_oSEXP) { +Rcpp::List simulate_nhmm_singlechannel(const arma::mat& eta_pi, const arma::mat& X_pi, const arma::cube& eta_A, const arma::cube& X_A, const arma::cube& eta_B, const arma::cube& X_B); +RcppExport SEXP _seqHMM_simulate_nhmm_singlechannel(SEXP eta_piSEXP, SEXP X_piSEXP, SEXP eta_ASEXP, SEXP X_ASEXP, SEXP eta_BSEXP, SEXP X_BSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< const arma::mat& >::type eta_pi(eta_piSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type X_i(X_iSEXP); + Rcpp::traits::input_parameter< const arma::mat& >::type X_pi(X_piSEXP); Rcpp::traits::input_parameter< const arma::cube& >::type eta_A(eta_ASEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type X_s(X_sSEXP); + Rcpp::traits::input_parameter< const arma::cube& >::type X_A(X_ASEXP); Rcpp::traits::input_parameter< const arma::cube& >::type eta_B(eta_BSEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type X_o(X_oSEXP); - rcpp_result_gen = Rcpp::wrap(simulate_nhmm_singlechannel(eta_pi, X_i, eta_A, X_s, eta_B, X_o)); + Rcpp::traits::input_parameter< const arma::cube& >::type X_B(X_BSEXP); + rcpp_result_gen = Rcpp::wrap(simulate_nhmm_singlechannel(eta_pi, X_pi, eta_A, X_A, eta_B, X_B)); return rcpp_result_gen; END_RCPP } // simulate_nhmm_multichannel -Rcpp::List simulate_nhmm_multichannel(const arma::mat& eta_pi, const arma::mat& X_i, const arma::cube& eta_A, const arma::cube& X_s, const arma::field& eta_B, const arma::cube& X_o, const arma::uvec& M); -RcppExport SEXP _seqHMM_simulate_nhmm_multichannel(SEXP eta_piSEXP, SEXP X_iSEXP, SEXP eta_ASEXP, SEXP X_sSEXP, SEXP eta_BSEXP, SEXP X_oSEXP, SEXP MSEXP) { +Rcpp::List simulate_nhmm_multichannel(const arma::mat& eta_pi, const arma::mat& X_pi, const arma::cube& eta_A, const arma::cube& X_A, const arma::field& eta_B, const arma::cube& X_B, const arma::uvec& M); +RcppExport SEXP _seqHMM_simulate_nhmm_multichannel(SEXP eta_piSEXP, SEXP X_piSEXP, SEXP eta_ASEXP, SEXP X_ASEXP, SEXP eta_BSEXP, SEXP X_BSEXP, SEXP MSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< const arma::mat& >::type eta_pi(eta_piSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type X_i(X_iSEXP); + Rcpp::traits::input_parameter< const arma::mat& >::type X_pi(X_piSEXP); Rcpp::traits::input_parameter< const arma::cube& >::type eta_A(eta_ASEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type X_s(X_sSEXP); + Rcpp::traits::input_parameter< const arma::cube& >::type X_A(X_ASEXP); Rcpp::traits::input_parameter< const arma::field& >::type eta_B(eta_BSEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type X_o(X_oSEXP); + Rcpp::traits::input_parameter< const arma::cube& >::type X_B(X_BSEXP); Rcpp::traits::input_parameter< const arma::uvec& >::type M(MSEXP); - rcpp_result_gen = Rcpp::wrap(simulate_nhmm_multichannel(eta_pi, X_i, eta_A, X_s, eta_B, X_o, M)); + rcpp_result_gen = Rcpp::wrap(simulate_nhmm_multichannel(eta_pi, X_pi, eta_A, X_A, eta_B, X_B, M)); return rcpp_result_gen; END_RCPP } // simulate_mnhmm_singlechannel -Rcpp::List simulate_mnhmm_singlechannel(const arma::field& eta_pi, const arma::mat& X_i, const arma::field& eta_A, const arma::cube& X_s, const arma::field& eta_B, const arma::cube& X_o, const arma::mat& eta_omega, const arma::mat& X_d); -RcppExport SEXP _seqHMM_simulate_mnhmm_singlechannel(SEXP eta_piSEXP, SEXP X_iSEXP, SEXP eta_ASEXP, SEXP X_sSEXP, SEXP eta_BSEXP, SEXP X_oSEXP, SEXP eta_omegaSEXP, SEXP X_dSEXP) { +Rcpp::List simulate_mnhmm_singlechannel(const arma::field& eta_pi, const arma::mat& X_pi, const arma::field& eta_A, const arma::cube& X_A, const arma::field& eta_B, const arma::cube& X_B, const arma::mat& eta_omega, const arma::mat& X_omega); +RcppExport SEXP _seqHMM_simulate_mnhmm_singlechannel(SEXP eta_piSEXP, SEXP X_piSEXP, SEXP eta_ASEXP, SEXP X_ASEXP, SEXP eta_BSEXP, SEXP X_BSEXP, SEXP eta_omegaSEXP, SEXP X_omegaSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< const arma::field& >::type eta_pi(eta_piSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type X_i(X_iSEXP); + Rcpp::traits::input_parameter< const arma::mat& >::type X_pi(X_piSEXP); Rcpp::traits::input_parameter< const arma::field& >::type eta_A(eta_ASEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type X_s(X_sSEXP); + Rcpp::traits::input_parameter< const arma::cube& >::type X_A(X_ASEXP); Rcpp::traits::input_parameter< const arma::field& >::type eta_B(eta_BSEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type X_o(X_oSEXP); + Rcpp::traits::input_parameter< const arma::cube& >::type X_B(X_BSEXP); Rcpp::traits::input_parameter< const arma::mat& >::type eta_omega(eta_omegaSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type X_d(X_dSEXP); - rcpp_result_gen = Rcpp::wrap(simulate_mnhmm_singlechannel(eta_pi, X_i, eta_A, X_s, eta_B, X_o, eta_omega, X_d)); + Rcpp::traits::input_parameter< const arma::mat& >::type X_omega(X_omegaSEXP); + rcpp_result_gen = Rcpp::wrap(simulate_mnhmm_singlechannel(eta_pi, X_pi, eta_A, X_A, eta_B, X_B, eta_omega, X_omega)); return rcpp_result_gen; END_RCPP } // simulate_mnhmm_multichannel -Rcpp::List simulate_mnhmm_multichannel(const arma::field& eta_pi, const arma::mat& X_i, const arma::field& eta_A, const arma::cube& X_s, const arma::field& eta_B, const arma::cube& X_o, const arma::mat& eta_omega, const arma::mat& X_d, const arma::uvec& M); -RcppExport SEXP _seqHMM_simulate_mnhmm_multichannel(SEXP eta_piSEXP, SEXP X_iSEXP, SEXP eta_ASEXP, SEXP X_sSEXP, SEXP eta_BSEXP, SEXP X_oSEXP, SEXP eta_omegaSEXP, SEXP X_dSEXP, SEXP MSEXP) { +Rcpp::List simulate_mnhmm_multichannel(const arma::field& eta_pi, const arma::mat& X_pi, const arma::field& eta_A, const arma::cube& X_A, const arma::field& eta_B, const arma::cube& X_B, const arma::mat& eta_omega, const arma::mat& X_omega, const arma::uvec& M); +RcppExport SEXP _seqHMM_simulate_mnhmm_multichannel(SEXP eta_piSEXP, SEXP X_piSEXP, SEXP eta_ASEXP, SEXP X_ASEXP, SEXP eta_BSEXP, SEXP X_BSEXP, SEXP eta_omegaSEXP, SEXP X_omegaSEXP, SEXP MSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< const arma::field& >::type eta_pi(eta_piSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type X_i(X_iSEXP); + Rcpp::traits::input_parameter< const arma::mat& >::type X_pi(X_piSEXP); Rcpp::traits::input_parameter< const arma::field& >::type eta_A(eta_ASEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type X_s(X_sSEXP); + Rcpp::traits::input_parameter< const arma::cube& >::type X_A(X_ASEXP); Rcpp::traits::input_parameter< const arma::field& >::type eta_B(eta_BSEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type X_o(X_oSEXP); + Rcpp::traits::input_parameter< const arma::cube& >::type X_B(X_BSEXP); Rcpp::traits::input_parameter< const arma::mat& >::type eta_omega(eta_omegaSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type X_d(X_dSEXP); + Rcpp::traits::input_parameter< const arma::mat& >::type X_omega(X_omegaSEXP); Rcpp::traits::input_parameter< const arma::uvec& >::type M(MSEXP); - rcpp_result_gen = Rcpp::wrap(simulate_mnhmm_multichannel(eta_pi, X_i, eta_A, X_s, eta_B, X_o, eta_omega, X_d, M)); + rcpp_result_gen = Rcpp::wrap(simulate_mnhmm_multichannel(eta_pi, X_pi, eta_A, X_A, eta_B, X_B, eta_omega, X_omega, M)); return rcpp_result_gen; END_RCPP } -// softmax -arma::vec softmax(const arma::vec& x); -RcppExport SEXP _seqHMM_softmax(SEXP xSEXP) { +// viterbi_nhmm_singlechannel +Rcpp::List viterbi_nhmm_singlechannel(arma::mat& eta_pi, const arma::mat& X_pi, arma::cube& eta_A, const arma::cube& X_A, arma::cube& eta_B, const arma::cube& X_B, const arma::umat& obs, const arma::uvec Ti, const bool iv_pi, const bool iv_A, const bool iv_B, const bool tv_A, const bool tv_B); +RcppExport SEXP _seqHMM_viterbi_nhmm_singlechannel(SEXP eta_piSEXP, SEXP X_piSEXP, SEXP eta_ASEXP, SEXP X_ASEXP, SEXP eta_BSEXP, SEXP X_BSEXP, SEXP obsSEXP, SEXP TiSEXP, SEXP iv_piSEXP, SEXP iv_ASEXP, SEXP iv_BSEXP, SEXP tv_ASEXP, SEXP tv_BSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::vec& >::type x(xSEXP); - rcpp_result_gen = Rcpp::wrap(softmax(x)); + Rcpp::traits::input_parameter< arma::mat& >::type eta_pi(eta_piSEXP); + Rcpp::traits::input_parameter< const arma::mat& >::type X_pi(X_piSEXP); + Rcpp::traits::input_parameter< arma::cube& >::type eta_A(eta_ASEXP); + Rcpp::traits::input_parameter< const arma::cube& >::type X_A(X_ASEXP); + Rcpp::traits::input_parameter< arma::cube& >::type eta_B(eta_BSEXP); + Rcpp::traits::input_parameter< const arma::cube& >::type X_B(X_BSEXP); + Rcpp::traits::input_parameter< const arma::umat& >::type obs(obsSEXP); + Rcpp::traits::input_parameter< const arma::uvec >::type Ti(TiSEXP); + Rcpp::traits::input_parameter< const bool >::type iv_pi(iv_piSEXP); + Rcpp::traits::input_parameter< const bool >::type iv_A(iv_ASEXP); + Rcpp::traits::input_parameter< const bool >::type iv_B(iv_BSEXP); + Rcpp::traits::input_parameter< const bool >::type tv_A(tv_ASEXP); + Rcpp::traits::input_parameter< const bool >::type tv_B(tv_BSEXP); + rcpp_result_gen = Rcpp::wrap(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)); return rcpp_result_gen; END_RCPP } -// varcoef -Rcpp::NumericMatrix varcoef(const arma::mat& coef, const arma::mat& X); -RcppExport SEXP _seqHMM_varcoef(SEXP coefSEXP, SEXP XSEXP) { +// viterbi_nhmm_multichannel +Rcpp::List viterbi_nhmm_multichannel(arma::mat& eta_pi, const arma::mat& X_pi, arma::cube& eta_A, const arma::cube& X_A, arma::field& eta_B, const arma::cube& X_B, const arma::ucube& obs, const arma::uvec Ti, const bool iv_pi, const bool iv_A, const bool iv_B, const bool tv_A, const bool tv_B); +RcppExport SEXP _seqHMM_viterbi_nhmm_multichannel(SEXP eta_piSEXP, SEXP X_piSEXP, SEXP eta_ASEXP, SEXP X_ASEXP, SEXP eta_BSEXP, SEXP X_BSEXP, SEXP obsSEXP, SEXP TiSEXP, SEXP iv_piSEXP, SEXP iv_ASEXP, SEXP iv_BSEXP, SEXP tv_ASEXP, SEXP tv_BSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::mat& >::type coef(coefSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type X(XSEXP); - rcpp_result_gen = Rcpp::wrap(varcoef(coef, X)); + Rcpp::traits::input_parameter< arma::mat& >::type eta_pi(eta_piSEXP); + Rcpp::traits::input_parameter< const arma::mat& >::type X_pi(X_piSEXP); + Rcpp::traits::input_parameter< arma::cube& >::type eta_A(eta_ASEXP); + Rcpp::traits::input_parameter< const arma::cube& >::type X_A(X_ASEXP); + Rcpp::traits::input_parameter< arma::field& >::type eta_B(eta_BSEXP); + Rcpp::traits::input_parameter< const arma::cube& >::type X_B(X_BSEXP); + Rcpp::traits::input_parameter< const arma::ucube& >::type obs(obsSEXP); + Rcpp::traits::input_parameter< const arma::uvec >::type Ti(TiSEXP); + Rcpp::traits::input_parameter< const bool >::type iv_pi(iv_piSEXP); + Rcpp::traits::input_parameter< const bool >::type iv_A(iv_ASEXP); + Rcpp::traits::input_parameter< const bool >::type iv_B(iv_BSEXP); + Rcpp::traits::input_parameter< const bool >::type tv_A(tv_ASEXP); + Rcpp::traits::input_parameter< const bool >::type tv_B(tv_BSEXP); + rcpp_result_gen = Rcpp::wrap(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)); return rcpp_result_gen; END_RCPP } -// viterbi -Rcpp::List viterbi(const arma::mat& transition, const arma::cube& emission, const arma::vec& init, const arma::ucube& obs); -RcppExport SEXP _seqHMM_viterbi(SEXP transitionSEXP, SEXP emissionSEXP, SEXP initSEXP, SEXP obsSEXP) { +// viterbi_mnhmm_singlechannel +Rcpp::List viterbi_mnhmm_singlechannel(arma::mat& eta_omega, const arma::mat& X_omega, arma::field& eta_pi, const arma::mat& X_pi, arma::field& eta_A, const arma::cube& X_A, arma::field& eta_B, const arma::cube& X_B, const arma::umat& obs, const arma::uvec Ti, const bool iv_omega, const bool iv_pi, const bool iv_A, const bool iv_B, const bool tv_A, const bool tv_B); +RcppExport SEXP _seqHMM_viterbi_mnhmm_singlechannel(SEXP eta_omegaSEXP, SEXP X_omegaSEXP, SEXP eta_piSEXP, SEXP X_piSEXP, SEXP eta_ASEXP, SEXP X_ASEXP, SEXP eta_BSEXP, SEXP X_BSEXP, SEXP obsSEXP, SEXP TiSEXP, SEXP iv_omegaSEXP, SEXP iv_piSEXP, SEXP iv_ASEXP, SEXP iv_BSEXP, SEXP tv_ASEXP, SEXP tv_BSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< arma::mat& >::type eta_omega(eta_omegaSEXP); + Rcpp::traits::input_parameter< const arma::mat& >::type X_omega(X_omegaSEXP); + Rcpp::traits::input_parameter< arma::field& >::type eta_pi(eta_piSEXP); + Rcpp::traits::input_parameter< const arma::mat& >::type X_pi(X_piSEXP); + Rcpp::traits::input_parameter< arma::field& >::type eta_A(eta_ASEXP); + Rcpp::traits::input_parameter< const arma::cube& >::type X_A(X_ASEXP); + Rcpp::traits::input_parameter< arma::field& >::type eta_B(eta_BSEXP); + Rcpp::traits::input_parameter< const arma::cube& >::type X_B(X_BSEXP); + Rcpp::traits::input_parameter< const arma::umat& >::type obs(obsSEXP); + Rcpp::traits::input_parameter< const arma::uvec >::type Ti(TiSEXP); + Rcpp::traits::input_parameter< const bool >::type iv_omega(iv_omegaSEXP); + Rcpp::traits::input_parameter< const bool >::type iv_pi(iv_piSEXP); + Rcpp::traits::input_parameter< const bool >::type iv_A(iv_ASEXP); + Rcpp::traits::input_parameter< const bool >::type iv_B(iv_BSEXP); + Rcpp::traits::input_parameter< const bool >::type tv_A(tv_ASEXP); + Rcpp::traits::input_parameter< const bool >::type tv_B(tv_BSEXP); + rcpp_result_gen = Rcpp::wrap(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)); + return rcpp_result_gen; +END_RCPP +} +// viterbi_mnhmm_multichannel +Rcpp::List viterbi_mnhmm_multichannel(arma::mat& eta_omega, const arma::mat& X_omega, arma::field& eta_pi, const arma::mat& X_pi, arma::field& eta_A, const arma::cube& X_A, arma::field& eta_B, const arma::cube& X_B, const arma::ucube& obs, const arma::uvec Ti, const bool iv_omega, const bool iv_pi, const bool iv_A, const bool iv_B, const bool tv_A, const bool tv_B); +RcppExport SEXP _seqHMM_viterbi_mnhmm_multichannel(SEXP eta_omegaSEXP, SEXP X_omegaSEXP, SEXP eta_piSEXP, SEXP X_piSEXP, SEXP eta_ASEXP, SEXP X_ASEXP, SEXP eta_BSEXP, SEXP X_BSEXP, SEXP obsSEXP, SEXP TiSEXP, SEXP iv_omegaSEXP, SEXP iv_piSEXP, SEXP iv_ASEXP, SEXP iv_BSEXP, SEXP tv_ASEXP, SEXP tv_BSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< arma::mat& >::type eta_omega(eta_omegaSEXP); + Rcpp::traits::input_parameter< const arma::mat& >::type X_omega(X_omegaSEXP); + Rcpp::traits::input_parameter< arma::field& >::type eta_pi(eta_piSEXP); + Rcpp::traits::input_parameter< const arma::mat& >::type X_pi(X_piSEXP); + Rcpp::traits::input_parameter< arma::field& >::type eta_A(eta_ASEXP); + Rcpp::traits::input_parameter< const arma::cube& >::type X_A(X_ASEXP); + Rcpp::traits::input_parameter< arma::field& >::type eta_B(eta_BSEXP); + Rcpp::traits::input_parameter< const arma::cube& >::type X_B(X_BSEXP); + Rcpp::traits::input_parameter< const arma::ucube& >::type obs(obsSEXP); + Rcpp::traits::input_parameter< const arma::uvec >::type Ti(TiSEXP); + Rcpp::traits::input_parameter< const bool >::type iv_omega(iv_omegaSEXP); + Rcpp::traits::input_parameter< const bool >::type iv_pi(iv_piSEXP); + Rcpp::traits::input_parameter< const bool >::type iv_A(iv_ASEXP); + Rcpp::traits::input_parameter< const bool >::type iv_B(iv_BSEXP); + Rcpp::traits::input_parameter< const bool >::type tv_A(tv_ASEXP); + Rcpp::traits::input_parameter< const bool >::type tv_B(tv_BSEXP); + rcpp_result_gen = Rcpp::wrap(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)); + return rcpp_result_gen; +END_RCPP +} +// objective +Rcpp::List objective(const arma::mat& transition, const arma::cube& emission, const arma::vec& init, arma::ucube& obs, const arma::umat& ANZ, const arma::ucube& BNZ, const arma::uvec& INZ, const arma::uvec& nSymbols, arma::uword threads); +RcppExport SEXP _seqHMM_objective(SEXP transitionSEXP, SEXP emissionSEXP, SEXP initSEXP, SEXP obsSEXP, SEXP ANZSEXP, SEXP BNZSEXP, SEXP INZSEXP, SEXP nSymbolsSEXP, SEXP threadsSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< const arma::mat& >::type transition(transitionSEXP); Rcpp::traits::input_parameter< const arma::cube& >::type emission(emissionSEXP); Rcpp::traits::input_parameter< const arma::vec& >::type init(initSEXP); - Rcpp::traits::input_parameter< const arma::ucube& >::type obs(obsSEXP); - rcpp_result_gen = Rcpp::wrap(viterbi(transition, emission, init, obs)); + Rcpp::traits::input_parameter< arma::ucube& >::type obs(obsSEXP); + Rcpp::traits::input_parameter< const arma::umat& >::type ANZ(ANZSEXP); + Rcpp::traits::input_parameter< const arma::ucube& >::type BNZ(BNZSEXP); + Rcpp::traits::input_parameter< const arma::uvec& >::type INZ(INZSEXP); + Rcpp::traits::input_parameter< const arma::uvec& >::type nSymbols(nSymbolsSEXP); + Rcpp::traits::input_parameter< arma::uword >::type threads(threadsSEXP); + rcpp_result_gen = Rcpp::wrap(objective(transition, emission, init, obs, ANZ, BNZ, INZ, nSymbols, threads)); return rcpp_result_gen; END_RCPP } -// viterbi_nhmm_singlechannel -Rcpp::List viterbi_nhmm_singlechannel(const arma::mat& eta_pi, const arma::mat& X_i, const arma::cube& eta_A, const arma::cube& X_s, const arma::cube& eta_B, const arma::cube& X_o, const arma::umat& obs); -RcppExport SEXP _seqHMM_viterbi_nhmm_singlechannel(SEXP eta_piSEXP, SEXP X_iSEXP, SEXP eta_ASEXP, SEXP X_sSEXP, SEXP eta_BSEXP, SEXP X_oSEXP, SEXP obsSEXP) { +// objectivex +Rcpp::List objectivex(const arma::mat& transition, const arma::cube& emission, const arma::vec& init, const arma::ucube& obs, const arma::umat& ANZ, const arma::ucube& BNZ, const arma::uvec& INZ, const arma::uvec& nSymbols, const arma::mat& coef, const arma::mat& X, arma::uvec& numberOfStates, arma::uword threads); +RcppExport SEXP _seqHMM_objectivex(SEXP transitionSEXP, SEXP emissionSEXP, SEXP initSEXP, SEXP obsSEXP, SEXP ANZSEXP, SEXP BNZSEXP, SEXP INZSEXP, SEXP nSymbolsSEXP, SEXP coefSEXP, SEXP XSEXP, SEXP numberOfStatesSEXP, SEXP threadsSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::mat& >::type eta_pi(eta_piSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type X_i(X_iSEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type eta_A(eta_ASEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type X_s(X_sSEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type eta_B(eta_BSEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type X_o(X_oSEXP); - Rcpp::traits::input_parameter< const arma::umat& >::type obs(obsSEXP); - rcpp_result_gen = Rcpp::wrap(viterbi_nhmm_singlechannel(eta_pi, X_i, eta_A, X_s, eta_B, X_o, obs)); + Rcpp::traits::input_parameter< const arma::mat& >::type transition(transitionSEXP); + Rcpp::traits::input_parameter< const arma::cube& >::type emission(emissionSEXP); + Rcpp::traits::input_parameter< const arma::vec& >::type init(initSEXP); + Rcpp::traits::input_parameter< const arma::ucube& >::type obs(obsSEXP); + Rcpp::traits::input_parameter< const arma::umat& >::type ANZ(ANZSEXP); + Rcpp::traits::input_parameter< const arma::ucube& >::type BNZ(BNZSEXP); + Rcpp::traits::input_parameter< const arma::uvec& >::type INZ(INZSEXP); + Rcpp::traits::input_parameter< const arma::uvec& >::type nSymbols(nSymbolsSEXP); + Rcpp::traits::input_parameter< const arma::mat& >::type coef(coefSEXP); + Rcpp::traits::input_parameter< const arma::mat& >::type X(XSEXP); + Rcpp::traits::input_parameter< arma::uvec& >::type numberOfStates(numberOfStatesSEXP); + Rcpp::traits::input_parameter< arma::uword >::type threads(threadsSEXP); + rcpp_result_gen = Rcpp::wrap(objectivex(transition, emission, init, obs, ANZ, BNZ, INZ, nSymbols, coef, X, numberOfStates, threads)); return rcpp_result_gen; END_RCPP } -// viterbi_nhmm_multichannel -Rcpp::List viterbi_nhmm_multichannel(const arma::mat& eta_pi, const arma::mat& X_i, const arma::cube& eta_A, const arma::cube& X_s, const arma::field& eta_B, const arma::cube& X_o, const arma::ucube& obs, const arma::uvec M); -RcppExport SEXP _seqHMM_viterbi_nhmm_multichannel(SEXP eta_piSEXP, SEXP X_iSEXP, SEXP eta_ASEXP, SEXP X_sSEXP, SEXP eta_BSEXP, SEXP X_oSEXP, SEXP obsSEXP, SEXP MSEXP) { +// softmax +arma::vec softmax(const arma::vec& x); +RcppExport SEXP _seqHMM_softmax(SEXP xSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::mat& >::type eta_pi(eta_piSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type X_i(X_iSEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type eta_A(eta_ASEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type X_s(X_sSEXP); - Rcpp::traits::input_parameter< const arma::field& >::type eta_B(eta_BSEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type X_o(X_oSEXP); - Rcpp::traits::input_parameter< const arma::ucube& >::type obs(obsSEXP); - Rcpp::traits::input_parameter< const arma::uvec >::type M(MSEXP); - rcpp_result_gen = Rcpp::wrap(viterbi_nhmm_multichannel(eta_pi, X_i, eta_A, X_s, eta_B, X_o, obs, M)); + Rcpp::traits::input_parameter< const arma::vec& >::type x(xSEXP); + rcpp_result_gen = Rcpp::wrap(softmax(x)); return rcpp_result_gen; END_RCPP } -// viterbi_mnhmm_singlechannel -Rcpp::List viterbi_mnhmm_singlechannel(const arma::field& eta_pi, const arma::mat& X_i, const arma::field& eta_A, const arma::cube& X_s, const arma::field& eta_B, const arma::cube& X_o, const arma::mat& eta_omega, const arma::mat& X_d, const arma::umat& obs); -RcppExport SEXP _seqHMM_viterbi_mnhmm_singlechannel(SEXP eta_piSEXP, SEXP X_iSEXP, SEXP eta_ASEXP, SEXP X_sSEXP, SEXP eta_BSEXP, SEXP X_oSEXP, SEXP eta_omegaSEXP, SEXP X_dSEXP, SEXP obsSEXP) { +// varcoef +Rcpp::NumericMatrix varcoef(const arma::mat& coef, const arma::mat& X); +RcppExport SEXP _seqHMM_varcoef(SEXP coefSEXP, SEXP XSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::field& >::type eta_pi(eta_piSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type X_i(X_iSEXP); - Rcpp::traits::input_parameter< const arma::field& >::type eta_A(eta_ASEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type X_s(X_sSEXP); - Rcpp::traits::input_parameter< const arma::field& >::type eta_B(eta_BSEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type X_o(X_oSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type eta_omega(eta_omegaSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type X_d(X_dSEXP); - Rcpp::traits::input_parameter< const arma::umat& >::type obs(obsSEXP); - rcpp_result_gen = Rcpp::wrap(viterbi_mnhmm_singlechannel(eta_pi, X_i, eta_A, X_s, eta_B, X_o, eta_omega, X_d, obs)); + Rcpp::traits::input_parameter< const arma::mat& >::type coef(coefSEXP); + Rcpp::traits::input_parameter< const arma::mat& >::type X(XSEXP); + rcpp_result_gen = Rcpp::wrap(varcoef(coef, X)); return rcpp_result_gen; END_RCPP } -// viterbi_mnhmm_multichannel -Rcpp::List viterbi_mnhmm_multichannel(const arma::field& eta_pi, const arma::mat& X_i, const arma::field& eta_A, const arma::cube& X_s, const arma::field& eta_B, const arma::cube& X_o, const arma::mat& eta_omega, const arma::mat& X_d, const arma::ucube& obs, const arma::uvec M); -RcppExport SEXP _seqHMM_viterbi_mnhmm_multichannel(SEXP eta_piSEXP, SEXP X_iSEXP, SEXP eta_ASEXP, SEXP X_sSEXP, SEXP eta_BSEXP, SEXP X_oSEXP, SEXP eta_omegaSEXP, SEXP X_dSEXP, SEXP obsSEXP, SEXP MSEXP) { +// viterbi +Rcpp::List viterbi(const arma::mat& transition, const arma::cube& emission, const arma::vec& init, const arma::ucube& obs); +RcppExport SEXP _seqHMM_viterbi(SEXP transitionSEXP, SEXP emissionSEXP, SEXP initSEXP, SEXP obsSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::field& >::type eta_pi(eta_piSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type X_i(X_iSEXP); - Rcpp::traits::input_parameter< const arma::field& >::type eta_A(eta_ASEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type X_s(X_sSEXP); - Rcpp::traits::input_parameter< const arma::field& >::type eta_B(eta_BSEXP); - Rcpp::traits::input_parameter< const arma::cube& >::type X_o(X_oSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type eta_omega(eta_omegaSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type X_d(X_dSEXP); + Rcpp::traits::input_parameter< const arma::mat& >::type transition(transitionSEXP); + Rcpp::traits::input_parameter< const arma::cube& >::type emission(emissionSEXP); + Rcpp::traits::input_parameter< const arma::vec& >::type init(initSEXP); Rcpp::traits::input_parameter< const arma::ucube& >::type obs(obsSEXP); - Rcpp::traits::input_parameter< const arma::uvec >::type M(MSEXP); - rcpp_result_gen = Rcpp::wrap(viterbi_mnhmm_multichannel(eta_pi, X_i, eta_A, X_s, eta_B, X_o, eta_omega, X_d, obs, M)); + rcpp_result_gen = Rcpp::wrap(viterbi(transition, emission, init, obs)); return rcpp_result_gen; END_RCPP } @@ -1145,10 +1217,6 @@ END_RCPP static const R_CallMethodDef CallEntries[] = { {"_seqHMM_EM", (DL_FUNC) &_seqHMM_EM, 9}, {"_seqHMM_EMx", (DL_FUNC) &_seqHMM_EMx, 12}, - {"_seqHMM_backward_nhmm_singlechannel", (DL_FUNC) &_seqHMM_backward_nhmm_singlechannel, 5}, - {"_seqHMM_backward_nhmm_multichannel", (DL_FUNC) &_seqHMM_backward_nhmm_multichannel, 6}, - {"_seqHMM_backward_mnhmm_singlechannel", (DL_FUNC) &_seqHMM_backward_mnhmm_singlechannel, 5}, - {"_seqHMM_backward_mnhmm_multichannel", (DL_FUNC) &_seqHMM_backward_mnhmm_multichannel, 6}, {"_seqHMM_cost_matrix_singlechannel", (DL_FUNC) &_seqHMM_cost_matrix_singlechannel, 6}, {"_seqHMM_cost_matrix_multichannel", (DL_FUNC) &_seqHMM_cost_matrix_multichannel, 6}, {"_seqHMM_cost_matrix_clusters", (DL_FUNC) &_seqHMM_cost_matrix_clusters, 2}, @@ -1158,10 +1226,6 @@ static const R_CallMethodDef CallEntries[] = { {"_seqHMM_eta_to_gamma_mat_field", (DL_FUNC) &_seqHMM_eta_to_gamma_mat_field, 1}, {"_seqHMM_eta_to_gamma_cube_field", (DL_FUNC) &_seqHMM_eta_to_gamma_cube_field, 1}, {"_seqHMM_fast_quantiles", (DL_FUNC) &_seqHMM_fast_quantiles, 2}, - {"_seqHMM_forward_nhmm_singlechannel", (DL_FUNC) &_seqHMM_forward_nhmm_singlechannel, 7}, - {"_seqHMM_forward_nhmm_multichannel", (DL_FUNC) &_seqHMM_forward_nhmm_multichannel, 8}, - {"_seqHMM_forward_mnhmm_singlechannel", (DL_FUNC) &_seqHMM_forward_mnhmm_singlechannel, 9}, - {"_seqHMM_forward_mnhmm_multichannel", (DL_FUNC) &_seqHMM_forward_mnhmm_multichannel, 10}, {"_seqHMM_forwardbackward", (DL_FUNC) &_seqHMM_forwardbackward, 6}, {"_seqHMM_forwardbackwardx", (DL_FUNC) &_seqHMM_forwardbackwardx, 9}, {"_seqHMM_get_omega", (DL_FUNC) &_seqHMM_get_omega, 2}, @@ -1194,24 +1258,32 @@ static const R_CallMethodDef CallEntries[] = { {"_seqHMM_log_logLikHMM", (DL_FUNC) &_seqHMM_log_logLikHMM, 5}, {"_seqHMM_log_logLikMixHMM", (DL_FUNC) &_seqHMM_log_logLikMixHMM, 8}, {"_seqHMM_log_objective", (DL_FUNC) &_seqHMM_log_objective, 9}, - {"_seqHMM_log_objective_nhmm_singlechannel", (DL_FUNC) &_seqHMM_log_objective_nhmm_singlechannel, 15}, - {"_seqHMM_log_objective_nhmm_multichannel", (DL_FUNC) &_seqHMM_log_objective_nhmm_multichannel, 16}, - {"_seqHMM_log_objective_mnhmm_singlechannel", (DL_FUNC) &_seqHMM_log_objective_mnhmm_singlechannel, 19}, - {"_seqHMM_log_objective_mnhmm_multichannel", (DL_FUNC) &_seqHMM_log_objective_mnhmm_multichannel, 20}, {"_seqHMM_log_objectivex", (DL_FUNC) &_seqHMM_log_objectivex, 12}, - {"_seqHMM_objective", (DL_FUNC) &_seqHMM_objective, 9}, - {"_seqHMM_objectivex", (DL_FUNC) &_seqHMM_objectivex, 12}, + {"_seqHMM_backward_nhmm_singlechannel", (DL_FUNC) &_seqHMM_backward_nhmm_singlechannel, 13}, + {"_seqHMM_backward_nhmm_multichannel", (DL_FUNC) &_seqHMM_backward_nhmm_multichannel, 13}, + {"_seqHMM_backward_mnhmm_singlechannel", (DL_FUNC) &_seqHMM_backward_mnhmm_singlechannel, 16}, + {"_seqHMM_backward_mnhmm_multichannel", (DL_FUNC) &_seqHMM_backward_mnhmm_multichannel, 16}, + {"_seqHMM_forward_nhmm_singlechannel", (DL_FUNC) &_seqHMM_forward_nhmm_singlechannel, 13}, + {"_seqHMM_forward_nhmm_multichannel", (DL_FUNC) &_seqHMM_forward_nhmm_multichannel, 13}, + {"_seqHMM_forward_mnhmm_singlechannel", (DL_FUNC) &_seqHMM_forward_mnhmm_singlechannel, 16}, + {"_seqHMM_forward_mnhmm_multichannel", (DL_FUNC) &_seqHMM_forward_mnhmm_multichannel, 16}, + {"_seqHMM_log_objective_nhmm_singlechannel", (DL_FUNC) &_seqHMM_log_objective_nhmm_singlechannel, 13}, + {"_seqHMM_log_objective_nhmm_multichannel", (DL_FUNC) &_seqHMM_log_objective_nhmm_multichannel, 13}, + {"_seqHMM_log_objective_mnhmm_singlechannel", (DL_FUNC) &_seqHMM_log_objective_mnhmm_singlechannel, 16}, + {"_seqHMM_log_objective_mnhmm_multichannel", (DL_FUNC) &_seqHMM_log_objective_mnhmm_multichannel, 16}, {"_seqHMM_simulate_nhmm_singlechannel", (DL_FUNC) &_seqHMM_simulate_nhmm_singlechannel, 6}, {"_seqHMM_simulate_nhmm_multichannel", (DL_FUNC) &_seqHMM_simulate_nhmm_multichannel, 7}, {"_seqHMM_simulate_mnhmm_singlechannel", (DL_FUNC) &_seqHMM_simulate_mnhmm_singlechannel, 8}, {"_seqHMM_simulate_mnhmm_multichannel", (DL_FUNC) &_seqHMM_simulate_mnhmm_multichannel, 9}, + {"_seqHMM_viterbi_nhmm_singlechannel", (DL_FUNC) &_seqHMM_viterbi_nhmm_singlechannel, 13}, + {"_seqHMM_viterbi_nhmm_multichannel", (DL_FUNC) &_seqHMM_viterbi_nhmm_multichannel, 13}, + {"_seqHMM_viterbi_mnhmm_singlechannel", (DL_FUNC) &_seqHMM_viterbi_mnhmm_singlechannel, 16}, + {"_seqHMM_viterbi_mnhmm_multichannel", (DL_FUNC) &_seqHMM_viterbi_mnhmm_multichannel, 16}, + {"_seqHMM_objective", (DL_FUNC) &_seqHMM_objective, 9}, + {"_seqHMM_objectivex", (DL_FUNC) &_seqHMM_objectivex, 12}, {"_seqHMM_softmax", (DL_FUNC) &_seqHMM_softmax, 1}, {"_seqHMM_varcoef", (DL_FUNC) &_seqHMM_varcoef, 2}, {"_seqHMM_viterbi", (DL_FUNC) &_seqHMM_viterbi, 4}, - {"_seqHMM_viterbi_nhmm_singlechannel", (DL_FUNC) &_seqHMM_viterbi_nhmm_singlechannel, 7}, - {"_seqHMM_viterbi_nhmm_multichannel", (DL_FUNC) &_seqHMM_viterbi_nhmm_multichannel, 8}, - {"_seqHMM_viterbi_mnhmm_singlechannel", (DL_FUNC) &_seqHMM_viterbi_mnhmm_singlechannel, 9}, - {"_seqHMM_viterbi_mnhmm_multichannel", (DL_FUNC) &_seqHMM_viterbi_mnhmm_multichannel, 10}, {"_seqHMM_viterbix", (DL_FUNC) &_seqHMM_viterbix, 7}, {NULL, NULL, 0} }; diff --git a/src/backward_nhmm.cpp b/src/backward_nhmm.cpp deleted file mode 100644 index 60ec4357..00000000 --- a/src/backward_nhmm.cpp +++ /dev/null @@ -1,129 +0,0 @@ -// backward algorithm for NHMM -#include "backward_nhmm.h" -#include "get_parameters.h" -#include "eta_to_gamma.h" - -// [[Rcpp::export]] -arma::cube backward_nhmm_singlechannel( - const arma::cube& eta_A, const arma::cube& X_s, - const arma::cube& eta_B, const arma::cube& X_o, - const arma::umat& obs) { - - unsigned int N = X_s.n_slices; - unsigned int T = X_s.n_cols; - unsigned int S = eta_A.n_slices; - unsigned int M = eta_B.n_rows + 1; - arma::cube log_beta(S, T, N); - arma::mat log_py(S, T); - arma::cube log_A(S, S, T); - arma::cube log_B(S, M + 1, T); - arma::cube gamma_A = eta_to_gamma(eta_A); - arma::cube gamma_B = eta_to_gamma(eta_B); - for (unsigned int i = 0; i < N; i++) { - log_A = get_log_A(gamma_A, X_s.slice(i)); - log_B = get_log_B(gamma_B, X_o.slice(i), true); - for (unsigned int t = 0; t < T; t++) { - for (unsigned int s = 0; s < S; s++) { - log_py(s, t) = log_B(s, obs(t, i), t); - } - } - univariate_backward_nhmm(log_beta.slice(i), log_A, log_py); - } - return log_beta; -} - -// [[Rcpp::export]] -arma::cube backward_nhmm_multichannel( - const arma::cube& eta_A, const arma::cube& X_s, - const arma::field& eta_B, const arma::cube& X_o, - const arma::ucube& obs, const arma::uvec M) { - - unsigned int N = X_s.n_slices; - unsigned int T = X_s.n_cols; - unsigned int S = eta_A.n_slices; - unsigned int C = obs.n_rows; - arma::cube log_beta(S, T, N); - arma::mat log_py(S, T); - arma::cube log_A(S, S, T); - arma::field log_B(C); - arma::cube gamma_A = eta_to_gamma(eta_A); - arma::field gamma_B = eta_to_gamma(eta_B); - for (unsigned int i = 0; i < N; i++) { - log_py.zeros(); - log_A = get_log_A(gamma_A, X_s.slice(i)); - log_B = get_log_B(gamma_B, X_o.slice(i), M, true); - for (unsigned int t = 0; t < T; t++) { - for (unsigned int c = 0; c < C; c++) { - log_py.col(t) += log_B(c).slice(t).col(obs(c, t, i)); - } - } - univariate_backward_nhmm(log_beta.slice(i), log_A, log_py); - } - return log_beta; -} - -// [[Rcpp::export]] -arma::cube backward_mnhmm_singlechannel( - const arma::field& eta_A, const arma::cube& X_s, - const arma::field& eta_B, const arma::cube& X_o, - const arma::umat& obs) { - - unsigned int N = X_s.n_slices; - unsigned int T = X_s.n_cols; - unsigned int S = eta_A(0).n_slices; - unsigned int D = eta_A.n_elem; - unsigned int M = eta_B(0).n_rows + 1; - arma::cube log_beta(S * D, T, N); - arma::mat log_py(S, T); - arma::cube log_A(S, S, T); - arma::cube log_B(S, M + 1, T); - arma::field gamma_A = eta_to_gamma(eta_A); - arma::field gamma_B = eta_to_gamma(eta_B); - for (unsigned int i = 0; i < N; i++) { - for (unsigned int d = 0; d < D; d++) { - log_A = get_log_A(gamma_A(d), X_s.slice(i)); - log_B = get_log_B(gamma_B(d), X_o.slice(i), true); - for (unsigned int t = 0; t < T; t++) { - log_py.col(t) = log_B.slice(t).col(obs(t, i)); - } - arma::subview submat = log_beta.slice(i).rows(d * S, (d + 1) * S - 1); - univariate_backward_nhmm(submat, log_A, log_py); - } - } - return log_beta; -} -// [[Rcpp::export]] -arma::cube backward_mnhmm_multichannel( - const arma::field& eta_A, const arma::cube& X_s, - const arma::field& eta_B, const arma::cube& X_o, - const arma::ucube& obs, const arma::uvec M) { - - unsigned int N = X_s.n_slices; - unsigned int T = X_s.n_cols; - unsigned int S = eta_A(0).n_slices; - unsigned int D = eta_A.n_elem; - unsigned int C = obs.n_rows; - arma::cube log_beta(S * D, T, N); - arma::mat log_py(S, T); - arma::cube log_A(S, S, T); - arma::field log_B(C); - arma::field gamma_A = eta_to_gamma(eta_A); - arma::field gamma_B = eta_to_gamma(eta_B); - for (unsigned int i = 0; i < N; i++) { - for (unsigned int d = 0; d < D; d++) { - log_py.zeros(); - log_A = get_log_A(gamma_A(d), X_s.slice(i)); - log_B = get_log_B( - gamma_B.rows(d * C, (d + 1) * C - 1), X_o.slice(i), M, true - ); - for (unsigned int t = 0; t < T; t++) { - for (unsigned int c = 0; c < C; c++) { - log_py.col(t) += log_B(c).slice(t).col(obs(c, t, i)); - } - } - arma::subview submat = log_beta.slice(i).rows(d * S, (d + 1) * S - 1); - univariate_backward_nhmm(submat, log_A, log_py); - } - } - return log_beta; -} diff --git a/src/backward_nhmm.h b/src/backward_nhmm.h deleted file mode 100644 index 4033813a..00000000 --- a/src/backward_nhmm.h +++ /dev/null @@ -1,28 +0,0 @@ -#ifndef BACKWARD_NHMM_H -#define BACKWARD_NHMM_H - -#include -#include "logsumexp.h" - -template -void univariate_backward_nhmm( - submat& log_beta, - const arma::cube& log_transition, - const arma::mat& log_py) { - - unsigned int S = log_py.n_rows; - unsigned int T = log_py.n_cols; - - log_beta.col(T - 1).zeros(); - for (int t = (T - 2); t >= 0; t--) { - arma::vec tmpbeta(S); - for (unsigned int i = 0; i < S; i++) { - log_beta(i, t) = logSumExp( - log_beta.col(t + 1) + log_transition.slice(t).row(i).t() + - log_py.col(t + 1) - ); - } - } -} - -#endif \ No newline at end of file diff --git a/src/cost_matrix.cpp b/src/cost_matrix.cpp index 3fac3694..7c0e7f83 100644 --- a/src/cost_matrix.cpp +++ b/src/cost_matrix.cpp @@ -6,11 +6,11 @@ arma::mat cost_matrix_singlechannel( const arma::cube& gamma_A_est, const arma::cube& gamma_A_ref, const arma::cube& gamma_B_est, const arma::cube& gamma_B_ref) { - unsigned int S = gamma_A_ref.n_slices; + arma::uword S = gamma_A_ref.n_slices; arma::mat costs(S, S); - for (unsigned int j = 0; j < S; j++) { - for (unsigned int k = 0; k < S; k++) { + for (arma::uword j = 0; j < S; j++) { + for (arma::uword k = 0; k < S; k++) { double cost_pi = arma::norm(gamma_pi_est.row(k) - gamma_pi_ref.row(j)); double cost_A = arma::norm(arma::vectorise(gamma_A_est.slice(k) - gamma_A_ref.slice(j))); double cost_B = arma::norm(arma::vectorise(gamma_B_est.slice(k) - gamma_B_ref.slice(j))); @@ -25,16 +25,16 @@ arma::mat cost_matrix_multichannel( const arma::cube& gamma_A_est, const arma::cube& gamma_A_ref, const arma::field& gamma_B_est, const arma::field& gamma_B_ref) { - unsigned int S = gamma_A_ref.n_slices; - unsigned int C = gamma_B_est.n_elem; + arma::uword S = gamma_A_ref.n_slices; + arma::uword C = gamma_B_est.n_elem; arma::mat costs(S, S); - for (unsigned int j = 0; j < S; j++) { - for (unsigned int k = 0; k < S; k++) { + for (arma::uword j = 0; j < S; j++) { + for (arma::uword k = 0; k < S; k++) { double cost_pi = arma::norm(gamma_pi_est.row(k) - gamma_pi_ref.row(j)); double cost_A = arma::norm(arma::vectorise(gamma_A_est.slice(k) - gamma_A_ref.slice(j))); double cost_B = 0; - for (unsigned int c = 0; c < C; c++){ + for (arma::uword c = 0; c < C; c++){ cost_B += arma::norm(arma::vectorise(gamma_B_est(c).slice(k) - gamma_B_ref(c).slice(j))); } costs(k, j) = cost_pi + cost_A + cost_B; @@ -46,12 +46,11 @@ arma::mat cost_matrix_multichannel( arma::mat cost_matrix_clusters( const arma::mat& pcp_est, const arma::mat& pcp_mle) { - unsigned int D = pcp_est.n_cols; - unsigned int N = pcp_est.n_rows; + arma::uword D = pcp_est.n_cols; arma::mat costs(D, D); - for (unsigned int j = 0; j < D; j++) { - for (unsigned int k = 0; k < D; k++) { + for (arma::uword j = 0; j < D; j++) { + for (arma::uword k = 0; k < D; k++) { costs(k, j) = arma::norm(pcp_est.col(k) - pcp_mle.col(j)); } } diff --git a/src/create_Q.cpp b/src/create_Q.cpp index 8803ea02..a4119b45 100644 --- a/src/create_Q.cpp +++ b/src/create_Q.cpp @@ -23,12 +23,12 @@ arma::vec2 givens(const double a, const double b) { // Simplified version of Algorithm 2.6 in // Hammarling, S., & Lucas, C. (2008). // R and Q are identity matrices -arma::mat compute_cs(const unsigned int n) { +arma::mat compute_cs(const arma::uword n) { arma::vec u(n, arma::fill::ones); u = -u; arma::mat R(n, n, arma::fill::eye); arma::mat cs(2, n); - for (unsigned int j = 0; j < n; j++) { + for (arma::uword j = 0; j < n; j++) { cs.col(j) = givens(R(j, j), u(j)); R(j, j) = cs(0, j) * R(j, j) - cs(1, j) * u(j); if (j < n - 1) { @@ -41,12 +41,12 @@ arma::mat compute_cs(const unsigned int n) { return cs; } // [[Rcpp::export]] -arma::mat create_Q(const unsigned int n) { +arma::mat create_Q(const arma::uword n) { arma::mat cs = compute_cs(n - 1); arma::mat Q(n, n, arma::fill::eye); arma::vec t1(n); arma::vec t2(n); - for (unsigned int j = 0; j < n - 1; j++) { + for (arma::uword j = 0; j < n - 1; j++) { t1 = Q.col(j); t2 = Q.col(n - 1); Q.col(j) = cs(0, j) * t1 - cs(1, j) * t2; diff --git a/src/create_Q.h b/src/create_Q.h index f016ec80..7a7e830c 100644 --- a/src/create_Q.h +++ b/src/create_Q.h @@ -3,6 +3,6 @@ #include arma::vec2 givens(const double a, const double b); -arma::mat compute_cs(const unsigned int n); -arma::mat create_Q(const unsigned int n); +arma::mat compute_cs(const arma::uword n); +arma::mat create_Q(const arma::uword n); #endif diff --git a/src/eta_to_gamma.cpp b/src/eta_to_gamma.cpp index 62c5fde5..2374178c 100644 --- a/src/eta_to_gamma.cpp +++ b/src/eta_to_gamma.cpp @@ -11,25 +11,25 @@ arma::mat eta_to_gamma_mat(const arma::mat& eta) { arma::cube eta_to_gamma_cube(const arma::cube& eta) { arma::mat Q = create_Q(eta.n_rows + 1); arma::cube gamma(eta.n_rows + 1, eta.n_cols, eta.n_slices); - for (unsigned int i = 0; i < eta.n_slices; i++) { + for (arma::uword i = 0; i < eta.n_slices; i++) { gamma.slice(i) = sum_to_zero(eta.slice(i), Q); } return gamma; } // [[Rcpp::export]] arma::field eta_to_gamma_mat_field(const arma::field& eta) { - unsigned int L = eta.n_elem; + arma::uword L = eta.n_elem; arma::field gamma(L); - for (unsigned int l = 0; l < L; l++) { + for (arma::uword l = 0; l < L; l++) { gamma(l) = eta_to_gamma(eta(l)); } return gamma; } // [[Rcpp::export]] arma::field eta_to_gamma_cube_field(const arma::field& eta) { - unsigned int L = eta.n_elem; + arma::uword L = eta.n_elem; arma::field gamma(L); - for (unsigned int l = 0; l < L; l++) { + for (arma::uword l = 0; l < L; l++) { gamma(l) = eta_to_gamma(eta(l)); } return gamma; @@ -42,23 +42,23 @@ arma::mat eta_to_gamma(const arma::mat& eta) { arma::cube eta_to_gamma(const arma::cube& eta) { arma::mat Q = create_Q(eta.n_rows + 1); arma::cube gamma(eta.n_rows + 1, eta.n_cols, eta.n_slices); - for (unsigned int i = 0; i < eta.n_slices; i++) { + for (arma::uword i = 0; i < eta.n_slices; i++) { gamma.slice(i) = sum_to_zero(eta.slice(i), Q); } return gamma; } arma::field eta_to_gamma(const arma::field& eta) { - unsigned int L = eta.n_elem; + arma::uword L = eta.n_elem; arma::field gamma(L); - for (unsigned int l = 0; l < L; l++) { + for (arma::uword l = 0; l < L; l++) { gamma(l) = eta_to_gamma(eta(l)); } return gamma; } arma::field eta_to_gamma(const arma::field& eta) { - unsigned int L = eta.n_elem; + arma::uword L = eta.n_elem; arma::field gamma(L); - for (unsigned int l = 0; l < L; l++) { + for (arma::uword l = 0; l < L; l++) { gamma(l) = eta_to_gamma(eta(l)); } return gamma; @@ -69,26 +69,26 @@ arma::mat eta_to_gamma(const arma::mat& eta, const arma::mat& Q) { } arma::cube eta_to_gamma(const arma::cube& eta, const arma::mat& Q) { arma::cube gamma(eta.n_rows + 1, eta.n_cols, eta.n_slices); - for (unsigned int i = 0; i < eta.n_slices; i++) { + for (arma::uword i = 0; i < eta.n_slices; i++) { gamma.slice(i) = sum_to_zero(eta.slice(i), Q); } return gamma; } arma::field eta_to_gamma( const arma::field& eta, const arma::mat& Q) { - unsigned int L = eta.n_elem; + arma::uword L = eta.n_elem; arma::field gamma(L); - for (unsigned int l = 0; l < L; l++) { + for (arma::uword l = 0; l < L; l++) { gamma(l) = eta_to_gamma(eta(l), Q); } return gamma; } arma::field eta_to_gamma( const arma::field& eta, const arma::mat& Q) { - unsigned int L = eta.n_elem; + arma::uword L = eta.n_elem; arma::field gamma(L); - for (unsigned int l = 0; l < L; l++) { + for (arma::uword l = 0; l < L; l++) { gamma(l) = eta_to_gamma(eta(l), Q); } return gamma; -} \ No newline at end of file +} diff --git a/src/forward_backward.h b/src/forward_backward.h index c6c8de4c..3e001be2 100644 --- a/src/forward_backward.h +++ b/src/forward_backward.h @@ -9,13 +9,13 @@ void uvBackward(const arma::sp_mat& transition, const arma::cube& emission, const arma::umat& obs, arma::mat& beta, const arma::vec& scales); void internalForwardx(const arma::sp_mat& transition_t, const arma::cube& emission, - const arma::mat& init, const arma::ucube& obs, arma::cube& alpha, arma::mat& scales, unsigned int threads); + const arma::mat& init, const arma::ucube& obs, arma::cube& alpha, arma::mat& scales, arma::uword threads); void internalForward(const arma::mat& transition_t, const arma::cube& emission, - const arma::vec& init, const arma::ucube& obs, arma::cube& alpha, arma::mat& scales, unsigned int threads); + const arma::vec& init, const arma::ucube& obs, arma::cube& alpha, arma::mat& scales, arma::uword threads); void internalBackward(const arma::mat& transition, const arma::cube& emission, - const arma::ucube& obs, arma::cube& beta, const arma::mat& scales, unsigned int threads); + const arma::ucube& obs, arma::cube& beta, const arma::mat& scales, arma::uword threads); void internalBackwardx(const arma::sp_mat& transition, const arma::cube& emission, - const arma::ucube& obs, arma::cube& beta, const arma::mat& scales, unsigned int threads); + const arma::ucube& obs, arma::cube& beta, const arma::mat& scales, arma::uword threads); #endif diff --git a/src/forward_nhmm.cpp b/src/forward_nhmm.cpp deleted file mode 100644 index e8ba1fac..00000000 --- a/src/forward_nhmm.cpp +++ /dev/null @@ -1,153 +0,0 @@ -// forward algorithm for NHMM -#include "forward_nhmm.h" -#include "get_parameters.h" -#include "eta_to_gamma.h" - -// [[Rcpp::export]] -arma::cube forward_nhmm_singlechannel( - const arma::mat& eta_pi, const arma::mat& X_i, - const arma::cube& eta_A, const arma::cube& X_s, - const arma::cube& eta_B, const arma::cube& X_o, - const arma::umat& obs) { - - unsigned int N = X_s.n_slices; - unsigned int T = X_s.n_cols; - unsigned int S = eta_A.n_slices; - unsigned int M = eta_B.n_rows + 1; - arma::cube log_alpha(S, T, N); - arma::mat log_py(S, T); - arma::vec log_Pi(S); - arma::cube log_A(S, S, T); - arma::cube log_B(S, M + 1, T); - arma::mat gamma_pi = eta_to_gamma(eta_pi); - arma::cube gamma_A = eta_to_gamma(eta_A); - arma::cube gamma_B = eta_to_gamma(eta_B); - for (unsigned int i = 0; i < N; i++) { - log_Pi = get_log_pi(gamma_pi, X_i.col(i)); - log_A = get_log_A(gamma_A, X_s.slice(i)); - log_B = get_log_B(gamma_B, X_o.slice(i), true); - for (unsigned int t = 0; t < T; t++) { - log_py.col(t) = log_B.slice(t).col(obs(t, i)); - } - univariate_forward_nhmm(log_alpha.slice(i), log_Pi, log_A, log_py); - } - return log_alpha; -} - -// [[Rcpp::export]] -arma::cube forward_nhmm_multichannel( - const arma::mat& eta_pi, const arma::mat& X_i, - const arma::cube& eta_A, const arma::cube& X_s, - const arma::field& eta_B, const arma::cube& X_o, - const arma::ucube& obs, const arma::uvec M) { - - unsigned int N = X_s.n_slices; - unsigned int T = X_s.n_cols; - unsigned int S = eta_A.n_slices; - unsigned int C = obs.n_rows; - arma::cube log_alpha(S, T, N); - arma::mat log_py(S, T); - arma::vec log_Pi(S); - arma::cube log_A(S, S, T); - arma::field log_B(C); - arma::mat gamma_pi = eta_to_gamma(eta_pi); - arma::cube gamma_A = eta_to_gamma(eta_A); - arma::field gamma_B = eta_to_gamma(eta_B); - for (unsigned int i = 0; i < N; i++) { - log_py.zeros(); - log_Pi = get_log_pi(gamma_pi, X_i.col(i)); - log_A = get_log_A(gamma_A, X_s.slice(i)); - log_B = get_log_B(gamma_B, X_o.slice(i), M, true); - for (unsigned int t = 0; t < T; t++) { - for (unsigned int c = 0; c < C; c++) { - log_py.col(t) += log_B(c).slice(t).col(obs(c, t, i)); - } - } - univariate_forward_nhmm(log_alpha.slice(i), log_Pi, log_A, log_py); - } - return log_alpha; -} - -// [[Rcpp::export]] -arma::cube forward_mnhmm_singlechannel( - const arma::field& eta_pi, const arma::mat& X_i, - const arma::field& eta_A, const arma::cube& X_s, - const arma::field& eta_B, const arma::cube& X_o, - const arma::mat& eta_omega, const arma::mat& X_d, - const arma::umat& obs) { - - unsigned int N = X_s.n_slices; - unsigned int T = X_s.n_cols; - unsigned int S = eta_A(0).n_slices; - unsigned int D = eta_omega.n_rows + 1; - unsigned int M = eta_B(0).n_rows + 1; - arma::cube log_alpha(S * D, T, N); - arma::mat log_py(S, T); - arma::vec log_Pi(S); - arma::cube log_A(S, S, T); - arma::cube log_B(S, M + 1, T); - arma::vec log_omega(D); - arma::mat gamma_omega = eta_to_gamma(eta_omega); - arma::field gamma_pi = eta_to_gamma(eta_pi); - arma::field gamma_A = eta_to_gamma(eta_A); - arma::field gamma_B = eta_to_gamma(eta_B); - for (unsigned int i = 0; i < N; i++) { - log_omega = get_log_omega(gamma_omega, X_d.col(i)); - for (unsigned int d = 0; d < D; d++) { - log_Pi = get_log_pi(gamma_pi(d), X_i.col(i)); - log_A = get_log_A(gamma_A(d), X_s.slice(i)); - log_B = get_log_B(gamma_B(d), X_o.slice(i), true); - for (unsigned int t = 0; t < T; t++) { - log_py.col(t) = log_B.slice(t).col(obs(t, i)); - } - log_alpha.slice(i).rows(d * S, (d + 1) * S - 1).fill(log_omega(d)); - arma::subview submat = log_alpha.slice(i).rows(d * S, (d + 1) * S - 1); - univariate_forward_nhmm(submat, log_Pi, log_A, log_py); - } - } - return log_alpha; -} -// [[Rcpp::export]] -arma::cube forward_mnhmm_multichannel( - const arma::field& eta_pi, const arma::mat& X_i, - const arma::field& eta_A, const arma::cube& X_s, - const arma::field& eta_B, const arma::cube& X_o, - const arma::mat& eta_omega, const arma::mat& X_d, - const arma::ucube& obs, const arma::uvec M) { - - unsigned int N = X_s.n_slices; - unsigned int T = X_s.n_cols; - unsigned int S = eta_A(0).n_slices; - unsigned int D = eta_omega.n_rows + 1; - unsigned int C = obs.n_rows; - arma::cube log_alpha(S * D, T, N); - arma::mat log_py(S, T); - arma::vec log_Pi(S); - arma::cube log_A(S, S, T); - arma::field log_B(C); - arma::vec log_omega(D); - arma::mat gamma_omega = eta_to_gamma(eta_omega); - arma::field gamma_pi = eta_to_gamma(eta_pi); - arma::field gamma_A = eta_to_gamma(eta_A); - arma::field gamma_B = eta_to_gamma(eta_B); - for (unsigned int i = 0; i < N; i++) { - log_omega = get_log_omega(gamma_omega, X_d.col(i)); - for (unsigned int d = 0; d < D; d++) { - log_py.zeros(); - log_Pi = get_log_pi(gamma_pi(d), X_i.col(i)); - log_A = get_log_A(gamma_A(d), X_s.slice(i)); - log_B = get_log_B( - gamma_B.rows(d * C, (d + 1) * C - 1), X_o.slice(i), M, true - ); - for (unsigned int t = 0; t < T; t++) { - for (unsigned int c = 0; c < C; c++) { - log_py.col(t) += log_B(c).slice(t).col(obs(c, t, i)); - } - } - log_alpha.slice(i).rows(d * S, (d + 1) * S - 1).fill(log_omega(d)); - arma::subview submat = log_alpha.slice(i).rows(d * S, (d + 1) * S - 1); - univariate_forward_nhmm(submat, log_Pi, log_A, log_py); - } - } - return log_alpha; -} diff --git a/src/forward_nhmm.h b/src/forward_nhmm.h deleted file mode 100644 index 73c97112..00000000 --- a/src/forward_nhmm.h +++ /dev/null @@ -1,26 +0,0 @@ -#ifndef FORWARD_NHMM_H -#define FORWARD_NHMM_H - -#include -#include "logsumexp.h" - -template -void univariate_forward_nhmm( - submat& log_alpha, - const arma::vec& log_init, - const arma::cube& log_transition, - const arma::mat& log_py) { - - unsigned int S = log_py.n_rows; - unsigned int T = log_py.n_cols; - log_alpha.col(0) = log_init + log_py.col(0); - for (unsigned int t = 1; t < T; t++) { - for (unsigned int i = 0; i < S; i++) { - log_alpha(i, t) = logSumExp( - log_alpha.col(t - 1) + log_transition.slice(t - 1).col(i) + log_py(i, t) - ); - } - } -} - -#endif \ No newline at end of file diff --git a/src/forwardbackward.cpp b/src/forwardbackward.cpp index fbcae267..44dda51e 100644 --- a/src/forwardbackward.cpp +++ b/src/forwardbackward.cpp @@ -3,7 +3,7 @@ #include "useomp.h" // [[Rcpp::export]] Rcpp::List forwardbackward(const arma::mat& transition, const arma::cube& emission, - const arma::vec& init, const arma::ucube& obs, bool forwardonly, unsigned int threads) { + const arma::vec& init, const arma::ucube& obs, bool forwardonly, arma::uword threads) { arma::cube alpha(emission.n_rows, obs.n_cols, obs.n_slices); //m,n,k arma::mat scales(obs.n_cols, obs.n_slices); //n,k diff --git a/src/forwardbackwardx.cpp b/src/forwardbackwardx.cpp index e5e7c960..ce8cb465 100644 --- a/src/forwardbackwardx.cpp +++ b/src/forwardbackwardx.cpp @@ -6,13 +6,13 @@ // [[Rcpp::export]] Rcpp::List forwardbackwardx(const arma::mat& transition, const arma::cube& emission, const arma::vec& init, const arma::ucube obs, const arma::mat& coef, const arma::mat& X, - const arma::uvec& numberOfStates, bool forwardonly, unsigned int threads) { + const arma::uvec& numberOfStates, bool forwardonly, arma::uword threads) { arma::mat weights = exp(X * coef).t(); weights.each_row() /= arma::sum(weights, 0); arma::mat initk(emission.n_rows, obs.n_slices); - for (unsigned int k = 0; k < obs.n_slices; k++) { + for (arma::uword k = 0; k < obs.n_slices; k++) { initk.col(k) = init % reparma(weights.col(k), numberOfStates); } arma::cube alpha(emission.n_rows, obs.n_cols, obs.n_slices); //m,n,k diff --git a/src/get_parameters.cpp b/src/get_parameters.cpp index eb5893c9..48288d39 100644 --- a/src/get_parameters.cpp +++ b/src/get_parameters.cpp @@ -1,5 +1,4 @@ #include "get_parameters.h" -#include "sum_to_zero.h" // eta_omega is D x K (start from, covariates) // X a vector of length K @@ -16,7 +15,7 @@ arma::vec get_log_omega(const arma::mat& gamma, const arma::vec& X) { // [[Rcpp::export]] arma::mat get_omega_all(const arma::mat& gamma, const arma::mat& X) { arma::mat omega(gamma.n_rows, X.n_cols); - for (unsigned int i = 0; i < X.n_cols; i++) { + for (arma::uword i = 0; i < X.n_cols; i++) { omega.col(i) = softmax(gamma * X.col(i)); } return omega; @@ -39,19 +38,19 @@ arma::vec get_log_pi(const arma::mat& gamma, const arma::vec& X) { // [[Rcpp::export]] arma::cube get_A(const arma::cube& gamma, const arma::mat& X, const bool tv) { - unsigned int S = gamma.n_slices; - unsigned int T = X.n_cols; + arma::uword S = gamma.n_slices; + arma::uword T = X.n_cols; arma::cube A(S, S, T); arma::mat Atmp(S, S); if (tv) { - for (unsigned int t = 0; t < T; t++) { // time - for (unsigned int j = 0; j < S; j ++) { // from states + for (arma::uword t = 0; t < T; t++) { // time + for (arma::uword j = 0; j < S; j ++) { // from states Atmp.col(j) = softmax(gamma.slice(j) * X.col(t)); } A.slice(t) = Atmp.t(); } } else { - for (unsigned int j = 0; j < S; j ++) { // from states + for (arma::uword j = 0; j < S; j ++) { // from states Atmp.col(j) = softmax(gamma.slice(j) * X.col(0)); } A.each_slice() = Atmp.t(); @@ -63,19 +62,19 @@ arma::cube get_A(const arma::cube& gamma, const arma::mat& X, // [[Rcpp::export]] arma::cube get_log_A(const arma::cube& gamma, const arma::mat& X, const bool tv) { - unsigned int S = gamma.n_slices; - unsigned int T = X.n_cols; + arma::uword S = gamma.n_slices; + arma::uword T = X.n_cols; arma::cube A(S, S, T); arma::mat Atmp(S, S); if (tv) { - for (unsigned int t = 0; t < T; t++) { // time - for (unsigned int j = 0; j < S; j ++) { // from states + for (arma::uword t = 0; t < T; t++) { // time + for (arma::uword j = 0; j < S; j ++) { // from states Atmp.col(j) = softmax(gamma.slice(j) * X.col(t)); } A.slice(t) = Atmp.t(); } } else { - for (unsigned int j = 0; j < S; j ++) { // from states + for (arma::uword j = 0; j < S; j ++) { // from states Atmp.col(j) = softmax(gamma.slice(j) * X.col(0)); } A.each_slice() = Atmp.t(); @@ -87,23 +86,23 @@ arma::cube get_log_A(const arma::cube& gamma, const arma::mat& X, // [[Rcpp::export]] arma::cube get_B(const arma::cube& gamma, const arma::mat& X, const bool tv, const bool add_missing) { - unsigned int S = gamma.n_slices; - unsigned int M = gamma.n_rows; - unsigned int T = X.n_cols; + arma::uword S = gamma.n_slices; + arma::uword M = gamma.n_rows; + arma::uword T = X.n_cols; arma::cube B(S, M + add_missing, T); arma::mat Btmp(M + add_missing, S); if (add_missing) { Btmp.row(M).fill(1.0); } if (tv) { - for (unsigned int t = 0; t < T; t++) { // time - for (unsigned int j = 0; j < S; j ++) { // from states + for (arma::uword t = 0; t < T; t++) { // time + for (arma::uword j = 0; j < S; j ++) { // from states Btmp.col(j).rows(0, M - 1) = softmax(gamma.slice(j) * X.col(t)); } B.slice(t) = Btmp.t(); } } else { - for (unsigned int j = 0; j < S; j ++) { // from states + for (arma::uword j = 0; j < S; j ++) { // from states Btmp.col(j).rows(0, M - 1) = softmax( gamma.slice(j) * X.col(0) ); @@ -117,9 +116,9 @@ arma::cube get_B(const arma::cube& gamma, const arma::mat& X, arma::field get_B( const arma::field& gamma, const arma::mat& X, const arma::uvec& M, const bool tv, const bool add_missing) { - unsigned int C = M.n_elem; + arma::uword C = M.n_elem; arma::field B(C); // C field of cubes, each S x M_c x T - for (unsigned int c = 0; c < C; c++) { + for (arma::uword c = 0; c < C; c++) { B(c) = get_B(gamma(c), X, tv, add_missing); } return B; @@ -129,23 +128,23 @@ arma::field get_B( // [[Rcpp::export]] arma::cube get_log_B(const arma::cube& gamma, const arma::mat& X, const bool tv, const bool add_missing) { - unsigned int S = gamma.n_slices; - unsigned int M = gamma.n_rows; - unsigned int T = X.n_cols; + arma::uword S = gamma.n_slices; + arma::uword M = gamma.n_rows; + arma::uword T = X.n_cols; arma::cube B(S, M + add_missing, T); arma::mat Btmp(M + add_missing, S); if (add_missing) { Btmp.row(M).fill(1.0); } if (tv) { - for (unsigned int t = 0; t < T; t++) { // time - for (unsigned int j = 0; j < S; j ++) { // from states + for (arma::uword t = 0; t < T; t++) { // time + for (arma::uword j = 0; j < S; j ++) { // from states Btmp.col(j).rows(0, M - 1) = softmax(gamma.slice(j) * X.col(t)); } B.slice(t) = Btmp.t(); } } else { - for (unsigned int j = 0; j < S; j ++) { // from states + for (arma::uword j = 0; j < S; j ++) { // from states Btmp.col(j).rows(0, M - 1) = softmax( gamma.slice(j) * X.col(0) ); @@ -159,9 +158,9 @@ arma::cube get_log_B(const arma::cube& gamma, const arma::mat& X, arma::field get_log_B( const arma::field& gamma, const arma::mat& X, const arma::uvec& M, const bool tv, const bool add_missing) { - unsigned int C = M.n_elem; + arma::uword C = M.n_elem; arma::field log_B(C); // C field of cubes, each S x M_c x T - for (unsigned int c = 0; c < C; c++) { + for (arma::uword c = 0; c < C; c++) { log_B(c) = get_log_B(gamma(c), X, tv, add_missing); } return log_B; @@ -172,7 +171,7 @@ arma::field get_log_B( // [[Rcpp::export]] arma::mat get_pi_all(const arma::mat& gamma, const arma::mat& X) { arma::mat pi(gamma.n_rows, X.n_cols); - for (unsigned int i = 0; i < X.n_cols; i++) { + for (arma::uword i = 0; i < X.n_cols; i++) { pi.col(i) = softmax(gamma * X.col(i)); } return pi; @@ -182,9 +181,9 @@ arma::mat get_pi_all(const arma::mat& gamma, const arma::mat& X) { // [[Rcpp::export]] arma::field get_A_all(const arma::cube& gamma, const arma::cube& X, const bool tv) { - unsigned int N = X.n_slices; + arma::uword N = X.n_slices; arma::field A(N); - for (unsigned int i = 0; i < N; i++) { + for (arma::uword i = 0; i < N; i++) { A(i) = get_A(gamma, X.slice(i), tv); } return A; @@ -194,9 +193,9 @@ arma::field get_A_all(const arma::cube& gamma, const arma::cube& X, // [[Rcpp::export]] arma::field get_B_all( const arma::cube& gamma, const arma::cube& X, const bool tv) { - unsigned int N = X.n_slices; + arma::uword N = X.n_slices; arma::field B(N); - for (unsigned int i = 0; i < N; i++) { + for (arma::uword i = 0; i < N; i++) { B(i) = get_B(gamma, X.slice(i), tv); } return B; @@ -209,14 +208,14 @@ arma::field get_B_all( // [[Rcpp::export]] arma::mat get_pi_qs(const arma::field& gamma, const arma::mat& X, const arma::vec& probs) { - unsigned int S = gamma(0).n_rows; - unsigned int L = gamma.n_elem; - unsigned int N = X.n_cols; - unsigned int P = probs.n_elem; + arma::uword S = gamma(0).n_rows; + arma::uword L = gamma.n_elem; + arma::uword N = X.n_cols; + arma::uword P = probs.n_elem; arma::mat pi(S, L); arma::mat qs(S * N, P); - for (unsigned int i = 0; i < N; i++) { - for (unsigned int l = 0; l < L; l++) { + for (arma::uword i = 0; i < N; i++) { + for (arma::uword l = 0; l < L; l++) { pi.col(l) = get_pi(gamma(l), X.col(i)); } qs.rows(i * S, (i + 1) * S - 1) = arma::quantile(pi, probs, 1); @@ -232,16 +231,16 @@ arma::mat get_A_qs(const arma::field& gamma, const arma::cube& X, const bool tv, const arma::vec& probs) { - unsigned int S = gamma(0).n_rows; - unsigned int L = gamma.n_elem; - unsigned int N = X.n_slices; - unsigned int T = X.n_cols; - unsigned int P = probs.n_elem; - unsigned int SST = S * S * T; + arma::uword S = gamma(0).n_rows; + arma::uword L = gamma.n_elem; + arma::uword N = X.n_slices; + arma::uword T = X.n_cols; + arma::uword P = probs.n_elem; + arma::uword SST = S * S * T; arma::mat A(SST, L); arma::mat qs(SST * N, P); - for (unsigned int i = 0; i < N; i++) { - for (unsigned int l = 0; l < L; l++) { + for (arma::uword i = 0; i < N; i++) { + for (arma::uword l = 0; l < L; l++) { A.col(l) = arma::vectorise(get_A(gamma(l), X.slice(i), tv)); } qs.rows(i * SST, (i + 1) * SST - 1) = arma::quantile(A, probs, 1); @@ -256,17 +255,17 @@ arma::mat get_A_qs(const arma::field& gamma, arma::mat get_B_qs(const arma::field& gamma, const arma::cube& X, const bool tv, const arma::vec& probs) { - unsigned int M = gamma(0).n_rows; - unsigned int S = gamma(0).n_slices; - unsigned int L = gamma.n_elem; - unsigned int N = X.n_slices; - unsigned int T = X.n_cols; - unsigned int P = probs.n_elem; - unsigned int SMT = S * M * T; + arma::uword M = gamma(0).n_rows; + arma::uword S = gamma(0).n_slices; + arma::uword L = gamma.n_elem; + arma::uword N = X.n_slices; + arma::uword T = X.n_cols; + arma::uword P = probs.n_elem; + arma::uword SMT = S * M * T; arma::mat B(SMT, L); arma::mat qs(SMT * N, P); - for (unsigned int i = 0; i < N; i++) { - for (unsigned int l = 0; l < L; l++) { + for (arma::uword i = 0; i < N; i++) { + for (arma::uword l = 0; l < L; l++) { B.col(l) = arma::vectorise(get_B(gamma(l), X.slice(i), tv)); } qs.rows(i * SMT, (i + 1) * SMT - 1) = arma::quantile(B, probs, 1); @@ -279,14 +278,14 @@ arma::mat get_B_qs(const arma::field& gamma, // [[Rcpp::export]] arma::mat get_omega_qs(const arma::field& gamma, const arma::mat& X, const arma::vec& probs) { - unsigned int D = gamma(0).n_rows; - unsigned int L = gamma.n_elem; - unsigned int N = X.n_cols; - unsigned int P = probs.n_elem; + arma::uword D = gamma(0).n_rows; + arma::uword L = gamma.n_elem; + arma::uword N = X.n_cols; + arma::uword P = probs.n_elem; arma::mat omega(D, L); arma::mat qs(D * N, P); - for (unsigned int i = 0; i < N; i++) { - for (unsigned int l = 0; l < L; l++) { + for (arma::uword i = 0; i < N; i++) { + for (arma::uword l = 0; l < L; l++) { omega.col(l) = get_omega(gamma(l), X.col(i)); } qs.rows(i * D, (i + 1) * D - 1) = arma::quantile(omega, probs, 1); @@ -302,14 +301,13 @@ arma::mat get_omega_qs(const arma::field& gamma, const arma::mat& X, arma::mat get_pi_ame(const arma::field& gamma, const arma::mat& X1, const arma::mat& X2, const arma::vec& probs) { - unsigned int S = gamma(0).n_rows; - unsigned int L = gamma.n_elem; - unsigned int N = X1.n_cols; - unsigned int P = probs.n_elem; + arma::uword S = gamma(0).n_rows; + arma::uword L = gamma.n_elem; + arma::uword N = X1.n_cols; double invN = 1.0 / N; arma::mat pi(S, L, arma::fill::zeros); - for (unsigned int l = 0; l < L; l++) { - for (unsigned int i = 0; i < N; i++) { + for (arma::uword l = 0; l < L; l++) { + for (arma::uword i = 0; i < N; i++) { pi.col(l) += invN * ( get_pi(gamma(l), X1.col(i)) - get_pi(gamma(l), X2.col(i)) ); @@ -325,16 +323,15 @@ arma::mat get_A_ame(const arma::field& gamma, const arma::cube& X1, const arma::cube& X2, const bool tv, const arma::vec& probs) { - unsigned int S = gamma(0).n_rows; - unsigned int L = gamma.n_elem; - unsigned int N = X1.n_slices; - unsigned int T = X1.n_cols; - unsigned int P = probs.n_elem; + arma::uword S = gamma(0).n_rows; + arma::uword L = gamma.n_elem; + arma::uword N = X1.n_slices; + arma::uword T = X1.n_cols; double invN = 1.0 / N; - unsigned int SST = S * S * T; + arma::uword SST = S * S * T; arma::mat A(SST, L, arma::fill::zeros); - for (unsigned int l = 0; l < L; l++) { - for (unsigned int i = 0; i < N; i++) { + for (arma::uword l = 0; l < L; l++) { + for (arma::uword i = 0; i < N; i++) { A.col(l) += invN * ( arma::vectorise(get_A(gamma(l), X1.slice(i), tv)) - arma::vectorise(get_A(gamma(l), X2.slice(i), tv)) @@ -350,17 +347,16 @@ arma::mat get_A_ame(const arma::field& gamma, arma::mat get_B_ame(const arma::field& gamma, const arma::cube& X1, const arma::cube& X2, const bool tv, const arma::vec& probs) { - unsigned int M = gamma(0).n_rows; - unsigned int S = gamma(0).n_slices; - unsigned int L = gamma.n_elem; - unsigned int N = X1.n_slices; - unsigned int T = X1.n_cols; - unsigned int P = probs.n_elem; - unsigned int SMT = S * M * T; + arma::uword M = gamma(0).n_rows; + arma::uword S = gamma(0).n_slices; + arma::uword L = gamma.n_elem; + arma::uword N = X1.n_slices; + arma::uword T = X1.n_cols; + arma::uword SMT = S * M * T; double invN = 1.0 / N; arma::mat B(SMT, L, arma::fill::zeros); - for (unsigned int l = 0; l < L; l++) { - for (unsigned int i = 0; i < N; i++) { + for (arma::uword l = 0; l < L; l++) { + for (arma::uword i = 0; i < N; i++) { B.col(l) += invN * ( arma::vectorise(get_B(gamma(l), X1.slice(i), tv)) - arma::vectorise(get_B(gamma(l), X2.slice(i), tv)) @@ -375,14 +371,13 @@ arma::mat get_B_ame(const arma::field& gamma, arma::mat get_omega_ame(const arma::field& gamma, const arma::mat& X1, const arma::mat& X2, const arma::vec& probs) { - unsigned int D = gamma(0).n_rows; - unsigned int L = gamma.n_elem; - unsigned int N = X1.n_cols; - unsigned int P = probs.n_elem; + arma::uword D = gamma(0).n_rows; + arma::uword L = gamma.n_elem; + arma::uword N = X1.n_cols; double invN = 1.0 / N; arma::mat omega(D, L, arma::fill::zeros); - for (unsigned int l = 0; l < L; l++) { - for (unsigned int i = 0; i < N; i++) { + for (arma::uword l = 0; l < L; l++) { + for (arma::uword i = 0; i < N; i++) { omega.col(l) += invN * ( get_omega(gamma(l), X1.col(i)) - get_omega(gamma(l), X2.col(i)) ); @@ -390,3 +385,29 @@ arma::mat get_omega_ame(const arma::field& gamma, } return arma::quantile(omega, probs, 1); } +// +// // Compute row of A for EM algorithm +// // gamma is S x K (transition to, covariates) +// // X is K x T matrix (covariates, time points) +// // [[Rcpp::export]] +// arma::mat get_A_em(const arma::mat& gamma, const arma::mat& X, +// const bool tv) { +// arma::uword S = gamma.rows; +// arma::uword T = X.n_cols; +// arma::mat A(S, T); +// arma::mat Atmp(S, S); +// if (tv) { +// for (arma::uword t = 0; t < T; t++) { // time +// for (arma::uword j = 0; j < S; j ++) { // from states +// Atmp.col(j) = softmax(gamma.slice(j) * X.col(t)); +// } +// A.slice(t) = Atmp.t(); +// } +// } else { +// for (arma::uword j = 0; j < S; j ++) { // from states +// Atmp.col(j) = softmax(gamma.slice(j) * X.col(0)); +// } +// A.each_slice() = Atmp.t(); +// } +// return A; +// } diff --git a/src/internalBackward.cpp b/src/internalBackward.cpp index 2a9e69a5..ca65e39f 100644 --- a/src/internalBackward.cpp +++ b/src/internalBackward.cpp @@ -4,15 +4,15 @@ void internalBackward(const arma::mat& transition, const arma::cube& emission, const arma::ucube& obs, arma::cube& beta, const arma::mat& scales, - unsigned int threads) { + arma::uword threads) { #pragma omp parallel for if(obs.n_slices >= threads) schedule(static) num_threads(threads) \ default(none) shared(beta, scales, obs, emission, transition) - for (unsigned int k = 0; k < obs.n_slices; k++) { + for (arma::uword k = 0; k < obs.n_slices; k++) { beta.slice(k).col(obs.n_cols - 1).fill(scales(obs.n_cols - 1, k)); for (int t = obs.n_cols - 2; t >= 0; t--) { arma::vec tmpbeta = beta.slice(k).col(t + 1); - for (unsigned int r = 0; r < obs.n_rows; r++) { + for (arma::uword r = 0; r < obs.n_rows; r++) { tmpbeta %= emission.slice(r).col(obs(r, t + 1, k)); } beta.slice(k).col(t) = transition * tmpbeta * scales(t, k); @@ -22,15 +22,15 @@ default(none) shared(beta, scales, obs, emission, transition) void internalBackwardx(const arma::sp_mat& transition, const arma::cube& emission, const arma::ucube& obs, arma::cube& beta, - const arma::mat& scales, unsigned int threads) { + const arma::mat& scales, arma::uword threads) { #pragma omp parallel for if(obs.n_slices >= threads) schedule(static) num_threads(threads) \ default(none) shared(beta, scales, obs, emission,transition) - for (unsigned int k = 0; k < obs.n_slices; k++) { + for (arma::uword k = 0; k < obs.n_slices; k++) { beta.slice(k).col(obs.n_cols - 1).fill(scales(obs.n_cols - 1, k)); for (int t = obs.n_cols - 2; t >= 0; t--) { arma::vec tmpbeta = beta.slice(k).col(t + 1); - for (unsigned int r = 0; r < obs.n_rows; r++) { + for (arma::uword r = 0; r < obs.n_rows; r++) { tmpbeta %= emission.slice(r).col(obs(r, t + 1, k)); } beta.slice(k).col(t) = transition * tmpbeta * scales(t, k); diff --git a/src/internalForward.cpp b/src/internalForward.cpp index 108a9be5..79fc3017 100644 --- a/src/internalForward.cpp +++ b/src/internalForward.cpp @@ -4,20 +4,20 @@ #include "useomp.h" void internalForward(const arma::mat& transition_t, const arma::cube& emission, const arma::vec& init, - const arma::ucube& obs, arma::cube& alpha, arma::mat& scales, unsigned int threads) { + const arma::ucube& obs, arma::cube& alpha, arma::mat& scales, arma::uword threads) { #pragma omp parallel for if(obs.n_slices >= threads) schedule(static) num_threads(threads) \ default(none) shared(alpha, scales, obs, init, emission, transition_t) - for (unsigned int k = 0; k < obs.n_slices; k++) { + for (arma::uword k = 0; k < obs.n_slices; k++) { alpha.slice(k).col(0) = init; - for (unsigned int r = 0; r < obs.n_rows; r++) { + for (arma::uword r = 0; r < obs.n_rows; r++) { alpha.slice(k).col(0) %= emission.slice(r).col(obs(r, 0, k)); } scales(0, k) = 1.0 / sum(alpha.slice(k).col(0)); alpha.slice(k).col(0) *= scales(0, k); - for (unsigned int t = 1; t < obs.n_cols; t++) { + for (arma::uword t = 1; t < obs.n_cols; t++) { alpha.slice(k).col(t) = transition_t * alpha.slice(k).col(t - 1); - for (unsigned int r = 0; r < obs.n_rows; r++) { + for (arma::uword r = 0; r < obs.n_rows; r++) { alpha.slice(k).col(t) %= emission.slice(r).col(obs(r, t, k)); } scales(t, k) = 1.0 / sum(alpha.slice(k).col(t)); @@ -28,21 +28,21 @@ void internalForward(const arma::mat& transition_t, const arma::cube& emission, void internalForwardx(const arma::sp_mat& transition_t, const arma::cube& emission, const arma::mat& init, const arma::ucube& obs, arma::cube& alpha, arma::mat& scales, - unsigned int threads) { + arma::uword threads) { #pragma omp parallel for if(obs.n_slices >= threads) schedule(static) num_threads(threads) \ default(none) shared(alpha, scales, obs, init, emission, transition_t) - for (unsigned int k = 0; k < obs.n_slices; k++) { + for (arma::uword k = 0; k < obs.n_slices; k++) { alpha.slice(k).col(0) = init.col(k); - for (unsigned int r = 0; r < obs.n_rows; r++) { + for (arma::uword r = 0; r < obs.n_rows; r++) { alpha.slice(k).col(0) %= emission.slice(r).col(obs(r, 0, k)); } scales(0, k) = 1.0 / sum(alpha.slice(k).col(0)); alpha.slice(k).col(0) *= scales(0, k); - for (unsigned int t = 1; t < obs.n_cols; t++) { + for (arma::uword t = 1; t < obs.n_cols; t++) { alpha.slice(k).col(t) = transition_t * alpha.slice(k).col(t - 1); - for (unsigned int r = 0; r < obs.n_rows; r++) { + for (arma::uword r = 0; r < obs.n_rows; r++) { alpha.slice(k).col(t) %= emission.slice(r).col(obs(r, t, k)); } scales(t, k) = 1.0 / sum(alpha.slice(k).col(t)); diff --git a/src/logLikHMM.cpp b/src/logLikHMM.cpp index 2def64ac..1801a6dc 100644 --- a/src/logLikHMM.cpp +++ b/src/logLikHMM.cpp @@ -4,16 +4,16 @@ // [[Rcpp::export]] Rcpp::NumericVector logLikHMM(const arma::mat& transition, const arma::cube& emission, - const arma::vec& init, const arma::ucube& obs, unsigned int threads) { + const arma::vec& init, const arma::ucube& obs, arma::uword threads) { arma::vec ll(obs.n_slices); arma::mat transition_t(transition.t()); #pragma omp parallel for if(obs.n_slices >= threads) schedule(static) num_threads(threads) \ default(none) shared(ll, obs, init, emission, transition_t) - for (unsigned int k = 0; k < obs.n_slices; k++) { + for (arma::uword k = 0; k < obs.n_slices; k++) { arma::vec alpha = init; - for (unsigned int r = 0; r < obs.n_rows; r++) { + for (arma::uword r = 0; r < obs.n_rows; r++) { alpha %= emission.slice(r).col(obs(r, 0, k)); } @@ -21,9 +21,9 @@ Rcpp::NumericVector logLikHMM(const arma::mat& transition, const arma::cube& emi ll(k) = log(tmp); alpha /= tmp; - for (unsigned int t = 1; t < obs.n_cols; t++) { + for (arma::uword t = 1; t < obs.n_cols; t++) { alpha = transition_t * alpha; - for (unsigned int r = 0; r < obs.n_rows; r++) { + for (arma::uword r = 0; r < obs.n_rows; r++) { alpha %= emission.slice(r).col(obs(r, t, k)); } diff --git a/src/logLikMixHMM.cpp b/src/logLikMixHMM.cpp index 1ea12b7a..f2759b55 100644 --- a/src/logLikMixHMM.cpp +++ b/src/logLikMixHMM.cpp @@ -6,7 +6,7 @@ // [[Rcpp::export]] Rcpp::NumericVector logLikMixHMM(const arma::mat& transition, const arma::cube& emission, const arma::vec& init, const arma::ucube& obs, const arma::mat& coef, const arma::mat& X, - const arma::uvec& numberOfStates, unsigned int threads) { + const arma::uvec& numberOfStates, arma::uword threads) { arma::mat weights = exp(X * coef).t(); if (!weights.is_finite()) { @@ -18,10 +18,10 @@ Rcpp::NumericVector logLikMixHMM(const arma::mat& transition, const arma::cube& arma::sp_mat transition_t(transition.t()); #pragma omp parallel for if(obs.n_slices >= threads) schedule(static) num_threads(threads) \ default(none) shared(ll, obs, weights, init, emission, transition_t, numberOfStates) - for (unsigned int k = 0; k < obs.n_slices; k++) { + for (arma::uword k = 0; k < obs.n_slices; k++) { arma::vec alpha = init % reparma(weights.col(k), numberOfStates); - for (unsigned int r = 0; r < obs.n_rows; r++) { + for (arma::uword r = 0; r < obs.n_rows; r++) { alpha %= emission.slice(r).col(obs(r, 0, k)); } @@ -29,9 +29,9 @@ Rcpp::NumericVector logLikMixHMM(const arma::mat& transition, const arma::cube& ll(k) = log(tmp); alpha /= tmp; - for (unsigned int t = 1; t < obs.n_cols; t++) { + for (arma::uword t = 1; t < obs.n_cols; t++) { alpha = transition_t * alpha; - for (unsigned int r = 0; r < obs.n_rows; r++) { + for (arma::uword r = 0; r < obs.n_rows; r++) { alpha %= emission.slice(r).col(obs(r, t, k)); } diff --git a/src/logSumExp.cpp b/src/logSumExp.cpp index ce555797..7cc595eb 100644 --- a/src/logSumExp.cpp +++ b/src/logSumExp.cpp @@ -8,13 +8,13 @@ // IMA Journal of Numerical Analysis, 41, 4, 2311–2330 // [[Rcpp::export]] double logSumExp(const arma::vec& x) { - unsigned int maxi = x.index_max(); + arma::uword maxi = x.index_max(); double maxv = x(maxi); if (!std::isfinite(maxv)) { return maxv; } double cumsum = 0.0; - for (unsigned int i = 0; i < x.n_elem; i++) { + for (arma::uword i = 0; i < x.n_elem; i++) { if ((i != maxi) && (x(i) > -arma::datum::inf)) { cumsum += exp(x(i) - maxv); } diff --git a/src/log_EM.cpp b/src/log_EM.cpp index f96848c4..0efa020d 100644 --- a/src/log_EM.cpp +++ b/src/log_EM.cpp @@ -6,7 +6,7 @@ // [[Rcpp::export]] Rcpp::List log_EM(const arma::mat& transition_, const arma::cube& emission_, const arma::vec& init_, const arma::ucube& obs, const arma::uvec& nSymbols, - int itermax, double tol, int trace, unsigned int threads) { + int itermax, double tol, int trace, arma::uword threads) { // Make sure we don't alter the original vec/mat/cube // needed for cube, in future maybe in other cases as well @@ -24,7 +24,7 @@ Rcpp::List log_EM(const arma::mat& transition_, const arma::cube& emission_, #pragma omp parallel for if(obs.n_slices >= threads) schedule(static) num_threads(threads) \ default(none) shared(obs, alpha, ll) - for (unsigned int k = 0; k < obs.n_slices; k++) { + for (arma::uword k = 0; k < obs.n_slices; k++) { ll(k) = logSumExp(alpha.slice(k).col(obs.n_cols - 1)); } @@ -45,22 +45,22 @@ Rcpp::List log_EM(const arma::mat& transition_, const arma::cube& emission_, arma::cube gamma(emission.n_rows, emission.n_cols, emission.n_slices, arma::fill::zeros); arma::vec delta(emission.n_rows, arma::fill::zeros); - for (unsigned int k = 0; k < obs.n_slices; k++) { + for (arma::uword k = 0; k < obs.n_slices; k++) { delta += exp(alpha.slice(k).col(0) + beta.slice(k).col(0) - ll(k)); } #pragma omp parallel for if(obs.n_slices>=threads) schedule(static) num_threads(threads) \ default(none) shared(transition, obs, alpha, beta, ll, \ emission, ksii, gamma, nSymbols) - for (unsigned int k = 0; k < obs.n_slices; k++) { + for (arma::uword k = 0; k < obs.n_slices; k++) { if (obs.n_cols > 1) { - for (unsigned int j = 0; j < emission.n_rows; j++) { - for (unsigned int i = 0; i < emission.n_rows; i++) { + for (arma::uword j = 0; j < emission.n_rows; j++) { + for (arma::uword i = 0; i < emission.n_rows; i++) { if (transition(i, j) > -arma::datum::inf) { arma::vec tmpnm1(obs.n_cols - 1); - for (unsigned int t = 0; t < (obs.n_cols - 1); t++) { + for (arma::uword t = 0; t < (obs.n_cols - 1); t++) { tmpnm1(t) = alpha(i, t, k) + transition(i, j) + beta(j, t + 1, k); - for (unsigned int r = 0; r < obs.n_rows; r++) { + for (arma::uword r = 0; r < obs.n_rows; r++) { tmpnm1(t) += emission(j, obs(r, t + 1, k), r); } } @@ -71,12 +71,12 @@ Rcpp::List log_EM(const arma::mat& transition_, const arma::cube& emission_, } } - for (unsigned int r = 0; r < emission.n_slices; r++) { - for (unsigned int l = 0; l < nSymbols(r); l++) { - for (unsigned int i = 0; i < emission.n_rows; i++) { + for (arma::uword r = 0; r < emission.n_slices; r++) { + for (arma::uword l = 0; l < nSymbols(r); l++) { + for (arma::uword i = 0; i < emission.n_rows; i++) { if (emission(i, l, r) > -arma::datum::inf) { arma::vec tmpn(obs.n_cols); - for (unsigned int t = 0; t < obs.n_cols; t++) { + for (arma::uword t = 0; t < obs.n_cols; t++) { if (l == (obs(r, t, k))) { tmpn(t) = alpha(i, t, k) + beta(i, t, k); } else @@ -95,7 +95,7 @@ Rcpp::List log_EM(const arma::mat& transition_, const arma::cube& emission_, ksii.each_col() /= sum(ksii, 1); transition = log(ksii); } - for (unsigned int r = 0; r < emission.n_slices; r++) { + for (arma::uword r = 0; r < emission.n_slices; r++) { gamma.slice(r).cols(0, nSymbols(r) - 1).each_col() /= sum( gamma.slice(r).cols(0, nSymbols(r) - 1), 1); emission.slice(r).cols(0, nSymbols(r) - 1) = log(gamma.slice(r).cols(0, nSymbols(r) - 1)); @@ -110,7 +110,7 @@ Rcpp::List log_EM(const arma::mat& transition_, const arma::cube& emission_, #pragma omp parallel for if(obs.n_slices >= threads) schedule(static) num_threads(threads) \ default(none) shared(obs, alpha, ll) - for (unsigned int k = 0; k < obs.n_slices; k++) { + for (arma::uword k = 0; k < obs.n_slices; k++) { ll(k) = logSumExp(alpha.slice(k).col(obs.n_cols - 1)); } diff --git a/src/log_EMx.cpp b/src/log_EMx.cpp index a5032b58..73e92e25 100644 --- a/src/log_EMx.cpp +++ b/src/log_EMx.cpp @@ -10,7 +10,7 @@ Rcpp::List log_EMx(const arma::mat& transition_, const arma::cube& emission_, const arma::vec& init_, const arma::ucube& obs, const arma::uvec& nSymbols, const arma::mat& coef_, const arma::mat& X, const arma::uvec& numberOfStates, - int itermax, double tol, int trace, unsigned int threads) { + int itermax, double tol, int trace, arma::uword threads) { // Make sure we don't alter the original vec/mat/cube // needed for cube, in future maybe in other cases as well @@ -29,7 +29,7 @@ Rcpp::List log_EMx(const arma::mat& transition_, const arma::cube& emission_, weights = log(weights); arma::mat initk(emission.n_rows, obs.n_slices); - for (unsigned int k = 0; k < obs.n_slices; k++) { + for (arma::uword k = 0; k < obs.n_slices; k++) { initk.col(k) = init + reparma(weights.col(k), numberOfStates); } @@ -43,7 +43,7 @@ Rcpp::List log_EMx(const arma::mat& transition_, const arma::cube& emission_, #pragma omp parallel for if(obs.n_slices >= threads) schedule(static) num_threads(threads) \ default(none) shared(obs, alpha, ll) - for (unsigned int k = 0; k < obs.n_slices; k++) { + for (arma::uword k = 0; k < obs.n_slices; k++) { ll(k) = logSumExp(alpha.slice(k).col(obs.n_cols - 1)); } @@ -65,21 +65,21 @@ Rcpp::List log_EMx(const arma::mat& transition_, const arma::cube& emission_, arma::cube gamma(emission.n_rows, emission.n_cols, emission.n_slices, arma::fill::zeros); arma::vec delta(emission.n_rows, arma::fill::zeros); - for (unsigned int k = 0; k < obs.n_slices; k++) { + for (arma::uword k = 0; k < obs.n_slices; k++) { delta += exp(alpha.slice(k).col(0) + beta.slice(k).col(0) - ll(k)); } #pragma omp parallel for if(obs.n_slices>=threads) schedule(static) num_threads(threads) \ default(none) shared(transition, obs, ll, alpha, beta, emission, ksii, gamma, nSymbols) - for (unsigned int k = 0; k < obs.n_slices; k++) { + for (arma::uword k = 0; k < obs.n_slices; k++) { if (obs.n_cols > 1) { - for (unsigned int j = 0; j < emission.n_rows; j++) { - for (unsigned int i = 0; i < emission.n_rows; i++) { + for (arma::uword j = 0; j < emission.n_rows; j++) { + for (arma::uword i = 0; i < emission.n_rows; i++) { if (transition(i, j) > -arma::datum::inf) { arma::vec tmpnm1(obs.n_cols - 1); - for (unsigned int t = 0; t < (obs.n_cols - 1); t++) { + for (arma::uword t = 0; t < (obs.n_cols - 1); t++) { tmpnm1(t) = alpha(i, t, k) + transition(i, j) + beta(j, t + 1, k); - for (unsigned int r = 0; r < obs.n_rows; r++) { + for (arma::uword r = 0; r < obs.n_rows; r++) { tmpnm1(t) += emission(j, obs(r, t + 1, k), r); } } @@ -90,12 +90,12 @@ Rcpp::List log_EMx(const arma::mat& transition_, const arma::cube& emission_, } } - for (unsigned int r = 0; r < emission.n_slices; r++) { - for (unsigned int l = 0; l < nSymbols[r]; l++) { - for (unsigned int i = 0; i < emission.n_rows; i++) { + for (arma::uword r = 0; r < emission.n_slices; r++) { + for (arma::uword l = 0; l < nSymbols[r]; l++) { + for (arma::uword i = 0; i < emission.n_rows; i++) { if (emission(i, l, r) > -arma::datum::inf) { arma::vec tmpn(obs.n_cols); - for (unsigned int t = 0; t < obs.n_cols; t++) { + for (arma::uword t = 0; t < obs.n_cols; t++) { if (l == (obs(r, t, k))) { tmpn(t) = alpha(i, t, k) + beta(i, t, k); } else @@ -110,7 +110,7 @@ Rcpp::List log_EMx(const arma::mat& transition_, const arma::cube& emission_, } } - unsigned int error = log_optCoef(weights, obs, emission, initk, beta, ll, coef, X, cumsumstate, + arma::uword error = log_optCoef(weights, obs, emission, initk, beta, ll, coef, X, cumsumstate, numberOfStates, trace); if (error != 0) { return Rcpp::List::create(Rcpp::Named("error") = error); @@ -119,27 +119,27 @@ Rcpp::List log_EMx(const arma::mat& transition_, const arma::cube& emission_, ksii.each_col() /= sum(ksii, 1); transition = log(ksii); } - for (unsigned int r = 0; r < emission.n_slices; r++) { + for (arma::uword r = 0; r < emission.n_slices; r++) { gamma.slice(r).cols(0, nSymbols(r) - 1).each_col() /= sum( gamma.slice(r).cols(0, nSymbols(r) - 1), 1); emission.slice(r).cols(0, nSymbols(r) - 1) = log(gamma.slice(r).cols(0, nSymbols(r) - 1)); } - for (unsigned int i = 0; i < numberOfStates.n_elem; i++) { + for (arma::uword i = 0; i < numberOfStates.n_elem; i++) { delta.subvec(cumsumstate(i) - numberOfStates(i), cumsumstate(i) - 1) /= arma::as_scalar( arma::accu(delta.subvec(cumsumstate(i) - numberOfStates(i), cumsumstate(i) - 1))); } init = log(delta); - for (unsigned int k = 0; k < obs.n_slices; k++) { + for (arma::uword k = 0; k < obs.n_slices; k++) { initk.col(k) = init + reparma(weights.col(k), numberOfStates); } log_internalForwardx(transition, emission, initk, obs, alpha, threads); log_internalBackward(transition, emission, obs, beta, threads); - for (unsigned int k = 0; k < obs.n_slices; k++) { + for (arma::uword k = 0; k < obs.n_slices; k++) { ll(k) = logSumExp(alpha.slice(k).col(obs.n_cols - 1)); } diff --git a/src/log_forward_backward.h b/src/log_forward_backward.h index 80142d00..a9019869 100644 --- a/src/log_forward_backward.h +++ b/src/log_forward_backward.h @@ -4,13 +4,13 @@ #include void log_internalForwardx(const arma::mat& transition, const arma::cube& emission, - const arma::mat& init, const arma::ucube& obs, arma::cube& alpha, unsigned int threads); + const arma::mat& init, const arma::ucube& obs, arma::cube& alpha, arma::uword threads); void log_internalForward(const arma::mat& transition, const arma::cube& emission, - const arma::vec& init, const arma::ucube& obs, arma::cube& alpha, unsigned int threads); + const arma::vec& init, const arma::ucube& obs, arma::cube& alpha, arma::uword threads); void log_internalBackward(const arma::mat& transition, const arma::cube& emission, - const arma::ucube& obs, arma::cube& beta, unsigned int threads); + const arma::ucube& obs, arma::cube& beta, arma::uword threads); #endif diff --git a/src/log_forwardbackward.cpp b/src/log_forwardbackward.cpp index 3720f2ca..19771377 100644 --- a/src/log_forwardbackward.cpp +++ b/src/log_forwardbackward.cpp @@ -5,7 +5,7 @@ // [[Rcpp::export]] Rcpp::List log_forwardbackward(const arma::mat& transition_, const arma::cube& emission_, - const arma::vec& init_, const arma::ucube& obs, bool forwardonly, unsigned int threads) { + const arma::vec& init_, const arma::ucube& obs, bool forwardonly, arma::uword threads) { arma::vec init = log(init_); arma::mat transition = log(transition_); diff --git a/src/log_forwardbackwardx.cpp b/src/log_forwardbackwardx.cpp index d3266346..4a48fd42 100644 --- a/src/log_forwardbackwardx.cpp +++ b/src/log_forwardbackwardx.cpp @@ -8,7 +8,7 @@ Rcpp::List log_forwardbackwardx(const arma::mat& transition_, const arma::cube& emission_, const arma::vec& init_, const arma::ucube& obs, const arma::mat& coef, const arma::mat& X, - const arma::uvec& numberOfStates, bool forwardonly, unsigned int threads) { + const arma::uvec& numberOfStates, bool forwardonly, arma::uword threads) { arma::vec init = log(init_); arma::mat transition = log(transition_); @@ -19,7 +19,7 @@ Rcpp::List log_forwardbackwardx(const arma::mat& transition_, weights = log(weights); arma::mat initk(emission.n_rows, obs.n_slices); - for (unsigned int k = 0; k < obs.n_slices; k++) { + for (arma::uword k = 0; k < obs.n_slices; k++) { initk.col(k) = init + reparma(weights.col(k), numberOfStates); } arma::cube alpha(emission.n_rows, obs.n_cols, obs.n_slices); //m,n,k diff --git a/src/log_internalBackward.cpp b/src/log_internalBackward.cpp index 0cf921e1..3a294dee 100644 --- a/src/log_internalBackward.cpp +++ b/src/log_internalBackward.cpp @@ -5,17 +5,17 @@ #include "useomp.h" void log_internalBackward(const arma::mat& transition, const arma::cube& emission, - const arma::ucube& obs, arma::cube& beta, unsigned int threads) { + const arma::ucube& obs, arma::cube& beta, arma::uword threads) { #pragma omp parallel for if(obs.n_slices >= threads) schedule(static) num_threads(threads) \ default(none) shared(beta, obs, emission,transition) - for (unsigned int k = 0; k < obs.n_slices; k++) { + for (arma::uword k = 0; k < obs.n_slices; k++) { beta.slice(k).col(obs.n_cols - 1).zeros(); for (int t = (obs.n_cols - 2); t >= 0; t--) { arma::vec tmpbeta(transition.n_rows); - for (unsigned int i = 0; i < transition.n_rows; i++) { + for (arma::uword i = 0; i < transition.n_rows; i++) { tmpbeta = beta.slice(k).col(t + 1) + transition.row(i).t(); - for (unsigned int r = 0; r < obs.n_rows; r++) { + for (arma::uword r = 0; r < obs.n_rows; r++) { tmpbeta += emission.slice(r).col(obs(r, t + 1, k)); } beta(i, t, k) = logSumExp(tmpbeta); diff --git a/src/log_internalForward.cpp b/src/log_internalForward.cpp index 85c03424..0ab38001 100644 --- a/src/log_internalForward.cpp +++ b/src/log_internalForward.cpp @@ -5,20 +5,20 @@ #include "useomp.h" void log_internalForward(const arma::mat& transition, const arma::cube& emission, - const arma::vec& init, const arma::ucube& obs, arma::cube& alpha, unsigned int threads) { + const arma::vec& init, const arma::ucube& obs, arma::cube& alpha, arma::uword threads) { #pragma omp parallel for if(obs.n_slices >= threads) schedule(static) num_threads(threads) \ default(none) shared(alpha, obs, init, emission, transition) - for (unsigned int k = 0; k < obs.n_slices; k++) { + for (arma::uword k = 0; k < obs.n_slices; k++) { alpha.slice(k).col(0) = init; - for (unsigned int r = 0; r < obs.n_rows; r++) { + for (arma::uword r = 0; r < obs.n_rows; r++) { alpha.slice(k).col(0) += emission.slice(r).col(obs(r, 0, k)); } - for (unsigned int t = 1; t < obs.n_cols; t++) { - for (unsigned int i = 0; i < transition.n_rows; i++) { + for (arma::uword t = 1; t < obs.n_cols; t++) { + for (arma::uword i = 0; i < transition.n_rows; i++) { alpha(i, t, k) = logSumExp(alpha.slice(k).col(t - 1) + transition.col(i)); } - for (unsigned int r = 0; r < obs.n_rows; r++) { + for (arma::uword r = 0; r < obs.n_rows; r++) { alpha.slice(k).col(t) += emission.slice(r).col(obs(r, t, k)); } } @@ -26,20 +26,20 @@ void log_internalForward(const arma::mat& transition, const arma::cube& emission } void log_internalForwardx(const arma::mat& transition, const arma::cube& emission, - const arma::mat& init, const arma::ucube& obs, arma::cube& alpha, unsigned int threads) { + const arma::mat& init, const arma::ucube& obs, arma::cube& alpha, arma::uword threads) { #pragma omp parallel for if(obs.n_slices >= threads) schedule(static) num_threads(threads) \ default(none) shared(alpha, obs, init, emission, transition) - for (unsigned int k = 0; k < obs.n_slices; k++) { + for (arma::uword k = 0; k < obs.n_slices; k++) { alpha.slice(k).col(0) = init.col(k); - for (unsigned int r = 0; r < obs.n_rows; r++) { + for (arma::uword r = 0; r < obs.n_rows; r++) { alpha.slice(k).col(0) += emission.slice(r).col(obs(r, 0, k)); } - for (unsigned int t = 1; t < obs.n_cols; t++) { - for (unsigned int i = 0; i < transition.n_rows; i++) { + for (arma::uword t = 1; t < obs.n_cols; t++) { + for (arma::uword i = 0; i < transition.n_rows; i++) { alpha(i, t, k) = logSumExp(alpha.slice(k).col(t - 1) + transition.col(i)); } - for (unsigned int r = 0; r < obs.n_rows; r++) { + for (arma::uword r = 0; r < obs.n_rows; r++) { alpha.slice(k).col(t) += emission.slice(r).col(obs(r, t, k)); } } diff --git a/src/log_logLikHMM.cpp b/src/log_logLikHMM.cpp index dc26158b..feaf6d07 100644 --- a/src/log_logLikHMM.cpp +++ b/src/log_logLikHMM.cpp @@ -5,7 +5,7 @@ // [[Rcpp::export]] Rcpp::NumericVector log_logLikHMM(const arma::mat& transition_, const arma::cube& emission_, - const arma::vec& init_, const arma::ucube& obs, unsigned int threads) { + const arma::vec& init_, const arma::ucube& obs, arma::uword threads) { arma::vec init = log(init_); arma::mat transition = log(transition_); @@ -14,18 +14,18 @@ Rcpp::NumericVector log_logLikHMM(const arma::mat& transition_, const arma::cube arma::vec ll(obs.n_slices); #pragma omp parallel for if(obs.n_slices >= threads) schedule(static) num_threads(threads) \ default(none) shared(ll, obs, init, emission, transition) - for (unsigned int k = 0; k < obs.n_slices; k++) { + for (arma::uword k = 0; k < obs.n_slices; k++) { arma::vec alpha = init; - for (unsigned int r = 0; r < obs.n_rows; r++) { + for (arma::uword r = 0; r < obs.n_rows; r++) { alpha += emission.slice(r).col(obs(r, 0, k)); } arma::vec alphatmp(emission.n_rows); - for (unsigned int t = 1; t < obs.n_cols; t++) { - for (unsigned int i = 0; i < emission.n_rows; i++) { + for (arma::uword t = 1; t < obs.n_cols; t++) { + for (arma::uword i = 0; i < emission.n_rows; i++) { alphatmp(i) = logSumExp(alpha + transition.col(i)); - for (unsigned int r = 0; r < obs.n_rows; r++) { + for (arma::uword r = 0; r < obs.n_rows; r++) { alphatmp(i) += emission(i, obs(r, t, k), r); } } diff --git a/src/log_logLikMixHMM.cpp b/src/log_logLikMixHMM.cpp index b0e32980..a943af9d 100644 --- a/src/log_logLikMixHMM.cpp +++ b/src/log_logLikMixHMM.cpp @@ -7,7 +7,7 @@ // [[Rcpp::export]] Rcpp::NumericVector log_logLikMixHMM(arma::mat transition, arma::cube emission, arma::vec init, const arma::ucube& obs, const arma::mat& coef, const arma::mat& X, - const arma::uvec& numberOfStates, unsigned int threads) { + const arma::uvec& numberOfStates, arma::uword threads) { arma::mat weights = exp(X * coef).t(); if (!weights.is_finite()) { @@ -24,16 +24,16 @@ Rcpp::NumericVector log_logLikMixHMM(arma::mat transition, arma::cube emission, #pragma omp parallel for if(obs.n_slices >= threads) schedule(static) num_threads(threads) \ default(none) shared(ll, obs, weights, init, emission, transition, numberOfStates) - for (unsigned int k = 0; k < obs.n_slices; k++) { + for (arma::uword k = 0; k < obs.n_slices; k++) { arma::vec alpha = init + reparma(weights.col(k), numberOfStates); - for (unsigned int r = 0; r < obs.n_rows; r++) { + for (arma::uword r = 0; r < obs.n_rows; r++) { alpha += emission.slice(r).col(obs(r, 0, k)); } arma::vec alphatmp(emission.n_rows); - for (unsigned int t = 1; t < obs.n_cols; t++) { - for (unsigned int i = 0; i < emission.n_rows; i++) { + for (arma::uword t = 1; t < obs.n_cols; t++) { + for (arma::uword i = 0; i < emission.n_rows; i++) { alphatmp(i) = logSumExp(alpha + transition.col(i)); - for (unsigned int r = 0; r < obs.n_rows; r++) { + for (arma::uword r = 0; r < obs.n_rows; r++) { alphatmp(i) += emission(i, obs(r, t, k), r); } } diff --git a/src/log_objective.cpp b/src/log_objective.cpp index 1aa01a6b..6d9e7a93 100644 --- a/src/log_objective.cpp +++ b/src/log_objective.cpp @@ -7,7 +7,7 @@ // [[Rcpp::export]] Rcpp::List log_objective(const arma::mat& transition, const arma::cube& emission, const arma::vec& init, const arma::ucube& obs, const arma::umat& ANZ, - const arma::ucube& BNZ, const arma::uvec& INZ, arma::uvec& nSymbols, unsigned int threads) { + const arma::ucube& BNZ, const arma::uvec& INZ, arma::uvec& nSymbols, arma::uword threads) { arma::vec grad(arma::accu(ANZ) + arma::accu(BNZ) + arma::accu(INZ), arma::fill::zeros); @@ -22,7 +22,7 @@ Rcpp::List log_objective(const arma::mat& transition, const arma::cube& emission log_internalBackward(transitionLog, emissionLog, obs, beta, threads); arma::vec ll(obs.n_slices); - for (unsigned int k = 0; k < obs.n_slices; k++) { + for (arma::uword k = 0; k < obs.n_slices; k++) { ll(k) = logSumExp(alpha.slice(k).col(obs.n_cols - 1)); } @@ -30,14 +30,14 @@ Rcpp::List log_objective(const arma::mat& transition, const arma::cube& emission arma::fill::zeros); #pragma omp parallel for if(obs.n_slices >= threads) schedule(static) num_threads(threads) default(shared) - for (unsigned int k = 0; k < obs.n_slices; k++) { + for (arma::uword k = 0; k < obs.n_slices; k++) { int countgrad = 0; // transitionMatrix arma::vec gradArow(emission.n_rows); arma::mat gradA(emission.n_rows, emission.n_rows); - for (unsigned int i = 0; i < emission.n_rows; i++) { + for (arma::uword i = 0; i < emission.n_rows; i++) { arma::uvec ind = arma::find(ANZ.row(i)); if (ind.n_elem > 0) { @@ -46,10 +46,10 @@ Rcpp::List log_objective(const arma::mat& transition, const arma::cube& emission gradA.each_row() -= transition.row(i); gradA.each_col() %= transition.row(i).t(); - for (unsigned int t = 0; t < (obs.n_cols - 1); t++) { - for (unsigned int j = 0; j < emission.n_rows; j++) { + for (arma::uword t = 0; t < (obs.n_cols - 1); t++) { + for (arma::uword j = 0; j < emission.n_rows; j++) { double tmp = 0.0; - for (unsigned int r = 0; r < obs.n_rows; r++) { + for (arma::uword r = 0; r < obs.n_rows; r++) { tmp += emissionLog(j, obs(r, t + 1, k), r); } gradArow(j) += exp(alpha(i, t, k) + tmp + beta(j, t + 1, k) - ll(k)); @@ -63,30 +63,30 @@ Rcpp::List log_objective(const arma::mat& transition, const arma::cube& emission } } // emissionMatrix - for (unsigned int r = 0; r < obs.n_rows; r++) { + for (arma::uword r = 0; r < obs.n_rows; r++) { arma::vec gradBrow(nSymbols[r]); arma::mat gradB(nSymbols[r], nSymbols[r]); - for (unsigned int i = 0; i < emission.n_rows; i++) { + for (arma::uword i = 0; i < emission.n_rows; i++) { arma::uvec ind = arma::find(BNZ.slice(r).row(i)); if (ind.n_elem > 0) { gradBrow.zeros(); gradB.eye(); gradB.each_row() -= emission.slice(r).row(i).subvec(0, nSymbols[r] - 1); gradB.each_col() %= emission.slice(r).row(i).subvec(0, nSymbols[r] - 1).t(); - for (unsigned int j = 0; j < nSymbols[r]; j++) { + for (arma::uword j = 0; j < nSymbols[r]; j++) { if (obs(r, 0, k) == j) { double tmp = 0.0; - for (unsigned int r2 = 0; r2 < obs.n_rows; r2++) { + for (arma::uword r2 = 0; r2 < obs.n_rows; r2++) { if (r2 != r) { tmp += emissionLog(i, obs(r2, 0, k), r2); } } gradBrow(j) += exp(initLog(i) + tmp + beta(i, 0, k) - ll(k)); } - for (unsigned int t = 0; t < (obs.n_cols - 1); t++) { + for (arma::uword t = 0; t < (obs.n_cols - 1); t++) { if (obs(r, t + 1, k) == j) { double tmp = 0.0; - for (unsigned int r2 = 0; r2 < obs.n_rows; r2++) { + for (arma::uword r2 = 0; r2 < obs.n_rows; r2++) { if (r2 != r) { tmp += emissionLog(i, obs(r2, t + 1, k), r2); } @@ -116,9 +116,9 @@ Rcpp::List log_objective(const arma::mat& transition, const arma::cube& emission gradI.eye(); gradI.each_row() -= init.t(); gradI.each_col() %= init; - for (unsigned int j = 0; j < emission.n_rows; j++) { + for (arma::uword j = 0; j < emission.n_rows; j++) { double tmp = 0.0; - for (unsigned int r = 0; r < obs.n_rows; r++) { + for (arma::uword r = 0; r < obs.n_rows; r++) { tmp += emissionLog(j, obs(r, 0, k), r); } gradIrow(j) += exp(tmp + beta(j, 0, k) - ll(k)); diff --git a/src/log_objective_nhmm.cpp b/src/log_objective_nhmm.cpp deleted file mode 100644 index c2e46041..00000000 --- a/src/log_objective_nhmm.cpp +++ /dev/null @@ -1,517 +0,0 @@ -// log-likelihood and gradients of NHMM -#include "forward_nhmm.h" -#include "backward_nhmm.h" -#include "eta_to_gamma.h" -#include "get_parameters.h" -#include "logsumexp.h" -#include "gradients.h" - -// Precomputed transformation matrices Q are actually t(Q). -// [[Rcpp::export]] -Rcpp::List log_objective_nhmm_singlechannel( - const arma::mat& Qs, const arma::mat& Qm, - const arma::mat& eta_pi, const arma::mat& X_i, - const arma::cube& eta_A, const arma::cube& X_s, - const arma::cube& eta_B, const arma::cube& X_o, - const arma::umat& obs, const bool iv_pi, const bool iv_A, const bool iv_B, - const bool tv_A, const bool tv_B, const arma::uvec& Ti) { - - unsigned int N = X_s.n_slices; - unsigned int T = X_s.n_cols; - unsigned int S = eta_A.n_slices; - unsigned int M = eta_B.n_rows + 1; - arma::vec loglik(N); - arma::mat log_alpha(S, T); - arma::mat log_beta(S, T); - arma::mat log_py(S, T); - - arma::vec Pi(S); - arma::cube A(S, S, T); - arma::cube B(S, M + 1, T); - arma::vec log_Pi(S); - arma::cube log_A(S, S, T); - arma::cube log_B(S, M + 1, T); - - arma::mat grad_pi(S - 1, X_i.n_rows, arma::fill::zeros); - arma::cube grad_A(S - 1, X_s.n_rows, S, arma::fill::zeros); - arma::cube grad_B(M - 1, X_o.n_rows, S, arma::fill::zeros); - - arma::mat gamma_pi = eta_to_gamma(eta_pi, Qs.t()); - arma::cube gamma_A = eta_to_gamma(eta_A, Qs.t()); - arma::cube gamma_B = eta_to_gamma(eta_B, Qm.t()); - arma::mat tmpmat(S, S); - arma::vec tmpvec(M); - for (unsigned int i = 0; i < N; i++) { - if (iv_pi || i == 0) { - Pi = get_pi(gamma_pi, X_i.col(i)); - log_Pi = arma::log(Pi); - } - if (iv_A || i == 0) { - A = get_A(gamma_A, X_s.slice(i), tv_A); - log_A = arma::log(A); - } - if (iv_B || i == 0) { - B = get_B(gamma_B, X_o.slice(i), tv_B, true); - log_B = arma::log(B); - } - for (unsigned int t = 0; t < Ti(i); t++) { - log_py.col(t) = log_B.slice(t).col(obs(t, i)); - } - univariate_forward_nhmm(log_alpha, log_Pi, log_A, log_py.cols(0, Ti(i) - 1)); - univariate_backward_nhmm(log_beta, log_A, log_py.cols(0, Ti(i) - 1)); - double ll = logSumExp(log_alpha.col(Ti(i) - 1)); - if (!std::isfinite(ll)) { - double small = -arma::datum::inf; // -std::max(std::min(1e10, N * 1e5), 1e3); - grad_pi.fill(small); - grad_A.fill(small); - grad_B.fill(small); - return Rcpp::List::create( - Rcpp::Named("loglik") = -arma::datum::inf, - Rcpp::Named("gradient_pi") = Rcpp::wrap(grad_pi), - Rcpp::Named("gradient_A") = Rcpp::wrap(grad_A), - Rcpp::Named("gradient_B") = Rcpp::wrap(grad_B) - ); - } - loglik(i) = ll; - // gradient wrt gamma_pi - gradient_wrt_pi(grad_pi, tmpmat, Qs, log_py, log_beta, ll, Pi, X_i, i); - // gradient wrt gamma_A - for (unsigned int t = 0; t < (Ti(i) - 1); t++) { - for (unsigned int s = 0; s < S; s++) { - gradient_wrt_A(grad_A.slice(s), tmpmat, Qs, log_py, log_alpha, log_beta, ll, A, X_s, i, t, s); - } - } - // gradient wrt gamma_B - for (unsigned int s = 0; s < S; s++) { - if (obs(0, i) < M) { - gradient_wrt_B_t0(grad_B.slice(s), tmpvec, Qm, obs, log_Pi, log_beta, ll, B, X_o, i, s); - } - for (unsigned int t = 0; t < (Ti(i) - 1); t++) { - if (obs(t + 1, i) < M) { - gradient_wrt_B(grad_B.slice(s), tmpvec, Qm, obs, log_alpha, log_beta, ll, log_A, B, X_o, i, s, t); - } - } - } - } - return Rcpp::List::create( - Rcpp::Named("loglik") = sum(loglik), - Rcpp::Named("gradient_pi") = Rcpp::wrap(grad_pi), - Rcpp::Named("gradient_A") = Rcpp::wrap(grad_A), - Rcpp::Named("gradient_B") = Rcpp::wrap(grad_B) - ); -} - - -// [[Rcpp::export]] -Rcpp::List log_objective_nhmm_multichannel( - const arma::mat& Qs, const arma::field& Qm, - const arma::mat& eta_pi, const arma::mat& X_i, - const arma::cube& eta_A, const arma::cube& X_s, - const arma::field& eta_B, const arma::cube& X_o, - const arma::ucube& obs, const arma::uvec& M, const bool iv_pi, - const bool iv_A, const bool iv_B, const bool tv_A, const bool tv_B, - const arma::uvec& Ti) { - - unsigned int C = M.n_elem; - unsigned int N = X_s.n_slices; - unsigned int T = X_s.n_cols; - unsigned int S = eta_A.n_slices; - arma::vec loglik(N); - arma::mat log_alpha(S, T); - arma::mat log_beta(S, T); - arma::mat log_py(S, T); - arma::vec log_Pi(S); - arma::cube log_A(S, S, T); - arma::field log_B(C); - arma::vec Pi(S); - arma::cube A(S, S, T); - arma::field B(C); - arma::mat grad_pi(S - 1, X_i.n_rows, arma::fill::zeros); - arma::cube grad_A(S - 1, X_s.n_rows, S, arma::fill::zeros); - arma::field grad_B(C); - for (unsigned int c = 0; c < C; c++) { - grad_B(c) = arma::cube(M(c) - 1, X_o.n_rows, S, arma::fill::zeros); - } - arma::mat gamma_pi = eta_to_gamma(eta_pi, Qs.t()); - arma::cube gamma_A = eta_to_gamma(eta_A, Qs.t()); - arma::field gamma_B = eta_to_gamma(eta_B); - arma::mat tmpmat(S, S); - arma::field tmpvec(C); - for (unsigned int c = 0; c < C; c++) { - tmpvec(c) = arma::vec(M(c)); - } - for (unsigned int i = 0; i < N; i++) { - log_py.zeros(); - if (iv_pi || i == 0) { - Pi = get_pi(gamma_pi, X_i.col(i)); - log_Pi = arma::log(Pi); - } - if (iv_A || i == 0) { - A = get_A(gamma_A, X_s.slice(i), tv_A); - log_A = arma::log(A); - } - if (iv_B || i == 0) { - B = get_B(gamma_B, X_o.slice(i), M, tv_B, true); - for (unsigned int c = 0; c < C; c++) { - log_B(c) = arma::log(B(c)); - } - } - for (unsigned int t = 0; t < Ti(i); t++) { - for (unsigned int c = 0; c < C; c++) { - log_py.col(t) += log_B(c).slice(t).col(obs(c, t, i)); - } - } - univariate_forward_nhmm(log_alpha, log_Pi, log_A, log_py.cols(0, Ti(i) - 1)); - univariate_backward_nhmm(log_beta, log_A, log_py.cols(0, Ti(i) - 1)); - double ll = logSumExp(log_alpha.col(Ti(i) - 1)); - if (!std::isfinite(ll)) { - double small = -arma::datum::inf; // -std::max(std::min(1e10, N * 1e5), 1e3); - grad_pi.fill(small); - grad_A.fill(small); - for (unsigned int c = 0; c < C; c++) { - grad_B(c).fill(small); - } - return Rcpp::List::create( - Rcpp::Named("loglik") = -arma::datum::inf, - Rcpp::Named("gradient_pi") = Rcpp::wrap(grad_pi), - Rcpp::Named("gradient_A") = Rcpp::wrap(grad_A), - Rcpp::Named("gradient_B") = Rcpp::wrap(grad_B) - ); - } - loglik(i) = ll; - // gradient wrt gamma_pi - gradient_wrt_pi(grad_pi, tmpmat, Qs, log_py, log_beta, ll, Pi, X_i, i); - // gradient wrt gamma_A - for (unsigned int t = 0; t < (Ti(i) - 1); t++) { - for (unsigned int s = 0; s < S; s++) { - gradient_wrt_A( - grad_A.slice(s), tmpmat, Qs, log_py, log_alpha, log_beta, ll, A, - X_s, i, t, s - ); - } - } - for (unsigned int c = 0; c < C; c++) { - for (unsigned int s = 0; s < S; s++) { - if (obs(c, 0, i) < M(c)) { - gradient_wrt_B_t0( - grad_B(c).slice(s), tmpvec(c), Qm(c), obs, log_Pi, log_beta, ll, - log_B, B, X_o, M, i, s, c - ); - } - for (unsigned int t = 0; t < (Ti(i) - 1); t++) { - if (obs(c, t + 1, i) < M(c)) { - gradient_wrt_B( - grad_B(c).slice(s), tmpvec(c), Qm(c), obs, log_alpha, log_beta, - ll, log_A, log_B, B, X_o, M, i, s, t, c - ); - } - } - } - } - } - return Rcpp::List::create( - Rcpp::Named("loglik") = sum(loglik), - Rcpp::Named("gradient_pi") = Rcpp::wrap(grad_pi), - Rcpp::Named("gradient_A") = Rcpp::wrap(grad_A), - Rcpp::Named("gradient_B") = Rcpp::wrap(grad_B) - ); -} - -// [[Rcpp::export]] -Rcpp::List log_objective_mnhmm_singlechannel( - const arma::mat& Qs, const arma::mat& Qm, const arma::mat& Qd, - const arma::field& eta_pi, const arma::mat& X_i, - const arma::field& eta_A, const arma::cube& X_s, - const arma::field& eta_B, const arma::cube& X_o, - const arma::mat& eta_omega, const arma::mat& X_d, - const arma::umat& obs, const bool iv_pi, const bool iv_A, const bool iv_B, - const bool tv_A, const bool tv_B, const bool iv_omega, - const arma::uvec& Ti) { - - unsigned int N = X_s.n_slices; - unsigned int T = X_s.n_cols; - unsigned int S = eta_A(0).n_slices; - unsigned int D = eta_omega.n_rows + 1; - unsigned int M = eta_B(0).n_rows + 1; - arma::vec loglik(N); - arma::vec loglik_i(D); - arma::cube log_alpha(S, T, D); - arma::cube log_beta(S, T, D); - arma::cube log_py(S, T, D); - - arma::vec omega(D); - arma::field Pi(D); - arma::field A(D); - arma::field B(D); - arma::vec log_omega(D); - arma::field log_Pi(D); - arma::field log_A(D); - arma::field log_B(D); - - arma::mat grad_omega(D - 1, X_d.n_rows, arma::fill::zeros); - arma::field grad_pi(D); - arma::field grad_A(D); - arma::field grad_B(D); - for (unsigned int d = 0; d < D; d++) { - grad_pi(d) = arma::mat(S - 1, X_i.n_rows, arma::fill::zeros); - grad_A(d) = arma::cube(S - 1, X_s.n_rows, S, arma::fill::zeros); - grad_B(d) = arma::cube(M - 1, X_o.n_rows, S, arma::fill::zeros); - } - arma::mat gamma_omega = eta_to_gamma(eta_omega, Qd.t()); - arma::field gamma_pi = eta_to_gamma(eta_pi, Qs.t()); - arma::field gamma_A = eta_to_gamma(eta_A, Qs.t()); - arma::field gamma_B = eta_to_gamma(eta_B, Qm.t()); - arma::mat tmpmat(S, S); - arma::mat tmpmatD(D, D); - arma::vec tmpvec(M); - for (unsigned int i = 0; i < N; i++) { - log_py.zeros(); - if (iv_omega || i == 0) { - omega = get_omega(gamma_omega, X_d.col(i)); - log_omega = arma::log(omega); - } - for (unsigned int d = 0; d < D; d++) { - if (iv_pi || i == 0) { - Pi(d) = get_pi(gamma_pi(d), X_i.col(i)); - log_Pi(d) = arma::log(Pi(d)); - } - if (iv_A || i == 0) { - A(d) = get_A(gamma_A(d), X_s.slice(i), tv_A); - log_A(d) = arma::log(A(d)); - } - if (iv_B || i == 0) { - B(d) = get_B(gamma_B(d), X_o.slice(i), tv_B, true); - log_B(d) = arma::log(B(d)); - } - for (unsigned int t = 0; t < Ti(i); t++) { - log_py.slice(d).col(t) = log_B(d).slice(t).col(obs(t, i)); - } - univariate_forward_nhmm( - log_alpha.slice(d), log_Pi(d), log_A(d), - log_py.slice(d).cols(0, Ti(i) - 1) - ); - univariate_backward_nhmm( - log_beta.slice(d), log_A(d), - log_py.slice(d).cols(0, Ti(i) - 1) - ); - loglik_i(d) = logSumExp(log_alpha.slice(d).col(Ti(i) - 1)); - } - loglik(i) = logSumExp(log_omega + loglik_i); - if (!std::isfinite(loglik(i))) { - double small = -arma::datum::inf; // -std::max(std::min(1e10, N * 1e5), 1e3); - grad_omega.fill(small); - for (unsigned int d = 0; d < D; d++) { - grad_pi(d).fill(small); - grad_A(d).fill(small); - grad_B(d).fill(small); - } - return Rcpp::List::create( - Rcpp::Named("loglik") = -arma::datum::inf, - Rcpp::Named("gradient_pi") = Rcpp::wrap(grad_pi), - Rcpp::Named("gradient_A") = Rcpp::wrap(grad_A), - Rcpp::Named("gradient_B") = Rcpp::wrap(grad_B), - Rcpp::Named("gradient_omega") = Rcpp::wrap(grad_omega) - ); - } - // gradient wrt gamma_pi - // d loglik / d pi - for (unsigned int d = 0; d < D; d++) { - // gradient wrt gamma_pi - gradient_wrt_pi( - grad_pi(d), tmpmat, Qs, log_omega, log_py, log_beta, loglik, Pi, X_i, - i, d - ); - // gradient wrt gamma_A - for (unsigned int t = 0; t < (Ti(i) - 1); t++) { - for (unsigned int s = 0; s < S; s++) { - gradient_wrt_A( - grad_A(d).slice(s), tmpmat, Qs, log_omega, log_py, log_alpha, - log_beta, loglik, A, X_s, i, t, s, d - ); - } - } - for (unsigned int s = 0; s < S; s++) { - if (obs(0, i) < M) { - gradient_wrt_B_t0( - grad_B(d).slice(s), tmpvec, Qm, log_omega, obs, log_Pi, log_beta, - loglik, B, X_o, i, s, d - ); - } - for (unsigned int t = 0; t < (T - 1); t++) { - if (obs(t + 1, i) < M) { - gradient_wrt_B( - grad_B(d).slice(s), tmpvec, Qm, log_omega, obs, log_alpha, - log_beta, loglik, log_A, B, X_o, i, s, t, d - ); - } - } - } - } - gradient_wrt_omega(grad_omega, tmpmatD, Qd, omega, loglik_i, loglik, X_d, i); - } - return Rcpp::List::create( - Rcpp::Named("loglik") = sum(loglik), - Rcpp::Named("gradient_pi") = Rcpp::wrap(grad_pi), - Rcpp::Named("gradient_A") = Rcpp::wrap(grad_A), - Rcpp::Named("gradient_B") = Rcpp::wrap(grad_B), - Rcpp::Named("gradient_omega") = Rcpp::wrap(grad_omega) - ); -} - -// [[Rcpp::export]] -Rcpp::List log_objective_mnhmm_multichannel( - const arma::mat& Qs, const arma::field& Qm, const arma::mat& Qd, - const arma::field& eta_pi, const arma::mat& X_i, - const arma::field& eta_A, const arma::cube& X_s, - const arma::field& eta_B, const arma::cube& X_o, - const arma::mat& eta_omega, const arma::mat& X_d, - const arma::ucube& obs, const arma::uvec& M, const bool iv_pi, - const bool iv_A, const bool iv_B, const bool tv_A, const bool tv_B, - const bool iv_omega, const arma::uvec& Ti) { - - unsigned int N = X_s.n_slices; - unsigned int T = X_s.n_cols; - unsigned int S = eta_A(0).n_slices; - unsigned int D = eta_omega.n_rows + 1; - unsigned int C = M.n_elem; - arma::vec loglik(N); - arma::vec loglik_i(D); - arma::cube log_alpha(S, T, D); - arma::cube log_beta(S, T, D); - arma::cube log_py(S, T, D); - - arma::vec omega(D); - arma::field Pi(D); - arma::field A(D); - arma::field B(D * C); - arma::vec log_omega(D); - arma::field log_Pi(D); - arma::field log_A(D); - arma::field log_B(D * C); - - arma::mat grad_omega(D - 1, X_d.n_rows, arma::fill::zeros); - arma::field grad_pi(D); - arma::field grad_A(D); - arma::field grad_B(C, D); - for (unsigned int d = 0; d < D; d++) { - grad_pi(d) = arma::mat(S - 1, X_i.n_rows, arma::fill::zeros); - grad_A(d) = arma::cube(S - 1, X_s.n_rows, S, arma::fill::zeros); - for (unsigned int c = 0; c < C; c++) { - grad_B(c, d) = arma::cube(M(c) - 1, X_o.n_rows, S, arma::fill::zeros); - } - } - arma::mat gamma_omega = eta_to_gamma(eta_omega, Qd.t()); - arma::field gamma_pi = eta_to_gamma(eta_pi, Qs.t()); - arma::field gamma_A = eta_to_gamma(eta_A, Qs.t()); - arma::field gamma_B = eta_to_gamma(eta_B); - arma::mat tmpmat(S, S); - arma::mat tmpmatD(D, D); - arma::field tmpvec(C); - for (unsigned int c = 0; c < C; c++) { - tmpvec(c) = arma::vec(M(c)); - } - for (unsigned int i = 0; i < N; i++) { - log_py.zeros(); - if (iv_omega || i == 0) { - omega = get_omega(gamma_omega, X_d.col(i)); - log_omega = arma::log(omega); - } - for (unsigned int d = 0; d < D; d++) { - if (iv_pi || i == 0) { - Pi(d) = get_pi(gamma_pi(d), X_i.col(i)); - log_Pi(d) = arma::log(Pi(d)); - } - if (iv_A || i == 0) { - A(d) = get_A(gamma_A(d), X_s.slice(i), tv_A); - log_A(d) = arma::log(A(d)); - } - if (iv_B || i == 0) { - B.rows(d * C, (d + 1) * C - 1) = get_B( - gamma_B.rows(d * C, (d + 1) * C - 1), X_o.slice(i), M, tv_B, true - ); - for(unsigned int c = 0; c < C; c++) { - log_B(d * C + c) = arma::log(B(d * C + c)); - } - } - for (unsigned int t = 0; t < Ti(i); t++) { - for (unsigned int c = 0; c < C; c++) { - log_py.slice(d).col(t) += log_B(d * C + c).slice(t).col(obs(c, t, i)); - } - } - univariate_forward_nhmm( - log_alpha.slice(d), log_Pi(d), log_A(d), - log_py.slice(d).cols(0, Ti(i) - 1) - ); - univariate_backward_nhmm( - log_beta.slice(d), log_A(d), - log_py.slice(d).cols(0, Ti(i) - 1) - ); - loglik_i(d) = logSumExp(log_alpha.slice(d).col(Ti(i) - 1)); - } - loglik(i) = logSumExp(log_omega + loglik_i); - if (!std::isfinite(loglik(i))) { - double small = -arma::datum::inf; // -std::max(std::min(1e10, N * 1e5), 1e3); - grad_omega.fill(small); - for (unsigned int d = 0; d < D; d++) { - grad_pi(d).fill(small); - grad_A(d).fill(small); - for (unsigned int c = 0; c < C; c++) { - grad_B(c, d).fill(small); - } - } - return Rcpp::List::create( - Rcpp::Named("loglik") = -arma::datum::inf, - Rcpp::Named("gradient_pi") = Rcpp::wrap(grad_pi), - Rcpp::Named("gradient_A") = Rcpp::wrap(grad_A), - Rcpp::Named("gradient_B") = Rcpp::wrap(grad_B), - Rcpp::Named("gradient_omega") = Rcpp::wrap(grad_omega) - ); - } - // gradient wrt gamma_pi - // d loglik / d pi - for (unsigned int d = 0; d < D; d++) { - gradient_wrt_pi( - grad_pi(d), tmpmat, Qs, log_omega, log_py, log_beta, loglik, Pi, X_i, - i, d - ); - // gradient wrt gamma_A - for (unsigned int t = 0; t < (Ti(i) - 1); t++) { - for (unsigned int s = 0; s < S; s++) { - gradient_wrt_A( - grad_A(d).slice(s), tmpmat, Qs, log_omega, log_py, log_alpha, - log_beta, loglik, A, X_s, i, t, s, d - ); - } - } - // gradient wrt gamma_B - for (unsigned int c = 0; c < C; c++) { - for (unsigned int s = 0; s < S; s++) { - if (obs(c, 0, i) < M(c)) { - gradient_wrt_B_t0( - grad_B(c, d).slice(s), tmpvec(c), Qm(c), log_omega, obs, log_Pi, - log_beta, loglik, log_B, B, X_o, M, i, s, c, d - ); - } - for (unsigned int t = 0; t < (T - 1); t++) { - if (obs(c, t + 1, i) < M(c)) { - gradient_wrt_B( - grad_B(c, d).slice(s), tmpvec(c), Qm(c), log_omega, obs, - log_alpha, log_beta, loglik, log_A, log_B, B, X_o, M, i, s, t, - c, d - ); - } - } - } - } - } - gradient_wrt_omega(grad_omega, tmpmatD, Qd, omega, loglik_i, loglik, X_d, i); - } - return Rcpp::List::create( - Rcpp::Named("loglik") = sum(loglik), - Rcpp::Named("gradient_pi") = Rcpp::wrap(grad_pi), - Rcpp::Named("gradient_A") = Rcpp::wrap(grad_A), - Rcpp::Named("gradient_B") = Rcpp::wrap(grad_B), - Rcpp::Named("gradient_omega") = Rcpp::wrap(grad_omega) - ); -} - diff --git a/src/log_objectivex.cpp b/src/log_objectivex.cpp index 7988d742..31527e6c 100644 --- a/src/log_objectivex.cpp +++ b/src/log_objectivex.cpp @@ -8,7 +8,7 @@ Rcpp::List log_objectivex(const arma::mat& transition, const arma::cube& emission, const arma::vec& init, const arma::ucube& obs, const arma::umat& ANZ, const arma::ucube& BNZ, const arma::uvec& INZ, const arma::uvec& nSymbols, const arma::mat& coef, - const arma::mat& X, const arma::uvec& numberOfStates, unsigned int threads) { + const arma::mat& X, const arma::uvec& numberOfStates, arma::uword threads) { int q = coef.n_rows; arma::vec grad(arma::accu(ANZ) + arma::accu(BNZ) + arma::accu(INZ) + (numberOfStates.n_elem - 1) * q, @@ -32,7 +32,7 @@ Rcpp::List log_objectivex(const arma::mat& transition, const arma::cube& emissio arma::mat initk(emission.n_rows, obs.n_slices); - for (unsigned int k = 0; k < obs.n_slices; k++) { + for (arma::uword k = 0; k < obs.n_slices; k++) { initk.col(k) = initLog + reparma(weights.col(k), numberOfStates); } @@ -40,7 +40,7 @@ Rcpp::List log_objectivex(const arma::mat& transition, const arma::cube& emissio log_internalBackward(transitionLog, emissionLog, obs, beta, threads); arma::vec ll(obs.n_slices); - for (unsigned int k = 0; k < obs.n_slices; k++) { + for (arma::uword k = 0; k < obs.n_slices; k++) { ll(k) = logSumExp(alpha.slice(k).col(obs.n_cols - 1)); } @@ -52,16 +52,16 @@ Rcpp::List log_objectivex(const arma::mat& transition, const arma::cube& emissio #pragma omp parallel for if(obs.n_slices >= threads) schedule(static) num_threads(threads) default(shared) - for (unsigned int k = 0; k < obs.n_slices; k++) { + for (arma::uword k = 0; k < obs.n_slices; k++) { int countgrad = 0; // transitionMatrix if (arma::accu(ANZ) > 0) { - for (unsigned int jj = 0; jj < numberOfStates.n_elem; jj++) { + for (arma::uword jj = 0; jj < numberOfStates.n_elem; jj++) { arma::vec gradArow(numberOfStates(jj)); arma::mat gradA(numberOfStates(jj), numberOfStates(jj)); int ind_jj = cumsumstate(jj) - numberOfStates(jj); - for (unsigned int i = 0; i < numberOfStates(jj); i++) { + for (arma::uword i = 0; i < numberOfStates(jj); i++) { arma::uvec ind = arma::find( ANZ.row(ind_jj + i).subvec(ind_jj, cumsumstate(jj) - 1)); @@ -71,10 +71,10 @@ Rcpp::List log_objectivex(const arma::mat& transition, const arma::cube& emissio gradA.each_row() -= transition.row(ind_jj + i).subvec(ind_jj, cumsumstate(jj) - 1); gradA.each_col() %= transition.row(ind_jj + i).subvec(ind_jj, cumsumstate(jj) - 1).t(); - for (unsigned int j = 0; j < numberOfStates(jj); j++) { - for (unsigned int t = 0; t < (obs.n_cols - 1); t++) { + for (arma::uword j = 0; j < numberOfStates(jj); j++) { + for (arma::uword t = 0; t < (obs.n_cols - 1); t++) { double tmp = 0.0; - for (unsigned int r = 0; r < obs.n_rows; r++) { + for (arma::uword r = 0; r < obs.n_rows; r++) { tmp += emissionLog(ind_jj + j, obs(r, t + 1, k), r); } gradArow(j) += exp( @@ -94,30 +94,30 @@ Rcpp::List log_objectivex(const arma::mat& transition, const arma::cube& emissio } if (arma::accu(BNZ) > 0) { // emissionMatrix - for (unsigned int r = 0; r < obs.n_rows; r++) { + for (arma::uword r = 0; r < obs.n_rows; r++) { arma::vec gradBrow(nSymbols(r)); arma::mat gradB(nSymbols(r), nSymbols(r)); - for (unsigned int i = 0; i < emission.n_rows; i++) { + for (arma::uword i = 0; i < emission.n_rows; i++) { arma::uvec ind = arma::find(BNZ.slice(r).row(i)); if (ind.n_elem > 0) { gradBrow.zeros(); gradB.eye(); gradB.each_row() -= emission.slice(r).row(i).subvec(0, nSymbols(r) - 1); gradB.each_col() %= emission.slice(r).row(i).subvec(0, nSymbols(r) - 1).t(); - for (unsigned int j = 0; j < nSymbols(r); j++) { + for (arma::uword j = 0; j < nSymbols(r); j++) { if (obs(r, 0, k) == j) { double tmp = 0.0; - for (unsigned int r2 = 0; r2 < obs.n_rows; r2++) { + for (arma::uword r2 = 0; r2 < obs.n_rows; r2++) { if (r2 != r) { tmp += emissionLog(i, obs(r2, 0, k), r2); } } gradBrow(j) += exp(initk(i, k) + tmp + beta(i, 0, k) - ll(k)); } - for (unsigned int t = 0; t < (obs.n_cols - 1); t++) { + for (arma::uword t = 0; t < (obs.n_cols - 1); t++) { if (obs(r, t + 1, k) == j) { double tmp = 0.0; - for (unsigned int r2 = 0; r2 < obs.n_rows; r2++) { + for (arma::uword r2 = 0; r2 < obs.n_rows; r2++) { if (r2 != r) { tmp += emissionLog(i, obs(r2, t + 1, k), r2); } @@ -137,14 +137,14 @@ Rcpp::List log_objectivex(const arma::mat& transition, const arma::cube& emissio } } if (arma::accu(INZ) > 0) { - for (unsigned int i = 0; i < numberOfStates.n_elem; i++) { + for (arma::uword i = 0; i < numberOfStates.n_elem; i++) { int ind_i = cumsumstate(i) - numberOfStates(i); arma::uvec ind = arma::find(INZ.subvec(ind_i, cumsumstate(i) - 1)); if (ind.n_elem > 0) { arma::vec gradIrow(numberOfStates(i), arma::fill::zeros); - for (unsigned int j = 0; j < numberOfStates(i); j++) { + for (arma::uword j = 0; j < numberOfStates(i); j++) { double tmp = 0.0; - for (unsigned int r = 0; r < obs.n_rows; r++) { + for (arma::uword r = 0; r < obs.n_rows; r++) { tmp += emissionLog(ind_i + j, obs(r, 0, k), r); } gradIrow(j) += exp(tmp + beta(ind_i + j, 0, k) - ll(k) + weights(i, k)); @@ -160,11 +160,11 @@ Rcpp::List log_objectivex(const arma::mat& transition, const arma::cube& emissio } } } - for (unsigned int jj = 1; jj < numberOfStates.n_elem; jj++) { - unsigned int ind_jj = cumsumstate(jj) - numberOfStates(jj); - for (unsigned int j = 0; j < emission.n_rows; j++) { + for (arma::uword jj = 1; jj < numberOfStates.n_elem; jj++) { + arma::uword ind_jj = cumsumstate(jj) - numberOfStates(jj); + for (arma::uword j = 0; j < emission.n_rows; j++) { double tmp = 0.0; - for (unsigned int r = 0; r < obs.n_rows; r++) { + for (arma::uword r = 0; r < obs.n_rows; r++) { tmp += emissionLog(j, obs(r, 0, k), r); } if ((j >= ind_jj) && (j < cumsumstate(jj))) { diff --git a/src/log_optCoef.cpp b/src/log_optCoef.cpp index b2c2baac..8e539471 100644 --- a/src/log_optCoef.cpp +++ b/src/log_optCoef.cpp @@ -1,7 +1,7 @@ // estimation of gamma coefficients using log-space #include "optcoef.h" -unsigned int log_optCoef(arma::mat& weights, const arma::ucube& obs, const arma::cube& emission, +arma::uword log_optCoef(arma::mat& weights, const arma::ucube& obs, const arma::cube& emission, const arma::mat& initk, const arma::cube& beta, const arma::vec& ll, arma::mat& coef, const arma::mat& X, const arma::uvec& cumsumstate, const arma::uvec& numberOfStates, int trace) { @@ -21,7 +21,7 @@ unsigned int log_optCoef(arma::mat& weights, const arma::ucube& obs, const arma: } arma::mat coefnew(coef.n_rows, coef.n_cols - 1); - for (unsigned int i = 0; i < (weights.n_rows - 1); i++) { + for (arma::uword i = 0; i < (weights.n_rows - 1); i++) { coefnew.col(i) = coef.col(i + 1) - tmpvec.subvec(i * X.n_cols, (i + 1) * X.n_cols - 1); } change = arma::accu(arma::abs(coef.submat(0, 1, coef.n_rows - 1, coef.n_cols - 1) - coefnew)) @@ -51,11 +51,11 @@ arma::vec log_gCoef(const arma::ucube& obs, const arma::cube& beta, const arma:: int q = X.n_cols; arma::vec grad(q * (weights.n_rows - 1), arma::fill::zeros); double tmp; - for (unsigned int jj = 1; jj < numberOfStates.n_elem; jj++) { - for (unsigned int k = 0; k < obs.n_slices; k++) { - for (unsigned int j = 0; j < emission.n_rows; j++) { + for (arma::uword jj = 1; jj < numberOfStates.n_elem; jj++) { + for (arma::uword k = 0; k < obs.n_slices; k++) { + for (arma::uword j = 0; j < emission.n_rows; j++) { tmp = 0.0; - for (unsigned int r = 0; r < obs.n_rows; r++) { + for (arma::uword r = 0; r < obs.n_rows; r++) { tmp += emission(j, obs(r, 0, k), r); } if ((j >= (cumsumstate(jj) - numberOfStates(jj))) && (j < cumsumstate(jj))) { diff --git a/src/mnhmm_base.h b/src/mnhmm_base.h new file mode 100644 index 00000000..8baa981d --- /dev/null +++ b/src/mnhmm_base.h @@ -0,0 +1,135 @@ +#ifndef MNHMMBASE_H +#define MNHMMBASE_H + +#include +#include "create_Q.h" +#include "eta_to_gamma.h" +#include "softmax.h" + +struct mnhmm_base { + const arma::uword S; + const arma::uword D; + const arma::mat& X_omega; + const arma::mat& X_pi; + const arma::cube& X_A; + const arma::cube& X_B; + const arma::uword K_omega; + const arma::uword K_pi; + const arma::uword K_A; + const arma::uword K_B; + const arma::uword N; + const arma::uword T; + const arma::uvec& Ti; + const bool iv_omega; + const bool iv_pi; + const bool iv_A; + const bool iv_B; + const bool tv_A; + const bool tv_B; + arma::mat Qs; + arma::mat Qd; + arma::mat eta_omega; + arma::mat gamma_omega; + arma::field eta_pi; + arma::field gamma_pi; + arma::field eta_A; + arma::field gamma_A; + // Pi, A, and log_p(y) of _one_ id and cluster we are currently working with + arma::vec omega; + arma::vec log_omega; + arma::field Pi; + arma::field log_Pi; + arma::field A; + arma::field log_A; + arma::cube log_py; + + mnhmm_base( + const arma::uword S_, + const arma::uword D_, + const arma::mat& X_d_, + const arma::mat& X_pi_, + const arma::cube& X_s_, + const arma::cube& X_o_, + const arma::uvec& Ti_, + const bool iv_omega_, + const bool iv_pi_, + const bool iv_A_, + const bool iv_B_, + const bool tv_A_, + const bool tv_B_, + arma::mat& eta_omega_, + arma::field& eta_pi_, + arma::field& eta_A_) + : S(S_), + D(D_), + X_omega(X_d_), + X_pi(X_pi_), + X_A(X_s_), + X_B(X_o_), + K_omega(X_omega.n_rows), + K_pi(X_pi.n_rows), + K_A(X_A.n_rows), + K_B(X_B.n_rows), + N(X_A.n_slices), + T(X_A.n_cols), + Ti(Ti_), + iv_omega(iv_omega_), + iv_pi(iv_pi_), + iv_A(iv_A_), + iv_B(iv_B_), + tv_A(tv_A_), + tv_B(tv_B_), + Qs(create_Q(S)), + Qd(create_Q(D)), + eta_omega(eta_omega_), + gamma_omega(eta_to_gamma(eta_omega, Qd)), + eta_pi(eta_pi_), + gamma_pi(eta_to_gamma(eta_pi, Qs)), + eta_A(eta_A_), + gamma_A(eta_to_gamma(eta_A, Qs)), + omega(D), + log_omega(D), + Pi(D), + log_Pi(D), + A(D), + log_A(D), + log_py(S, T, D) { + for (arma::uword d = 0; d < D; d++) { + Pi(d) = arma::vec(S); + log_Pi(d) = arma::vec(S); + A(d) = arma::cube(S, S, T); + log_A(d) = arma::cube(S, S, T); + } + } + + void update_omega(arma::uword i) { + omega = softmax(gamma_omega * X_omega.col(i)); + log_omega = arma::log(omega); + } + void update_pi(arma::uword i) { + for (arma::uword d = 0; d < D; d++) { + Pi(d) = softmax(gamma_pi(d) * X_pi.col(i)); + log_Pi(d) = arma::log(Pi(d)); + } + } + void update_A(arma::uword i) { + arma::mat Atmp(S, S); + for (arma::uword d = 0; d < D; d++) { + if (tv_A) { + for (arma::uword t = 0; t < Ti(i); t++) { // time + for (arma::uword j = 0; j < S; j ++) { // from states + Atmp.col(j) = softmax(gamma_A(d).slice(j) * X_A.slice(i).col(t)); + } + A(d).slice(t) = Atmp.t(); + } + } else { + for (arma::uword j = 0; j < S; j ++) { // from states + Atmp.col(j) = softmax(gamma_A(d).slice(j) * X_A.slice(i).col(0)); + } + A(d).each_slice() = Atmp.t(); + } + log_A(d) = arma::log(A(d)); + } + } +}; +#endif diff --git a/src/mnhmm_mc.h b/src/mnhmm_mc.h new file mode 100644 index 00000000..6768d98b --- /dev/null +++ b/src/mnhmm_mc.h @@ -0,0 +1,109 @@ +#ifndef MNHMM_MC_H +#define MNHMM_MC_H + +#include +#include "create_Q.h" +#include "eta_to_gamma.h" +#include "mnhmm_base.h" + +struct mnhmm_mc : public mnhmm_base { + + const arma::ucube& obs; + const arma::uword C; + arma::field eta_B; + arma::uvec M; + arma::field Qm; + arma::field gamma_B; + // these store Pi, A, B, and log_p(y) of _one_ id and clusterwe are currently working with + arma::field B; + arma::field log_B; + + mnhmm_mc( + const arma::uword S_, + const arma::uword D_, + const arma::mat& X_d_, + const arma::mat& X_pi_, + const arma::cube& X_s_, + const arma::cube& X_o_, + const arma::uvec& Ti_, + const bool iv_omega_, + const bool iv_pi_, + const bool iv_A_, + const bool iv_B_, + const bool tv_A_, + const bool tv_B_, + const arma::ucube& obs_, + arma::mat& eta_omega_, + arma::field& eta_pi_, + arma::field& eta_A_, + arma::field& eta_B_) + : mnhmm_base(S_, D_, X_d_, X_pi_, X_s_, X_o_, Ti_, iv_omega_, iv_pi_, iv_A_, + iv_B_, tv_A_, tv_B_, eta_omega_, eta_pi_, eta_A_), + obs(obs_), + C(obs.n_rows), + eta_B(arma::field(C, D)), + M(arma::uvec(C)), + Qm(arma::field(C)), + gamma_B(arma::field(C, D)), + B(arma::field(C, D)), + log_B(arma::field(C, D)) { + + for (arma::uword d = 0; d < D; d++) { + for (arma::uword c = 0; c < C; c++) { + eta_B(c, d) = eta_B_(c + d * C); // 1D field from R to 2D field + M(c) = eta_B(c, d).n_rows + 1; + Qm(c) = create_Q(M(c)); + gamma_B(c, d) = eta_to_gamma(eta_B(c, d), Qm(c)); + B(c, d) = arma::cube(S, M(c) + 1, T); // B field initialization + log_B(c, d) = arma::cube(S, M(c) + 1, T); // log_B field initialization + } + } + } + + void update_B(const arma::uword i) { + if (tv_B) { + for (arma::uword c = 0; c < C; c++) { + arma::mat Btmp(M(c) + 1, S, arma::fill::ones); + for (arma::uword d = 0; d < D; d++) { + for (arma::uword t = 0; t < Ti(i); t++) { // time + for (arma::uword s = 0; s < S; s++) { // from states + Btmp.col(s).rows(0, M(c) - 1) = softmax(gamma_B(c, d).slice(s) * X_B.slice(i).col(t)); + } + B(c, d).slice(t) = Btmp.t(); + } + log_B(c, d) = arma::log(B(c, d)); + } + } + } else { + for (arma::uword c = 0; c < C; c++) { + arma::mat Btmp(M(c) + 1, S, arma::fill::ones); + for (arma::uword d = 0; d < D; d++) { + for (arma::uword s = 0; s < S; s++) { // from states + Btmp.col(s).rows(0, M(c) - 1) = softmax( + gamma_B(c, d).slice(s) * X_B.slice(i).col(0) + ); + } + B(c, d).each_slice() = Btmp.t(); + log_B(c, d) = arma::log(B(c, d)); + } + } + } + } + + void update_probs(const arma::uword i) { + update_pi(i); + update_A(i); + update_B(i); + } + void update_log_py(const arma::uword i) { + log_py.zeros(); + for (arma::uword d = 0; d < D; d++) { + for (arma::uword t = 0; t < Ti(i); t++) { + for (arma::uword c = 0; c < C; c++) { + log_py.slice(d).col(t) += log_B(c, d).slice(t).col(obs(c, t, i)); + } + } + } + } +}; +#endif diff --git a/src/mnhmm_sc.h b/src/mnhmm_sc.h new file mode 100644 index 00000000..9ea809c7 --- /dev/null +++ b/src/mnhmm_sc.h @@ -0,0 +1,92 @@ +#ifndef MNHMM_SC_H +#define MNHMM_SC_H + +#include +#include "create_Q.h" +#include "eta_to_gamma.h" +#include "softmax.h" +#include "mnhmm_base.h" + +struct mnhmm_sc : public mnhmm_base { + + const arma::umat& obs; + arma::field eta_B; + const arma::uword M; + arma::mat Qm; + arma::field gamma_B; + // these store Pi, A, B, and log_p(y) of _one_ id we are currently working with + arma::field B; + arma::field log_B; + + mnhmm_sc( + const arma::uword S_, + const arma::uword D_, + const arma::mat& X_d_, + const arma::mat& X_pi_, + const arma::cube& X_s_, + const arma::cube& X_o_, + const arma::uvec& Ti_, + const bool iv_omega_, + const bool iv_pi_, + const bool iv_A_, + const bool iv_B_, + const bool tv_A_, + const bool tv_B_, + const arma::umat& obs_, + arma::mat& eta_omega_, + arma::field& eta_pi_, + arma::field& eta_A_, + arma::field& eta_B_) + : mnhmm_base(S_, D_, X_d_, X_pi_, X_s_, X_o_, Ti_, iv_omega_, iv_pi_, iv_A_, + iv_B_, tv_A_, tv_B_, eta_omega_, eta_pi_, eta_A_), + obs(obs_), + eta_B(eta_B_), + M(eta_B(0).n_rows + 1), + Qm(create_Q(M)), + gamma_B(eta_to_gamma(eta_B, Qm)), + B(D), + log_B(D){ + for (arma::uword d = 0; d < D; d++) { + B(d) = arma::cube(S, M + 1, T); + log_B(d) = arma::cube(S, M + 1, T); + } + } + + void update_B(const arma::uword i) { + arma::mat Btmp(M + 1, S, arma::fill::ones); + if (tv_B) { + for (arma::uword d = 0; d < D; d++) { + for (arma::uword t = 0; t < Ti(i); t++) { // time + for (arma::uword s = 0; s < S; s++) { // from states + Btmp.col(s).rows(0, M - 1) = softmax(gamma_B(d).slice(s) * X_B.slice(i).col(t)); + } + B(d).slice(t) = Btmp.t(); + } + log_B(d) = arma::log(B(d)); + } + } else { + for (arma::uword d = 0; d < D; d++) { + for (arma::uword s = 0; s < S; s++) { // from states + Btmp.col(s).rows(0, M - 1) = softmax( + gamma_B(d).slice(s) * X_B.slice(i).col(0) + ); + } + B(d).each_slice() = Btmp.t(); + log_B(d) = arma::log(B(d)); + } + } + } + void update_probs(const arma::uword i) { + update_pi(i); + update_A(i); + update_B(i); + } + void update_log_py(const arma::uword i) { + for (arma::uword d = 0; d < D; d++) { + for (arma::uword t = 0; t < Ti(i); t++) { + log_py.slice(d).col(t) = log_B(d).slice(t).col(obs(t, i)); + } + } + } +}; +#endif diff --git a/src/nhmm.h b/src/nhmm.h new file mode 100644 index 00000000..743dd9f9 --- /dev/null +++ b/src/nhmm.h @@ -0,0 +1,86 @@ +#ifndef NHMM_H +#define NHMM_H + +#include +#include "eta_to_gamma.h" + +struct nhmm { + const arma::umat& obs; + const arma::mat& X_pi; + const arma::cube& X_A; + const arma::cube& X_B; + const arma::mat& Qs; + const arma::mat& Qm; + const arma::uvec& Ti; + arma::mat eta_pi; + arma::cube eta_A; + arma::cube eta_B; + const arma::uword N; + const arma::uword T; + const arma::uword S; + const arma::uword M; + const bool iv_pi; + const bool iv_A; + const bool iv_B; + const bool tv_A; + const bool tv_B; + const arma::uword np_pi; + const arma::uword np_A; + const arma::uword np_B; + const arma::uword K_pi; + const arma::uword K_A; + const arma::uword K_B; + arma::mat gamma_pi; + arma::cube gamma_A; + arma::cube gamma_B; + + nhmm(const arma::umat& obs_, + const arma::mat& X_pi_, + const arma::cube& X_s_, + const arma::cube& X_o_, + const arma::mat& Qs_, + const arma::mat& Qm_, + const arma::uvec& Ti_, + arma::mat& eta_pi_, + arma::cube& eta_A_, + arma::cube& eta_B_, + const bool iv_pi_, + const bool iv_A_, + const bool iv_B_, + const bool tv_A_, + const bool tv_B_) + : obs(obs_), + X_pi(X_pi_), + X_A(X_s_), + X_B(X_o_), + Qs(Qs_), + Qm(Qm_), + Ti(Ti_), + eta_pi(eta_pi_), + eta_A(eta_A_), + eta_B(eta_B_), + N(obs.n_cols), + T(obs.n_rows), + S(Qs.n_rows), + M(Qm.n_rows), + iv_pi(iv_pi_), + iv_A(iv_A_), + iv_B(iv_B_), + tv_A(tv_A_), + tv_B(tv_B_), + np_pi(eta_pi.n_elem), + np_A(eta_A.n_elem), + np_B(eta_B.n_elem), + K_pi(X_pi.n_rows), + K_A(X_A.n_rows), + K_B(X_B.n_rows) { + gamma_pi = eta_to_gamma(eta_pi, Qs); + gamma_A = eta_to_gamma(eta_A, Qs); + gamma_B = eta_to_gamma(eta_B, Qs); + } + void mstep( + const arma::vec E_Pi, const arma::cube E_A, const arma::cube E_B, + const double xtol_abs, const double ftol_abs, const double xtol_rel, + const double ftol_rel, arma::uword maxeval); +}; +#endif diff --git a/src/nhmm_EM.cpp b/src/nhmm_EM.cpp new file mode 100644 index 00000000..96ff69db --- /dev/null +++ b/src/nhmm_EM.cpp @@ -0,0 +1,230 @@ +// // EM algorithm for NHMMs +// +// #include "softmax.h" +// #include "forward_nhmm.h" +// #include "backward_nhmm.h" +// #include "get_parameters.h" +// #include "nhmm_mstep.h" +// #include "nhmm_sc.h" +// #include "nhmm_mc.h" +// #include "mnhmm_sc.h" +// #include "mnhmm_mc.h" + +// // [[Rcpp::export]] +// Rcpp::List EM_LBFGS_nhmm_singlechannel( +// const arma::mat& eta_pi, const arma::mat& X_pi, +// const arma::cube& eta_A, const arma::cube& X_A, +// const arma::cube& eta_B, const arma::cube& X_B, +// const arma::umat& obs, const bool iv_pi, const bool iv_A, const bool iv_B, +// const bool tv_A, const bool tv_B, const arma::uvec& Ti, double n_obs, +// arma::uword maxeval, double ftol_abs, double ftol_rel, double xtol_abs, +// double xtol_rel) { +// +// nhmm_sc model( +// eta_A.n_slices, X_pi, X_A, X_B, Ti, +// iv_pi, iv_A, iv_B, tv_A, tv_B, obs, eta_pi, eta_A, eta_B +// ); + +// arma::mat log_alpha(model.S, model.T); +// arma::mat log_beta(model.S, model.T); +// // EM-algorithm begins +// +// double relative_change = ftol_rel + 1.0; +// double absolute_change = ftol_abs + 1.0; +// arma::uword iter = 0; +// double ll_new = 0; +// double ll = -1e150; +// arma::vec tmp_T(T); +// arma::vec E_Pi(S); +// arma::cube E_A(S, S, T); +// arma::cube E_B(S, M, T); +// while ((relative_change > ftol_rel) && (absolute_change > ftol_abs) && (iter < maxeval)) { +// iter++; +// ll_new = 0; +// E_Pi.zeros(); +// E_A.zeros(); +// E_B.zeros(); +// for (arma::uword i = 0; i < N; i++) { +// +// if (model.iv_pi || i == 0) { +// model.update_pi(i); +// } +// if (model.iv_A || i == 0) { +// model.update_A(i); +// } +// if (model.iv_B || i == 0) { +// model.update_B(i); +// } +// model.update_log_py(i); +// univariate_forward_nhmm( +// log_alpha, model.log_Pi, model.log_A, +// model.log_py.cols(0, model.Ti(i) - 1) +// ); +// univariate_backward_nhmm( +// log_beta, model.log_A, model.log_py.cols(0, model.Ti(i) - 1) +// ); +// +// double ll_i = logSumExp(log_alpha.col(model.Ti(i) - 1)); +// ll_new += ll_i; +// +// // update parameters once more even if already converged +// // Pi +// E_Pi += arma::exp(log_alpha.col(0) + log_beta.col(0) - ll_i); +// // A +// for (arma::uword j = 0; j < model.S; j++) { +// for (arma::uword k = 0; k < model.S; k++) { +// for (arma::uword t = 0; t < (model.Ti(i) - 1); t++) { +// E_A(k, j, t) += log_alpha(k, t) + model.log_A(k, j, t) + log_beta(j, t + 1) + model.log_py(j, t + 1) - ll_i; +// } +// } +// } +// // B +// for (arma::uword m = 0; m < model.M; m++) { +// for (arma::uword s = 0; s < model.S; s++) { +// tmp_T.fill(-arma::datum::inf); +// for (arma::uword t = 0; t < model.Ti(i); t++) { +// if (m == model.obs(t, i)) { +// E_B(s, m, t) += log_alpha(s, t) + log_beta(s, t) - ll_i; +// } +// } +// } +// } +// } +// // Minimize obj(E_pi, E_A, E_B, eta_pi, eta_A, eta_B, X_pi, X_A, X_B) +// // with respect to eta_pi, eta_A, eta_B +// nhmm_mstep(model.eta_pi, model.eta_A, model.eta_B, model.X_pi, model.X_A, model.X_B, E_Pi, E_A, E_B); +// relative_change = (ll_new - ll) / (std::abs(ll) + 1e-8); +// absolute_change = (ll_new - ll) / n_obs; +// ll = ll_new; +// } +// // Final log-likelihood +// ll_new = 0; +// for (arma::uword i = 0; i < N; i++) { +// model.update_log_py(i); +// univariate_forward_nhmm(log_alpha, model.log_Pi, model.log_A, model.log_py.cols(0, model.Ti(i) - 1)); +// ll_new += logSumExp(log_alpha.col(Ti(i) - 1)); +// } +// return Rcpp::List::create( +// Rcpp::Named("initial_probs") = Rcpp::wrap(model.Pi), +// Rcpp::Named("transition_probs") = Rcpp::wrap(model.A), +// Rcpp::Named("emission_probs") = Rcpp::wrap(model.B.cols(0, model.M - 1)), +// Rcpp::Named("logLik") = ll_new, +// Rcpp::Named("iterations") = iter, +// Rcpp::Named("relative_change") = relative_change, +// Rcpp::Named("absolute_change") = absolute_change +// ); +// } +// // // [[Rcpp::export]] +// // Rcpp::List EM_nhmm_multichannel( +// // const arma::mat& eta_pi, const arma::cube& eta_A, +// // const arma::field& eta_B, const arma::ucube& obs, +// // const arma::uvec& M, const arma::uvec& Ti, arma::uword itermax, +// // double tol) { +// // +// // arma::uword T = obs.n_rows; +// // arma::uword N = obs.n_cols; +// // arma::uword S = eta_A.n_slices; +// // arma::uword C = M.n_elem; +// // arma::uword maxM = arma::max(M); +// // EM-algorithm begins +// // +// // double change = tol + 1.0; +// // arma::uword iter = 0; +// // double ll_new = 0; +// // double ll = -1e150; +// // // initial values to probabilities +// // arma::vec log_Pi = arma::log(softmax(eta_to_gamma(eta_pi))); +// // arma::mat log_A(S, S); +// // arma::mat log_B(S, M + 1); +// // log_B.col(M).zeros(); +// // arma::cube gamma_A = eta_to_gamma(eta_A); +// // arma::cube gamma_B = eta_to_gamma(eta_B); +// // for (arma::uword s = 0; s < S; s++) { +// // log_A.row(s) = arma::log((softmax(gamma_A.slice(s)).t())); +// // log_B.row(s).cols(0, M - 1) = arma::log(softmax(gamma_B.slice(s)).t()); +// // } +// // arma::vec Pi(S); +// // arma::mat A(S, S); +// // arma::mat B(S, M); +// // arma::mat log_alpha(S, T); +// // arma::mat log_beta(S, T); +// // arma::mat log_py(S, T); +// // arma::vec tmp_T(T); +// // // ll = 0; +// // // for (arma::uword i = 0; i < N; i++) { +// // // for (arma::uword t = 0; t < Ti(i); t++) { +// // // log_py.col(t) = log_B.col(obs(t, i)); +// // // } +// // // univariate_forward_nhmm(log_alpha, log_Pi, log_A, log_py.cols(0, Ti(i) - 1)); +// // // ll += logSumExp(log_alpha.col(Ti(i) - 1)); +// // // } +// // while ((change > tol) && (iter < itermax)) { +// // iter++; +// // ll_new = 0; +// // Pi.zeros(); +// // A.zeros(); +// // B.zeros(); +// // for (arma::uword i = 0; i < N; i++) { +// // for (arma::uword t = 0; t < Ti(i); t++) { +// // log_py.col(t) = log_B.col(obs(t, i)); +// // } +// // univariate_forward_nhmm(log_alpha, log_Pi, log_A, log_py.cols(0, Ti(i) - 1)); +// // univariate_backward_nhmm(log_beta, log_A, log_py.cols(0, Ti(i) - 1)); +// // double ll_i = logSumExp(log_alpha.col(Ti(i) - 1)); +// // ll_new += ll_i; +// // +// // // Pi +// // Pi += arma::exp(log_alpha.col(0) + log_beta.col(0) - ll_i); +// // // A +// // for (arma::uword j = 0; j < S; j++) { +// // for (arma::uword k = 0; k < S; k++) { +// // for (arma::uword t = 0; t < (Ti(i) - 1); t++) { +// // tmp_T(t) = log_alpha(k, t) + log_A(k, j) + log_beta(j, t + 1) + log_py(j, t + 1); +// // } +// // A(k, j) += exp(logSumExp(tmp_T.rows(0, Ti(i) - 2) - ll_i)); +// // } +// // } +// // // B +// // for (arma::uword m = 0; m < M; m++) { +// // for (arma::uword s = 0; s < S; s++) { +// // tmp_T.fill(-arma::datum::inf); +// // for (arma::uword t = 0; t < Ti(i); t++) { +// // if (m == obs(t, i)) { +// // tmp_T(t) = log_alpha(s, t) + log_beta(s, t); +// // } +// // } +// // B(s, m) += exp(logSumExp(tmp_T.rows(0, Ti(i) - 1) - ll_i)); +// // } +// // } +// // } +// // log_Pi = arma::log(Pi / arma::accu(Pi)); +// // A.each_col() /= sum(A, 1); +// // log_A = arma::log(A); +// // B.cols(0, M - 1).each_col() /= sum(B.cols(0, M - 1), 1); +// // log_B.cols(0, M - 1) = arma::log(B.cols(0, M - 1)); +// // // ll_new = 0; +// // // for (arma::uword i = 0; i < N; i++) { +// // // for (arma::uword t = 0; t < Ti(i); t++) { +// // // log_py.col(t) = log_B.col(obs(t, i)); +// // // } +// // // univariate_forward_nhmm(log_alpha, log_Pi, log_A, log_py.cols(0, Ti(i) - 1)); +// // // ll_new += logSumExp(log_alpha.col(Ti(i) - 1)); +// // // } +// // +// // change = (ll_new - ll) / (std::abs(ll) + 0.1); +// // ll = ll_new; +// // } +// // Pi = arma::exp(log_Pi); +// // A = arma::exp(log_A); +// // B = arma::exp(log_B); +// // // should compute the final log-likelihood using these values, +// // // but not interested in that here +// // return Rcpp::List::create( +// // Rcpp::Named("initial_probs") = Rcpp::wrap(Pi), +// // Rcpp::Named("transition_probs") = Rcpp::wrap(A), +// // Rcpp::Named("emission_probs") = Rcpp::wrap(B.cols(0, M - 1)), +// // Rcpp::Named("logLik") = ll, +// // Rcpp::Named("iterations") = iter, +// // Rcpp::Named("change") = change +// // ); +// // } diff --git a/src/nhmm_backward.cpp b/src/nhmm_backward.cpp new file mode 100644 index 00000000..1eb340f2 --- /dev/null +++ b/src/nhmm_backward.cpp @@ -0,0 +1,91 @@ +// backward algorithm for NHMM +#include "nhmm_backward.h" +#include "nhmm_sc.h" +#include "nhmm_mc.h" +#include "mnhmm_sc.h" +#include "mnhmm_mc.h" + +// [[Rcpp::export]] +arma::cube backward_nhmm_singlechannel( + arma::mat& eta_pi, const arma::mat& X_pi, + arma::cube& eta_A, const arma::cube& X_A, + arma::cube& eta_B, const arma::cube& X_B, + const arma::umat& obs, const arma::uvec Ti, + const bool iv_pi, const bool iv_A, const bool iv_B, + const bool tv_A, const bool tv_B) { + + nhmm_sc model( + eta_A.n_slices, X_pi, X_A, X_B, Ti, + iv_pi, iv_A, iv_B, tv_A, tv_B, obs, eta_pi, eta_A, eta_B + ); + + arma::cube log_beta(model.S, model.T, model.N, arma::fill::value(arma::datum::nan)); + backward_nhmm(model, log_beta); + return log_beta; +} + +// [[Rcpp::export]] +arma::cube backward_nhmm_multichannel( + arma::mat& eta_pi, const arma::mat& X_pi, + arma::cube& eta_A, const arma::cube& X_A, + arma::field& eta_B, const arma::cube& X_B, + const arma::ucube& obs, const arma::uvec Ti, + const bool iv_pi, const bool iv_A, const bool iv_B, + const bool tv_A, const bool tv_B) { + + nhmm_mc model( + eta_A.n_slices, X_pi, X_A, X_B, Ti, + iv_pi, iv_A, iv_B, tv_A, tv_B, obs, eta_pi, eta_A, eta_B + ); + + arma::cube log_beta(model.S, model.T, model.N, arma::fill::value(arma::datum::nan)); + backward_nhmm(model, log_beta); + return log_beta; +} + +// [[Rcpp::export]] +arma::cube backward_mnhmm_singlechannel( + arma::mat& eta_omega, const arma::mat& X_omega, + arma::field& eta_pi, const arma::mat& X_pi, + arma::field& eta_A, const arma::cube& X_A, + arma::field& eta_B, const arma::cube& X_B, + const arma::umat& obs, const arma::uvec Ti, + const bool iv_omega, const bool iv_pi, const bool iv_A, const bool iv_B, + const bool tv_A, const bool tv_B) { + + mnhmm_sc model( + eta_A(0).n_slices, eta_A.n_rows, X_omega, X_pi, X_A, X_B, Ti, iv_omega, + iv_pi, iv_A, iv_B, tv_A, tv_B, obs, eta_omega, eta_pi, eta_A, eta_B + ); + + arma::cube log_beta( + model.S * model.D, model.T, model.N, + arma::fill::value(arma::datum::nan) + ); + for (arma::uword d = 0; d < model.D; d++) { + backward_mnhmm(model, log_beta); + } + return log_beta; +} + +// [[Rcpp::export]] +arma::cube backward_mnhmm_multichannel( + arma::mat& eta_omega, const arma::mat& X_omega, + arma::field& eta_pi, const arma::mat& X_pi, + arma::field& eta_A, const arma::cube& X_A, + arma::field& eta_B, const arma::cube& X_B, + const arma::ucube& obs, const arma::uvec Ti, + const bool iv_omega, const bool iv_pi, const bool iv_A, const bool iv_B, + const bool tv_A, const bool tv_B) { + + mnhmm_mc model( + eta_A(0).n_slices, eta_A.n_rows, X_omega, X_pi, X_A, X_B, Ti, iv_omega, + iv_pi, iv_A, iv_B, tv_A, tv_B, obs, eta_omega, eta_pi, eta_A, eta_B + ); + + arma::cube log_beta( + model.S * model.D, model.T, model.N, arma::fill::value(arma::datum::nan) + ); + backward_mnhmm(model, log_beta); + return log_beta; +} diff --git a/src/nhmm_backward.h b/src/nhmm_backward.h new file mode 100644 index 00000000..15675eec --- /dev/null +++ b/src/nhmm_backward.h @@ -0,0 +1,78 @@ +#ifndef BACKWARD_NHMM_H +#define BACKWARD_NHMM_H + +#include +#include "logsumexp.h" + +// time-varying A +template +void univariate_backward_nhmm( + submat& log_beta, + const arma::cube& log_A, + const arma::mat& log_py) { + + arma::uword S = log_py.n_rows; + arma::uword T = log_py.n_cols; + + log_beta.col(T - 1).zeros(); + for (int t = (T - 2); t >= 0; t--) { + for (arma::uword i = 0; i < S; i++) { + log_beta(i, t) = logSumExp( + log_beta.col(t + 1) + log_A.slice(t).row(i).t() + + log_py.col(t + 1) + ); + } + } +} +// // time-invariant A +// template +// void univariate_backward_nhmm( +// submat& log_beta, +// const arma::mat& log_A, +// const arma::mat& log_py) { +// +// arma::uword S = log_py.n_rows; +// arma::uword T = log_py.n_cols; +// arma::mat log_tA = log_A.t(); +// log_beta.col(T - 1).zeros(); +// for (int t = (T - 2); t >= 0; t--) { +// for (arma::uword i = 0; i < S; i++) { +// log_beta(i, t) = logSumExp( +// log_beta.col(t + 1) + log_tA.col(i) + log_py.col(t + 1) +// ); +// } +// } +// } + +template +void backward_nhmm(Model& model, arma::cube& log_beta) { + for (arma::uword i = 0; i < model.N; i++) { + model.update_probs(i); + model.update_log_py(i); + univariate_backward_nhmm( + log_beta.slice(i), + model.log_A, + model.log_py.cols(0, model.Ti(i) - 1) + ); + } +} + + +template +void backward_mnhmm(Model& model, arma::cube& log_beta) { + for (arma::uword i = 0; i < model.N; i++) { + model.update_probs(i); + model.update_log_py(i); + for (arma::uword d = 0; d < model.D; d++) { + arma::subview submat = + log_beta.slice(i).rows(d * model.S, (d + 1) * model.S - 1); + univariate_backward_nhmm( + submat, + model.log_A(d), + model.log_py.slice(d).cols(0, model.Ti(i) - 1) + ); + } + } +} + +#endif diff --git a/src/nhmm_base.h b/src/nhmm_base.h new file mode 100644 index 00000000..3b31bcb2 --- /dev/null +++ b/src/nhmm_base.h @@ -0,0 +1,98 @@ +#ifndef NHMMBASE_H +#define NHMMBASE_H + +#include +#include "create_Q.h" +#include "eta_to_gamma.h" +#include "softmax.h" + +struct nhmm_base { + const arma::uword S; + const arma::mat& X_pi; + const arma::cube& X_A; + const arma::cube& X_B; + const arma::uword K_pi; + const arma::uword K_A; + const arma::uword K_B; + const arma::uword N; + const arma::uword T; + const arma::uvec& Ti; + const bool iv_pi; + const bool iv_A; + const bool iv_B; + const bool tv_A; + const bool tv_B; + arma::mat Qs; + arma::mat eta_pi; + arma::mat gamma_pi; + arma::cube eta_A; + arma::cube gamma_A; + // these store Pi, A, B, and log_p(y) of _one_ id we are currently working with + arma::vec Pi; + arma::vec log_Pi; + arma::cube A; + arma::cube log_A; + arma::mat log_py; + + nhmm_base( + const arma::uword S_, + const arma::mat& X_pi_, + const arma::cube& X_s_, + const arma::cube& X_o_, + const arma::uvec& Ti_, + const bool iv_pi_, + const bool iv_A_, + const bool iv_B_, + const bool tv_A_, + const bool tv_B_, + arma::mat& eta_pi_, + arma::cube& eta_A_) + : S(S_), + X_pi(X_pi_), + X_A(X_s_), + X_B(X_o_), + K_pi(X_pi.n_rows), + K_A(X_A.n_rows), + K_B(X_B.n_rows), + N(X_A.n_slices), + T(X_A.n_cols), + Ti(Ti_), + iv_pi(iv_pi_), + iv_A(iv_A_), + iv_B(iv_B_), + tv_A(tv_A_), + tv_B(tv_B_), + Qs(create_Q(S)), + eta_pi(eta_pi_), + gamma_pi(eta_to_gamma(eta_pi, Qs)), + eta_A(eta_A_), + gamma_A(eta_to_gamma(eta_A, Qs)), + Pi(S), + log_Pi(S), + A(S, S, T), + log_A(S, S, T), + log_py(S, T) {} + + void update_pi(arma::uword i) { + Pi = softmax(gamma_pi * X_pi.col(i)); + log_Pi = arma::log(Pi); + } + void update_A(arma::uword i) { + arma::mat Atmp(S, S); + if (tv_A) { + for (arma::uword t = 0; t < Ti(i); t++) { // time + for (arma::uword j = 0; j < S; j ++) { // from states + Atmp.col(j) = softmax(gamma_A.slice(j) * X_A.slice(i).col(t)); + } + A.slice(t) = Atmp.t(); + } + } else { + for (arma::uword j = 0; j < S; j ++) { // from states + Atmp.col(j) = softmax(gamma_A.slice(j) * X_A.slice(i).col(0)); + } + A.each_slice() = Atmp.t(); + } + log_A = arma::log(A); + } +}; +#endif diff --git a/src/nhmm_forward.cpp b/src/nhmm_forward.cpp new file mode 100644 index 00000000..c024ce50 --- /dev/null +++ b/src/nhmm_forward.cpp @@ -0,0 +1,86 @@ +// forward algorithm for NHMM +#include "nhmm_forward.h" +#include "nhmm_sc.h" +#include "nhmm_mc.h" +#include "mnhmm_sc.h" +#include "mnhmm_mc.h" + +// [[Rcpp::export]] +arma::cube forward_nhmm_singlechannel( + arma::mat& eta_pi, const arma::mat& X_pi, + arma::cube& eta_A, const arma::cube& X_A, + arma::cube& eta_B, const arma::cube& X_B, + const arma::umat& obs, const arma::uvec Ti, + const bool iv_pi, const bool iv_A, const bool iv_B, + const bool tv_A, const bool tv_B) { + + nhmm_sc model( + eta_A.n_slices, X_pi, X_A, X_B, Ti, + iv_pi, iv_A, iv_B, tv_A, tv_B, obs, eta_pi, eta_A, eta_B + ); + arma::cube log_alpha(model.S, model.T, model.N, arma::fill::value(arma::datum::nan)); + forward_nhmm(model, log_alpha); + return log_alpha; +} + +// [[Rcpp::export]] +arma::cube forward_nhmm_multichannel( + arma::mat& eta_pi, const arma::mat& X_pi, + arma::cube& eta_A, const arma::cube& X_A, + arma::field& eta_B, const arma::cube& X_B, + const arma::ucube& obs, const arma::uvec Ti, + const bool iv_pi, const bool iv_A, const bool iv_B, + const bool tv_A, const bool tv_B) { + + nhmm_mc model( + eta_A.n_slices, X_pi, X_A, X_B, Ti, + iv_pi, iv_A, iv_B, tv_A, tv_B, obs, eta_pi, eta_A, eta_B + ); + arma::cube log_alpha(model.S, model.T, model.N, arma::fill::value(arma::datum::nan)); + forward_nhmm(model, log_alpha); + return log_alpha; +} + +// [[Rcpp::export]] +arma::cube forward_mnhmm_singlechannel( + arma::mat& eta_omega, const arma::mat& X_omega, + arma::field& eta_pi, const arma::mat& X_pi, + arma::field& eta_A, const arma::cube& X_A, + arma::field& eta_B, const arma::cube& X_B, + const arma::umat& obs, const arma::uvec Ti, + const bool iv_omega, const bool iv_pi, const bool iv_A, const bool iv_B, + const bool tv_A, const bool tv_B) { + + mnhmm_sc model( + eta_A(0).n_slices, eta_A.n_rows, X_omega, X_pi, X_A, X_B, Ti, iv_omega, + iv_pi, iv_A, iv_B, tv_A, tv_B, obs, eta_omega, eta_pi, eta_A, eta_B + ); + + arma::cube log_alpha( + model.S * model.D, model.T, model.N, + arma::fill::value(arma::datum::nan) + ); + forward_mnhmm(model, log_alpha); + return log_alpha; +} + +// [[Rcpp::export]] +arma::cube forward_mnhmm_multichannel( + arma::mat& eta_omega, const arma::mat& X_omega, + arma::field& eta_pi, const arma::mat& X_pi, + arma::field& eta_A, const arma::cube& X_A, + arma::field& eta_B, const arma::cube& X_B, + const arma::ucube& obs, const arma::uvec Ti, + const bool iv_omega, const bool iv_pi, const bool iv_A, const bool iv_B, + const bool tv_A, const bool tv_B) { + + mnhmm_mc model( + eta_A(0).n_slices, eta_A.n_rows, X_omega, X_pi, X_A, X_B, Ti, iv_omega, + iv_pi, iv_A, iv_B, tv_A, tv_B, obs, eta_omega, eta_pi, eta_A, eta_B + ); + arma::cube log_alpha( + model.S * model.D, model.T, model.N, arma::fill::value(arma::datum::nan) + ); + forward_mnhmm(model, log_alpha); + return log_alpha; +} diff --git a/src/nhmm_forward.h b/src/nhmm_forward.h new file mode 100644 index 00000000..1ef8a9c4 --- /dev/null +++ b/src/nhmm_forward.h @@ -0,0 +1,80 @@ +#ifndef FORWARD_NHMM_H +#define FORWARD_NHMM_H + +#include +#include "logsumexp.h" + +// // time-varying A +template +void univariate_forward_nhmm( + submat& log_alpha, + const arma::vec& log_pi, + const arma::cube& log_A, + const arma::mat& log_py) { + + arma::uword S = log_py.n_rows; + arma::uword T = log_py.n_cols; + log_alpha.col(0) = log_pi + log_py.col(0); + for (arma::uword t = 1; t < T; t++) { + for (arma::uword i = 0; i < S; i++) { + log_alpha(i, t) = logSumExp( + log_alpha.col(t - 1) + log_A.slice(t - 1).col(i) + log_py(i, t) + ); + } + } +} + +// // time-invariant A +// template +// void univariate_forward_nhmm( +// submat& log_alpha, +// const arma::vec& log_pi, +// const arma::mat& log_A, +// const arma::mat& log_py) { +// +// arma::uword S = log_py.n_rows; +// arma::uword T = log_py.n_cols; +// log_alpha.col(0) = log_pi + log_py.col(0); +// for (arma::uword t = 1; t < T; t++) { +// for (arma::uword i = 0; i < S; i++) { +// log_alpha(i, t) = logSumExp( +// log_alpha.col(t - 1) + log_A.col(i) + log_py(i, t) +// ); +// } +// } +// } + +template +void forward_nhmm(Model& model, arma::cube& log_alpha) { + for (arma::uword i = 0; i < model.N; i++) { + model.update_probs(i); + model.update_log_py(i); + univariate_forward_nhmm( + log_alpha.slice(i), + model.log_Pi, + model.log_A, + model.log_py.cols(0, model.Ti(i) - 1) + ); + } +} + +template +void forward_mnhmm(Model& model, arma::cube& log_alpha) { + for (arma::uword i = 0; i < model.N; i++) { + + model.update_omega(i); + model.update_probs(i); + model.update_log_py(i); + for (arma::uword d = 0; d < model.D; d++) { + arma::subview submat = + log_alpha.slice(i).rows(d * model.S, (d + 1) * model.S - 1); + univariate_forward_nhmm( + submat, + model.omega(d) + model.log_Pi(d), + model.log_A(d), + model.log_py.slice(d).cols(0, model.Ti(i) - 1) + ); + } + } +} +#endif diff --git a/src/gradients.cpp b/src/nhmm_gradients.cpp similarity index 60% rename from src/gradients.cpp rename to src/nhmm_gradients.cpp index 066472b5..40553949 100644 --- a/src/gradients.cpp +++ b/src/nhmm_gradients.cpp @@ -1,230 +1,230 @@ -#include "gradients.h" +#include "nhmm_gradients.h" void gradient_wrt_omega( - arma::mat& grad, arma::mat& tmpmat, const arma::mat& Qt, + arma::mat& grad, arma::mat& tmpmat, const arma::mat& Q, const arma::vec& omega, const arma::vec& loglik_i, const arma::vec& loglik, const arma::mat& X, - const unsigned int i) { + const arma::uword i) { tmpmat = -omega * omega.t(); tmpmat.diag() += omega; - grad += Qt * tmpmat * exp(loglik_i - loglik(i)) * X.col(i).t(); + grad += Q.t() * tmpmat * exp(loglik_i - loglik(i)) * X.col(i).t(); } void gradient_wrt_pi( - arma::mat& grad, arma::mat& tmpmat, const arma::mat& Qt, + arma::mat& grad, arma::mat& tmpmat, const arma::mat& Q, const arma::mat& log_py, const arma::mat& log_beta, const double ll, - const arma::vec& Pi, const arma::mat& X, const unsigned int i) { + const arma::vec& Pi, const arma::mat& X, const arma::uword i) { tmpmat = -Pi * Pi.t(); tmpmat.diag() += Pi; - grad += Qt * tmpmat * exp(log_py.col(0) + log_beta.col(0) - ll) * X.col(i).t(); + grad += Q.t() * tmpmat * exp(log_py.col(0) + log_beta.col(0) - ll) * X.col(i).t(); } void gradient_wrt_pi( - arma::mat& grad, arma::mat& tmpmat, const arma::mat& Qt, + arma::mat& grad, arma::mat& tmpmat, const arma::mat& Q, const arma::vec& log_omega, const arma::cube& log_py, const arma::cube& log_beta, const arma::vec& loglik, - const arma::field& Pi, const arma::mat& X, const unsigned int i, - const unsigned int d) { + const arma::field& Pi, const arma::mat& X, const arma::uword i, + const arma::uword d) { tmpmat = -Pi(d) * Pi(d).t(); tmpmat.diag() += Pi(d); - grad += Qt * tmpmat * exp(log_omega(d) + log_py.slice(d).col(0) + + grad += Q.t() * tmpmat * exp(log_omega(d) + log_py.slice(d).col(0) + log_beta.slice(d).col(0) - loglik(i)) * X.col(i).t(); } void gradient_wrt_A( - arma::mat& grad, arma::mat& tmpmat, const arma::mat& Qt, + arma::mat& grad, arma::mat& tmpmat, const arma::mat& Q, const arma::mat& log_py, const arma::mat& log_alpha, const arma::mat& log_beta, const double ll, const arma::cube& A, - const arma::cube& X, const unsigned int i, const unsigned int t, - const unsigned int s) { + const arma::cube& X, const arma::uword i, const arma::uword t, + const arma::uword s) { tmpmat = -A.slice(t).row(s).t() * A.slice(t).row(s); tmpmat.diag() += A.slice(t).row(s); - grad += Qt * tmpmat * exp(log_alpha(s, t) + log_py.col(t + 1) + + grad += Q.t() * tmpmat * exp(log_alpha(s, t) + log_py.col(t + 1) + log_beta.col(t + 1) - ll) * X.slice(i).col(t).t(); } void gradient_wrt_A( - arma::mat& grad, arma::mat& tmpmat, const arma::mat& Qt, + arma::mat& grad, arma::mat& tmpmat, const arma::mat& Q, const arma::vec& log_omega, const arma::cube& log_py, const arma::cube& log_alpha, const arma::cube& log_beta, const arma::vec& loglik, const arma::field A, - const arma::cube& X, const unsigned int i, const unsigned int t, - const unsigned int s, const unsigned int d) { + const arma::cube& X, const arma::uword i, const arma::uword t, + const arma::uword s, const arma::uword d) { tmpmat = -A(d).slice(t).row(s).t() * A(d).slice(t).row(s); tmpmat.diag() += A(d).slice(t).row(s); - grad += Qt * tmpmat * exp(log_omega(d) + log_alpha(s, t, d) + + grad += Q.t() * tmpmat * exp(log_omega(d) + log_alpha(s, t, d) + log_py.slice(d).col(t + 1) + log_beta.slice(d).col(t + 1) - loglik(i)) * X.slice(i).col(t).t(); } // NHMM singlechannel void gradient_wrt_B_t0( - arma::mat& grad, arma::vec& tmpvec, const arma::mat& Qt, + arma::mat& grad, arma::vec& tmpvec, const arma::mat& Q, const arma::umat& obs, const arma::vec& log_Pi, const arma::mat& log_beta, const double ll, const arma::cube& B, const arma::cube& X, - const unsigned int i, const unsigned int s) { + const arma::uword i, const arma::uword s) { arma::rowvec Brow = B.slice(0).row(s).cols(0, B.n_cols - 2); - unsigned int idx = obs(0, i); + arma::uword idx = obs(0, i); double brow = Brow(idx); tmpvec = -Brow.t() * brow; tmpvec(idx) += brow; - grad += Qt * exp(log_Pi(s) + log_beta(s, 0) - ll) * tmpvec * X.slice(i).col(0).t(); + grad += Q.t() * exp(log_Pi(s) + log_beta(s, 0) - ll) * tmpvec * X.slice(i).col(0).t(); } void gradient_wrt_B( - arma::mat& grad, arma::vec& tmpvec, const arma::mat& Qt, + arma::mat& grad, arma::vec& tmpvec, const arma::mat& Q, const arma::umat& obs, const arma::mat& log_alpha, const arma::mat& log_beta, const double ll, const arma::cube& log_A, const arma::cube& B, const arma::cube& X, - const unsigned int i, const unsigned int s, const unsigned int t) { + const arma::uword i, const arma::uword s, const arma::uword t) { arma::rowvec Brow = B.slice(t + 1).row(s).cols(0, B.n_cols - 2); - unsigned int idx = obs(t + 1, i); + arma::uword idx = obs(t + 1, i); double brow = Brow(idx); tmpvec = -Brow.t() * brow; tmpvec(idx) += brow; - grad += Qt * arma::accu(exp(log_alpha.col(t) + log_A.slice(t).col(s) + + grad += Q.t() * arma::accu(exp(log_alpha.col(t) + log_A.slice(t).col(s) + log_beta(s, t + 1) - ll)) * tmpvec * X.slice(i).col(t + 1).t(); } // NHMM multichannel void gradient_wrt_B_t0( - arma::mat& grad, arma::vec& tmpvec, const arma::mat& Qt, + arma::mat& grad, arma::vec& tmpvec, const arma::mat& Q, const arma::ucube& obs, const arma::vec& log_Pi, const arma::mat& log_beta, const double ll, const arma::field& log_B, const arma::field& B, const arma::cube& X, - const arma::uvec& M, const unsigned int i, const unsigned int s, - const unsigned int c) { + const arma::uvec& M, const arma::uword i, const arma::uword s, + const arma::uword c) { - unsigned int C = M.n_elem; + arma::uword C = M.n_elem; arma::rowvec Brow = B(c).slice(0).row(s).cols(0, M(c) - 1); - unsigned int idx = obs(c, 0, i); + arma::uword idx = obs(c, 0, i); double brow = Brow(idx); tmpvec = -Brow.t() * brow; tmpvec(idx) += brow; double logpy = 0; - for (unsigned int cc = 0; cc < C; cc++) { + for (arma::uword cc = 0; cc < C; cc++) { if (cc != c) { logpy += log_B(cc)(s, obs(cc, 0, i), 0); } } - grad += Qt * exp(log_Pi(s) + logpy + log_beta(s, 0) - ll) * tmpvec * + grad += Q.t() * exp(log_Pi(s) + logpy + log_beta(s, 0) - ll) * tmpvec * X.slice(i).col(0).t(); } void gradient_wrt_B( - arma::mat& grad, arma::vec& tmpvec, const arma::mat& Qt, + arma::mat& grad, arma::vec& tmpvec, const arma::mat& Q, const arma::ucube& obs, const arma::mat& log_alpha, const arma::mat& log_beta, const double ll, const arma::cube& log_A, const arma::field& log_B, const arma::field& B, - const arma::cube& X, const arma::uvec& M, const unsigned int i, - const unsigned int s, const unsigned int t, const unsigned int c) { + const arma::cube& X, const arma::uvec& M, const arma::uword i, + const arma::uword s, const arma::uword t, const arma::uword c) { - unsigned int C = M.n_elem; + arma::uword C = M.n_elem; arma::rowvec Brow = B(c).slice(t + 1).row(s).cols(0, M(c) - 1); - unsigned int idx = obs(c, t + 1, i); + arma::uword idx = obs(c, t + 1, i); double brow = Brow(idx); tmpvec = -Brow.t() * brow; tmpvec(idx) += brow; double logpy = 0; - for (unsigned int cc = 0; cc < C; cc++) { + for (arma::uword cc = 0; cc < C; cc++) { if (cc != c) { logpy += log_B(cc)(s, obs(cc, t + 1, i), t + 1); } } - grad += Qt * arma::accu(exp(log_alpha.col(t) + log_A.slice(t).col(s) + + grad += Q.t() * arma::accu(exp(log_alpha.col(t) + log_A.slice(t).col(s) + logpy + log_beta(s, t + 1) - ll)) * tmpvec * X.slice(i).col(t + 1).t(); } // MNHMM singlechannel void gradient_wrt_B_t0( - arma::mat& grad, arma::vec& tmpvec, const arma::mat& Qt, + arma::mat& grad, arma::vec& tmpvec, const arma::mat& Q, const arma::vec& log_omega, const arma::umat& obs, const arma::field& log_Pi, const arma::cube& log_beta, const arma::vec& loglik, const arma::field& B, const arma::cube& X, - const unsigned int i, const unsigned int s, const unsigned d) { + const arma::uword i, const arma::uword s, const unsigned d) { - unsigned int M = B(d).n_cols - 1; + arma::uword M = B(d).n_cols - 1; arma::rowvec Brow = B(d).slice(0).row(s).cols(0, M - 1); - unsigned int idx = obs(0, i); + arma::uword idx = obs(0, i); double brow = Brow(idx); tmpvec = -Brow.t() * brow; tmpvec(idx) += brow; - grad += Qt * exp(log_omega(d) + log_Pi(d)(s) + log_beta(s, 0, d) - + grad += Q.t() * exp(log_omega(d) + log_Pi(d)(s) + log_beta(s, 0, d) - loglik(i)) * tmpvec * X.slice(i).col(0).t(); } void gradient_wrt_B( - arma::mat& grad, arma::vec& tmpvec, const arma::mat& Qt, + arma::mat& grad, arma::vec& tmpvec, const arma::mat& Q, const arma::vec& log_omega, const arma::umat& obs, const arma::cube& log_alpha, const arma::cube& log_beta, const arma::vec& loglik, const arma::field& log_A, const arma::field& B, - const arma::cube& X, const unsigned int i, const unsigned int s, - const unsigned int t, const unsigned int d) { + const arma::cube& X, const arma::uword i, const arma::uword s, + const arma::uword t, const arma::uword d) { - unsigned int M = B(0).n_cols - 1; + arma::uword M = B(0).n_cols - 1; arma::rowvec Brow = B(d).slice(t + 1).row(s).cols(0, M - 1); - unsigned int idx = obs(t + 1, i); + arma::uword idx = obs(t + 1, i); double brow = Brow(idx); tmpvec = -Brow.t() * brow; tmpvec(idx) += brow; - grad += Qt * arma::accu(exp(log_omega(d) + log_alpha.slice(d).col(t) + + grad += Q.t() * arma::accu(exp(log_omega(d) + log_alpha.slice(d).col(t) + log_A(d).slice(t).col(s) + log_beta(s, t + 1, d) - loglik(i))) * tmpvec * X.slice(i).col(t + 1).t(); } // MNHMM MC void gradient_wrt_B_t0( - arma::mat& grad, arma::vec& tmpvec, const arma::mat& Qt, + arma::mat& grad, arma::vec& tmpvec, const arma::mat& Q, const arma::vec& log_omega, const arma::ucube& obs, const arma::field& log_Pi, const arma::cube& log_beta, const arma::vec& loglik, const arma::field& log_B, const arma::field& B, const arma::cube& X, - const arma::uvec& M, const unsigned int i, const unsigned int s, - const unsigned int c, const unsigned int d) { + const arma::uvec& M, const arma::uword i, const arma::uword s, + const arma::uword c, const arma::uword d) { - unsigned int C = M.n_elem; + arma::uword C = M.n_elem; arma::rowvec Brow = B(d * C + c).slice(0).row(s).cols(0, M(c) - 1); - unsigned int idx = obs(c, 0, i); + arma::uword idx = obs(c, 0, i); double brow = Brow(idx); tmpvec = -Brow.t() * brow; tmpvec(idx) += brow; double logpy = 0; - for (unsigned int cc = 0; cc < C; cc++) { + for (arma::uword cc = 0; cc < C; cc++) { if (cc != c) { logpy += log_B(d * C + cc)(s, obs(cc, 0, i), 0); } } - grad += Qt * exp(log_omega(d) + log_Pi(d)(s) + logpy + + grad += Q.t() * exp(log_omega(d) + log_Pi(d)(s) + logpy + log_beta(s, 0, d) - loglik(i)) * tmpvec * X.slice(i).col(0).t(); } // MNHMM MC void gradient_wrt_B( - arma::mat& grad, arma::vec& tmpvec, const arma::mat& Qt, + arma::mat& grad, arma::vec& tmpvec, const arma::mat& Q, const arma::vec& log_omega, const arma::ucube& obs, const arma::cube& log_alpha, const arma::cube& log_beta, const arma::vec& loglik, const arma::field& log_A, const arma::field& log_B, const arma::field& B, - const arma::cube& X, const arma::uvec& M, const unsigned int i, - const unsigned int s, const unsigned int t, const unsigned int c, - const unsigned int d) { + const arma::cube& X, const arma::uvec& M, const arma::uword i, + const arma::uword s, const arma::uword t, const arma::uword c, + const arma::uword d) { - unsigned int C = M.n_elem; + arma::uword C = M.n_elem; arma::rowvec Brow = B(d * C + c).slice(t + 1).row(s).cols(0, M(c) - 1); - unsigned int idx = obs(c, t + 1, i); + arma::uword idx = obs(c, t + 1, i); double brow = Brow(idx); tmpvec = -Brow.t() * brow; tmpvec(idx) += brow; double logpy = 0; - for (unsigned int cc = 0; cc < C; cc++) { + for (arma::uword cc = 0; cc < C; cc++) { if (cc != c) { logpy += log_B(d * C + cc)(s, obs(cc, t + 1, i), t + 1); } } - grad += Qt * arma::accu(exp(log_omega(d) + log_alpha.slice(d).col(t) + + grad += Q.t() * arma::accu(exp(log_omega(d) + log_alpha.slice(d).col(t) + log_A(d).slice(t).col(s) + logpy + log_beta(s, t + 1, d) - loglik(i))) * tmpvec * X.slice(i).col(t + 1).t(); -} \ No newline at end of file +} diff --git a/src/gradients.h b/src/nhmm_gradients.h similarity index 58% rename from src/gradients.h rename to src/nhmm_gradients.h index 0a10ac26..21a9067a 100644 --- a/src/gradients.h +++ b/src/nhmm_gradients.h @@ -5,99 +5,99 @@ void gradient_wrt_omega( arma::mat& grad, arma::mat& tmpmat, - const arma::mat& Qt, const arma::vec& omega, + const arma::mat& Q, const arma::vec& omega, const arma::vec& loglik_i, const arma::vec& loglik, const arma::mat& X, - const unsigned int i); + const arma::uword i); void gradient_wrt_pi( - arma::mat& grad, arma::mat& tmpmat,const arma::mat& Qt, + arma::mat& grad, arma::mat& tmpmat,const arma::mat& Q, const arma::mat& log_py, const arma::mat& log_beta, const double ll, - const arma::vec& Pi, const arma::mat& X, const unsigned int i); + const arma::vec& Pi, const arma::mat& X, const arma::uword i); void gradient_wrt_pi( - arma::mat& grad, arma::mat& tmpmat,const arma::mat& Qt, + arma::mat& grad, arma::mat& tmpmat,const arma::mat& Q, const arma::vec& log_omega, const arma::cube& log_py, const arma::cube& log_beta, const arma::vec& loglik, - const arma::field& Pi, const arma::mat& X, const unsigned int i, - const unsigned int d); + const arma::field& Pi, const arma::mat& X, const arma::uword i, + const arma::uword d); void gradient_wrt_A( - arma::mat& grad, arma::mat& tmpmat,const arma::mat& Qt, + arma::mat& grad, arma::mat& tmpmat,const arma::mat& Q, const arma::mat& log_py, const arma::mat& log_alpha, const arma::mat& log_beta, const double ll, const arma::cube& A, - const arma::cube& X, const unsigned int i, const unsigned int t, - const unsigned int s); + const arma::cube& X, const arma::uword i, const arma::uword t, + const arma::uword s); void gradient_wrt_A( - arma::mat& grad, arma::mat& tmpmat,const arma::mat& Qt, + arma::mat& grad, arma::mat& tmpmat,const arma::mat& Q, const arma::vec& log_omega, const arma::cube& log_py, const arma::cube& log_alpha, const arma::cube& log_beta, const arma::vec& loglik, const arma::field A, - const arma::cube& X, const unsigned int i, const unsigned int t, - const unsigned int s, const unsigned int d); + const arma::cube& X, const arma::uword i, const arma::uword t, + const arma::uword s, const arma::uword d); // NHMM SC void gradient_wrt_B_t0( - arma::mat& grad, arma::vec& tmpvec, const arma::mat& Qt, + arma::mat& grad, arma::vec& tmpvec, const arma::mat& Q, const arma::umat& obs, const arma::vec& log_Pi, const arma::mat& log_beta, const double ll, const arma::cube& B, const arma::cube& X, - const unsigned int i, const unsigned int s); + const arma::uword i, const arma::uword s); void gradient_wrt_B( - arma::mat& grad, arma::vec& tmpvec, const arma::mat& Qt, + arma::mat& grad, arma::vec& tmpvec, const arma::mat& Q, const arma::umat& obs, const arma::mat& log_alpha, const arma::mat& log_beta, const double ll, const arma::cube& log_A, const arma::cube& B, const arma::cube& X, - const unsigned int i, const unsigned int s, const unsigned int t); + const arma::uword i, const arma::uword s, const arma::uword t); // NHMM MC void gradient_wrt_B_t0( - arma::mat& grad, arma::vec& tmpvec, const arma::mat& Qt, + arma::mat& grad, arma::vec& tmpvec, const arma::mat& Q, const arma::ucube& obs, const arma::vec& log_Pi, const arma::mat& log_beta, const double ll, const arma::field& log_B, const arma::field& B, const arma::cube& X, - const arma::uvec& M, const unsigned int i, const unsigned int s, - const unsigned int c); + const arma::uvec& M, const arma::uword i, const arma::uword s, + const arma::uword c); void gradient_wrt_B( - arma::mat& grad, arma::vec& tmpvec, const arma::mat& Qt, + arma::mat& grad, arma::vec& tmpvec, const arma::mat& Q, const arma::ucube& obs, const arma::mat& log_alpha, const arma::mat& log_beta, const double ll, const arma::cube& log_A, const arma::field& log_B, const arma::field& B, - const arma::cube& X, const arma::uvec& M, const unsigned int i, - const unsigned int s, const unsigned int t, const unsigned int c); + const arma::cube& X, const arma::uvec& M, const arma::uword i, + const arma::uword s, const arma::uword t, const arma::uword c); // MNHMM SC void gradient_wrt_B_t0( - arma::mat& grad, arma::vec& tmpvec, const arma::mat& Qt, + arma::mat& grad, arma::vec& tmpvec, const arma::mat& Q, const arma::vec& log_omega, const arma::umat& obs, const arma::field& log_Pi, const arma::cube& log_beta, const arma::vec& loglik, const arma::field& B, const arma::cube& X, - const unsigned int i, const unsigned int s, const unsigned d); + const arma::uword i, const arma::uword s, const unsigned d); void gradient_wrt_B( - arma::mat& grad, arma::vec& tmpvec, const arma::mat& Qt, + arma::mat& grad, arma::vec& tmpvec, const arma::mat& Q, const arma::vec& log_omega, const arma::umat& obs, const arma::cube& log_alpha, const arma::cube& log_beta, const arma::vec& loglik, const arma::field& log_A, const arma::field& B, - const arma::cube& X, const unsigned int i, const unsigned int s, - const unsigned int t, const unsigned int d); + const arma::cube& X, const arma::uword i, const arma::uword s, + const arma::uword t, const arma::uword d); // MNHMM MC void gradient_wrt_B_t0( - arma::mat& grad, arma::vec& tmpvec, const arma::mat& Qt, + arma::mat& grad, arma::vec& tmpvec, const arma::mat& Q, const arma::vec& log_omega, const arma::ucube& obs, const arma::field& log_Pi, const arma::cube& log_beta, const arma::vec& loglik, const arma::field& log_B, const arma::field& B, const arma::cube& X, - const arma::uvec& M, const unsigned int i, const unsigned int s, - const unsigned int c, const unsigned int d); + const arma::uvec& M, const arma::uword i, const arma::uword s, + const arma::uword c, const arma::uword d); void gradient_wrt_B( - arma::mat& grad, arma::vec& tmpvec, const arma::mat& Qt, + arma::mat& grad, arma::vec& tmpvec, const arma::mat& Q, const arma::vec& log_omega, const arma::ucube& obs, const arma::cube& log_alpha, const arma::cube& log_beta, const arma::vec& loglik, const arma::field& log_A, const arma::field& log_B, const arma::field& B, - const arma::cube& X, const arma::uvec& M, const unsigned int i, - const unsigned int s, const unsigned int t, const unsigned int c, - const unsigned int d); + const arma::cube& X, const arma::uvec& M, const arma::uword i, + const arma::uword s, const arma::uword t, const arma::uword c, + const arma::uword d); #endif diff --git a/src/nhmm_log_objective.cpp b/src/nhmm_log_objective.cpp new file mode 100644 index 00000000..78556154 --- /dev/null +++ b/src/nhmm_log_objective.cpp @@ -0,0 +1,442 @@ +// log-likelihood and gradients of NHMM +#include "nhmm_sc.h" +#include "nhmm_mc.h" +#include "mnhmm_sc.h" +#include "mnhmm_mc.h" + +#include "nhmm_forward.h" +#include "nhmm_backward.h" +#include "eta_to_gamma.h" +#include "get_parameters.h" +#include "logsumexp.h" +#include "nhmm_gradients.h" + +// [[Rcpp::export]] +Rcpp::List log_objective_nhmm_singlechannel( + arma::mat& eta_pi, const arma::mat& X_pi, + arma::cube& eta_A, const arma::cube& X_A, + arma::cube& eta_B, const arma::cube& X_B, + const arma::umat& obs, const bool iv_pi, const bool iv_A, const bool iv_B, + const bool tv_A, const bool tv_B, const arma::uvec& Ti) { + + nhmm_sc model( + eta_A.n_slices, X_pi, X_A, X_B, Ti, + iv_pi, iv_A, iv_B, tv_A, tv_B, obs, eta_pi, eta_A, eta_B + ); + + arma::vec loglik(model.N); + arma::mat log_alpha(model.S, model.T); + arma::mat log_beta(model.S, model.T); + + arma::mat grad_pi(model.S - 1, model.K_pi, arma::fill::zeros); + arma::cube grad_A(model.S - 1, model.K_A, model.S, arma::fill::zeros); + arma::cube grad_B(model.M - 1, model.K_B, model.S, arma::fill::zeros); + + arma::mat tmpmat(model.S, model.S); + arma::vec tmpvec(model.M); + for (arma::uword i = 0; i < model.N; i++) { + if (model.iv_pi || i == 0) { + model.update_pi(i); + } + if (model.iv_A || i == 0) { + model.update_A(i); + } + if (model.iv_B || i == 0) { + model.update_B(i); + } + model.update_log_py(i); + univariate_forward_nhmm( + log_alpha, model.log_Pi, model.log_A, + model.log_py.cols(0, model.Ti(i) - 1) + ); + univariate_backward_nhmm( + log_beta, model.log_A, model.log_py.cols(0, model.Ti(i) - 1) + ); + double ll = logSumExp(log_alpha.col(model.Ti(i) - 1)); + if (!std::isfinite(ll)) { + double small = -arma::datum::inf; + grad_pi.fill(small); + grad_A.fill(small); + grad_B.fill(small); + return Rcpp::List::create( + Rcpp::Named("loglik") = -arma::datum::inf, + Rcpp::Named("gradient_pi") = Rcpp::wrap(grad_pi), + Rcpp::Named("gradient_A") = Rcpp::wrap(grad_A), + Rcpp::Named("gradient_B") = Rcpp::wrap(grad_B) + ); + } + loglik(i) = ll; + // gradient wrt gamma_pi + gradient_wrt_pi(grad_pi, tmpmat, model.Qs, model.log_py, log_beta, ll, model.Pi, model.X_pi, i); + // gradient wrt gamma_A + for (arma::uword t = 0; t < (model.Ti(i) - 1); t++) { + for (arma::uword s = 0; s < model.S; s++) { + gradient_wrt_A(grad_A.slice(s), tmpmat, model.Qs, model.log_py, log_alpha, log_beta, ll, model.A, model.X_A, i, t, s); + } + } + // gradient wrt gamma_B + for (arma::uword s = 0; s < model.S; s++) { + if (model.obs(0, i) < model.M) { + gradient_wrt_B_t0(grad_B.slice(s), tmpvec, model.Qm, model.obs, model.log_Pi, log_beta, ll, model.B, model.X_B, i, s); + } + for (arma::uword t = 0; t < (model.Ti(i) - 1); t++) { + if (obs(t + 1, i) < model.M) { + gradient_wrt_B(grad_B.slice(s), tmpvec, model.Qm, model.obs, log_alpha, log_beta, ll, model.log_A, model.B, model.X_B, i, s, t); + } + } + } + } + return Rcpp::List::create( + Rcpp::Named("loglik") = sum(loglik), + Rcpp::Named("gradient_pi") = Rcpp::wrap(grad_pi), + Rcpp::Named("gradient_A") = Rcpp::wrap(grad_A), + Rcpp::Named("gradient_B") = Rcpp::wrap(grad_B) + ); +} + + +// [[Rcpp::export]] +Rcpp::List log_objective_nhmm_multichannel( + arma::mat& eta_pi, const arma::mat& X_pi, + arma::cube& eta_A, const arma::cube& X_A, + arma::field& eta_B, const arma::cube& X_B, + const arma::ucube& obs, const bool iv_pi, + const bool iv_A, const bool iv_B, const bool tv_A, const bool tv_B, + const arma::uvec& Ti) { + + nhmm_mc model( + eta_A.n_slices, X_pi, X_A, X_B, Ti, + iv_pi, iv_A, iv_B, tv_A, tv_B, obs, eta_pi, eta_A, eta_B + ); + + arma::vec loglik(model.N); + arma::mat log_alpha(model.S, model.T); + arma::mat log_beta(model.S, model.T); + + arma::mat grad_pi(model.S - 1, model.K_pi, arma::fill::zeros); + arma::cube grad_A(model.S - 1, model.K_A, model.S, arma::fill::zeros); + arma::field grad_B(model.C); + for (arma::uword c = 0; c < model.C; c++) { + grad_B(c) = arma::cube(model.M(c) - 1, model.K_B, model.S, arma::fill::zeros); + } + arma::mat tmpmat(model.S, model.S); + arma::field tmpvec(model.C); + for (arma::uword c = 0; c < model.C; c++) { + tmpvec(c) = arma::vec(model.M(c)); + } + for (arma::uword i = 0; i < model.N; i++) { + if (model.iv_pi || i == 0) { + model.update_pi(i); + } + if (model.iv_A || i == 0) { + model.update_A(i); + } + if (model.iv_B || i == 0) { + model.update_B(i); + } + model.update_log_py(i); + univariate_forward_nhmm( + log_alpha, model.log_Pi, model.log_A, + model.log_py.cols(0, model.Ti(i) - 1) + ); + univariate_backward_nhmm( + log_beta, model.log_A, model.log_py.cols(0, model.Ti(i) - 1) + ); + double ll = logSumExp(log_alpha.col(model.Ti(i) - 1)); + if (!std::isfinite(ll)) { + double small = -arma::datum::inf; // -std::max(std::min(1e10, N * 1e5), 1e3); + grad_pi.fill(small); + grad_A.fill(small); + for (arma::uword c = 0; c < model.C; c++) { + grad_B(c).fill(small); + } + return Rcpp::List::create( + Rcpp::Named("loglik") = -arma::datum::inf, + Rcpp::Named("gradient_pi") = Rcpp::wrap(grad_pi), + Rcpp::Named("gradient_A") = Rcpp::wrap(grad_A), + Rcpp::Named("gradient_B") = Rcpp::wrap(grad_B) + ); + } + loglik(i) = ll; + // gradient wrt gamma_pi + gradient_wrt_pi(grad_pi, tmpmat, model.Qs, model.log_py, log_beta, ll, model.Pi, model.X_pi, i); + // gradient wrt gamma_A + for (arma::uword t = 0; t < (model.Ti(i) - 1); t++) { + for (arma::uword s = 0; s < model.S; s++) { + gradient_wrt_A( + grad_A.slice(s), tmpmat, model.Qs, model.log_py, log_alpha, log_beta, ll, model.A, + model.X_A, i, t, s + ); + } + } + for (arma::uword c = 0; c < model.C; c++) { + for (arma::uword s = 0; s < model.S; s++) { + if (model.obs(c, 0, i) < model.M(c)) { + gradient_wrt_B_t0( + grad_B(c).slice(s), tmpvec(c), model.Qm(c), model.obs, model.log_Pi, log_beta, ll, + model.log_B, model.B, model.X_B, model.M, i, s, c + ); + } + for (arma::uword t = 0; t < (model.Ti(i) - 1); t++) { + if (model.obs(c, t + 1, i) < model.M(c)) { + gradient_wrt_B( + grad_B(c).slice(s), tmpvec(c), model.Qm(c), model.obs, log_alpha, log_beta, + ll, model.log_A, model.log_B, model.B, model.X_B, model.M, i, s, t, c + ); + } + } + } + } + } + return Rcpp::List::create( + Rcpp::Named("loglik") = sum(loglik), + Rcpp::Named("gradient_pi") = Rcpp::wrap(grad_pi), + Rcpp::Named("gradient_A") = Rcpp::wrap(grad_A), + Rcpp::Named("gradient_B") = Rcpp::wrap(grad_B) + ); +} + +// [[Rcpp::export]] +Rcpp::List log_objective_mnhmm_singlechannel( + arma::mat& eta_omega, const arma::mat& X_omega, + arma::field& eta_pi, const arma::mat& X_pi, + arma::field& eta_A, const arma::cube& X_A, + arma::field& eta_B, const arma::cube& X_B, + const arma::umat& obs, const bool iv_pi, const bool iv_A, const bool iv_B, + const bool tv_A, const bool tv_B, const bool iv_omega, + const arma::uvec& Ti) { + + mnhmm_sc model( + eta_A(0).n_slices, eta_A.n_rows, X_omega, X_pi, X_A, X_B, Ti, iv_omega, + iv_pi, iv_A, iv_B, tv_A, tv_B, obs, eta_omega, eta_pi, eta_A, eta_B + ); + + arma::vec loglik(model.N); + arma::vec loglik_i(model.D); + arma::cube log_alpha(model.S, model.T, model.D); + arma::cube log_beta(model.S, model.T, model.D); + arma::mat grad_omega(model.D - 1, model.K_omega, arma::fill::zeros); + arma::field grad_pi(model.D); + arma::field grad_A(model.D); + arma::field grad_B(model.D); + for (arma::uword d = 0; d < model.D; d++) { + grad_pi(d) = arma::mat(model.S - 1, model.K_pi, arma::fill::zeros); + grad_A(d) = arma::cube(model.S - 1, model.K_A, model.S, arma::fill::zeros); + grad_B(d) = arma::cube(model.M - 1, model.K_B, model.S, arma::fill::zeros); + } + arma::mat tmpmat(model.S, model.S); + arma::mat tmpmatD(model.D, model.D); + arma::vec tmpvec(model.M); + for (arma::uword i = 0; i < model.N; i++) { + if (model.iv_omega || i == 0) { + model.update_omega(i); + } + if (model.iv_pi || i == 0) { + model.update_pi(i); + } + if (model.iv_A || i == 0) { + model.update_A(i); + } + if (model.iv_B || i == 0) { + model.update_B(i); + } + model.update_log_py(i); + for (arma::uword d = 0; d < model.D; d++) { + univariate_forward_nhmm( + log_alpha.slice(d), model.log_Pi(d), model.log_A(d), + model.log_py.slice(d).cols(0, model.Ti(i) - 1) + ); + univariate_backward_nhmm( + log_beta.slice(d), model.log_A(d), model.log_py.slice(d).cols(0, model.Ti(i) - 1) + ); + loglik_i(d) = logSumExp(log_alpha.slice(d).col(model.Ti(i) - 1)); + } + loglik(i) = logSumExp(model.log_omega + loglik_i); + if (!std::isfinite(loglik(i))) { + double small = -arma::datum::inf; // -std::max(std::min(1e10, N * 1e5), 1e3); + grad_omega.fill(small); + for (arma::uword d = 0; d < model.D; d++) { + grad_pi(d).fill(small); + grad_A(d).fill(small); + grad_B(d).fill(small); + } + return Rcpp::List::create( + Rcpp::Named("loglik") = -arma::datum::inf, + Rcpp::Named("gradient_pi") = Rcpp::wrap(grad_pi), + Rcpp::Named("gradient_A") = Rcpp::wrap(grad_A), + Rcpp::Named("gradient_B") = Rcpp::wrap(grad_B), + Rcpp::Named("gradient_omega") = Rcpp::wrap(grad_omega) + ); + } + // gradient wrt gamma_pi + // d loglik / d pi + for (arma::uword d = 0; d < model.D; d++) { + // gradient wrt gamma_pi + gradient_wrt_pi( + grad_pi(d), tmpmat, model.Qs, model.log_omega, model.log_py, log_beta, loglik, model.Pi, model.X_pi, + i, d + ); + // gradient wrt gamma_A + for (arma::uword t = 0; t < (model.Ti(i) - 1); t++) { + for (arma::uword s = 0; s < model.S; s++) { + gradient_wrt_A( + grad_A(d).slice(s), tmpmat, model.Qs, model.log_omega, model.log_py, log_alpha, + log_beta, loglik, model.A, model.X_A, i, t, s, d + ); + } + } + for (arma::uword s = 0; s < model.S; s++) { + if (model.obs(0, i) < model.M) { + gradient_wrt_B_t0( + grad_B(d).slice(s), tmpvec, model.Qm, model.log_omega, model.obs, model.log_Pi, log_beta, + loglik, model.B, model.X_B, i, s, d + ); + } + for (arma::uword t = 0; t < (model.T - 1); t++) { + if (model.obs(t + 1, i) < model.M) { + gradient_wrt_B( + grad_B(d).slice(s), tmpvec, model.Qm, model.log_omega, model.obs, log_alpha, + log_beta, loglik, model.log_A, model.B, model.X_B, i, s, t, d + ); + } + } + } + } + gradient_wrt_omega(grad_omega, tmpmatD, model.Qd, model.omega, loglik_i, loglik, model.X_omega, i); + } + return Rcpp::List::create( + Rcpp::Named("loglik") = sum(loglik), + Rcpp::Named("gradient_pi") = Rcpp::wrap(grad_pi), + Rcpp::Named("gradient_A") = Rcpp::wrap(grad_A), + Rcpp::Named("gradient_B") = Rcpp::wrap(grad_B), + Rcpp::Named("gradient_omega") = Rcpp::wrap(grad_omega) + ); +} + +// [[Rcpp::export]] +Rcpp::List log_objective_mnhmm_multichannel( + arma::mat& eta_omega, const arma::mat& X_omega, + arma::field& eta_pi, const arma::mat& X_pi, + arma::field& eta_A, const arma::cube& X_A, + arma::field& eta_B, const arma::cube& X_B, + const arma::ucube& obs, const bool iv_pi, const bool iv_A, const bool iv_B, + const bool tv_A, const bool tv_B, const bool iv_omega, + const arma::uvec& Ti) { + + mnhmm_mc model( + eta_A(0).n_slices, eta_A.n_rows, X_omega, X_pi, X_A, X_B, Ti, iv_omega, + iv_pi, iv_A, iv_B, tv_A, tv_B, obs, eta_omega, eta_pi, eta_A, eta_B + ); + + arma::vec loglik(model.N); + arma::vec loglik_i(model.D); + arma::cube log_alpha(model.S, model.T, model.D); + arma::cube log_beta(model.S, model.T, model.D); + arma::mat grad_omega(model.D - 1, model.K_omega, arma::fill::zeros); + arma::field grad_pi(model.D); + arma::field grad_A(model.D); + arma::field grad_B(model.C, model.D); + for (arma::uword d = 0; d < model.D; d++) { + grad_pi(d) = arma::mat(model.S - 1, model.K_pi, arma::fill::zeros); + grad_A(d) = arma::cube(model.S - 1, model.K_A, model.S, arma::fill::zeros); + for (arma::uword c = 0; c < model.C; c++) { + grad_B(c, d) = arma::cube(model.M(c) - 1, model.K_B, model.S, arma::fill::zeros); + } + } + arma::mat tmpmat(model.S, model.S); + arma::mat tmpmatD(model.D, model.D); + arma::field tmpvec(model.C); + for (arma::uword c = 0; c < model.C; c++) { + tmpvec(c) = arma::vec(model.M(c)); + } + for (arma::uword i = 0; i < model.N; i++) { + if (model.iv_omega || i == 0) { + model.update_omega(i); + } + if (model.iv_pi || i == 0) { + model.update_pi(i); + } + if (model.iv_A || i == 0) { + model.update_A(i); + } + if (model.iv_B || i == 0) { + model.update_B(i); + } + model.update_log_py(i); + for (arma::uword d = 0; d < model.D; d++) { + univariate_forward_nhmm( + log_alpha.slice(d), model.log_Pi(d), model.log_A(d), + model.log_py.slice(d).cols(0, model.Ti(i) - 1) + ); + univariate_backward_nhmm( + log_beta.slice(d), model.log_A(d), model.log_py.slice(d).cols(0, model.Ti(i) - 1) + ); + loglik_i(d) = logSumExp(log_alpha.slice(d).col(model.Ti(i) - 1)); + } + loglik(i) = logSumExp(model.log_omega + loglik_i); + if (!std::isfinite(loglik(i))) { + double small = -arma::datum::inf; // -std::max(std::min(1e10, N * 1e5), 1e3); + grad_omega.fill(small); + for (arma::uword d = 0; d < model.D; d++) { + grad_pi(d).fill(small); + grad_A(d).fill(small); + for (arma::uword c = 0; c < model.C; c++) { + grad_B(c, d).fill(small); + } + } + return Rcpp::List::create( + Rcpp::Named("loglik") = -arma::datum::inf, + Rcpp::Named("gradient_pi") = Rcpp::wrap(grad_pi), + Rcpp::Named("gradient_A") = Rcpp::wrap(grad_A), + Rcpp::Named("gradient_B") = Rcpp::wrap(grad_B), + Rcpp::Named("gradient_omega") = Rcpp::wrap(grad_omega) + ); + } + // gradient wrt gamma_pi + // d loglik / d pi + for (arma::uword d = 0; d < model.D; d++) { + // gradient wrt gamma_pi + gradient_wrt_pi( + grad_pi(d), tmpmat, model.Qs, model.log_omega, model.log_py, log_beta, loglik, model.Pi, model.X_pi, + i, d + ); + // gradient wrt gamma_A + for (arma::uword t = 0; t < (model.Ti(i) - 1); t++) { + for (arma::uword s = 0; s < model.S; s++) { + gradient_wrt_A( + grad_A(d).slice(s), tmpmat, model.Qs, model.log_omega, model.log_py, log_alpha, + log_beta, loglik, model.A, model.X_A, i, t, s, d + ); + } + } + // gradient wrt gamma_B + for (arma::uword c = 0; c < model.C; c++) { + for (arma::uword s = 0; s < model.S; s++) { + if (model.obs(c, 0, i) < model.M(c)) { + gradient_wrt_B_t0( + grad_B(c, d).slice(s), tmpvec(c), model.Qm(c), model.log_omega, model.obs, model.log_Pi, + log_beta, loglik, model.log_B, model.B, model.X_B, model.M, i, s, c, d + ); + } + for (arma::uword t = 0; t < (model.T - 1); t++) { + if (model.obs(c, t + 1, i) < model.M(c)) { + gradient_wrt_B( + grad_B(c, d).slice(s), tmpvec(c), model.Qm(c), model.log_omega, model.obs, + log_alpha, log_beta, loglik, model.log_A, model.log_B, model.B, model.X_B, model.M, i, s, t, + c, d + ); + } + } + } + } + } + gradient_wrt_omega(grad_omega, tmpmatD, model.Qd, model.omega, loglik_i, loglik, model.X_omega, i); + } + return Rcpp::List::create( + Rcpp::Named("loglik") = sum(loglik), + Rcpp::Named("gradient_pi") = Rcpp::wrap(grad_pi), + Rcpp::Named("gradient_A") = Rcpp::wrap(grad_A), + Rcpp::Named("gradient_B") = Rcpp::wrap(grad_B), + Rcpp::Named("gradient_omega") = Rcpp::wrap(grad_omega) + ); +} diff --git a/src/nhmm_mc.h b/src/nhmm_mc.h new file mode 100644 index 00000000..2e8022b7 --- /dev/null +++ b/src/nhmm_mc.h @@ -0,0 +1,92 @@ +#ifndef NHMM_MC_H +#define NHMM_MC_H + +#include +#include "create_Q.h" +#include "eta_to_gamma.h" +#include "softmax.h" +#include "nhmm_base.h" + +struct nhmm_mc : public nhmm_base { + + const arma::ucube& obs; + const arma::uword C; + arma::field eta_B; + arma::uvec M; + arma::field Qm; + arma::field gamma_B; + // these store Pi, A, B, and log_p(y) of _one_ id we are currently working with + arma::field B; + arma::field log_B; + + nhmm_mc( + const arma::uword S_, + const arma::mat& X_pi_, + const arma::cube& X_s_, + const arma::cube& X_o_, + const arma::uvec& Ti_, + const bool iv_pi_, + const bool iv_A_, + const bool iv_B_, + const bool tv_A_, + const bool tv_B_, + const arma::ucube& obs_, + arma::mat& eta_pi_, + arma::cube& eta_A_, + arma::field& eta_B_) + : nhmm_base(S_, X_pi_, X_s_, X_o_, Ti_, iv_pi_, iv_A_, iv_B_, tv_A_, tv_B_, eta_pi_, eta_A_), + obs(obs_), + eta_B(eta_B_), + C(obs.n_rows), + M(arma::uvec(C)), + Qm(arma::field(C)), + gamma_B(arma::field(C)), + B(arma::field(C)), + log_B(arma::field(C)) { + + for (arma::uword c = 0; c < C; c++) { + M(c) = eta_B(c).n_rows + 1; + Qm(c) = create_Q(M(c)); + gamma_B(c) = eta_to_gamma(eta_B(c), Qm(c)); + B(c) = arma::cube(S, M(c) + 1, T); // B field initialization + log_B(c) = arma::cube(S, M(c) + 1, T); // log_B field initialization + } + } + void update_B(const arma::uword i) { + for (arma::uword c = 0; c < C; c++) { + arma::mat Btmp(M(c) + 1, S, arma::fill::ones); + if (tv_B) { + for (arma::uword t = 0; t < Ti(i); t++) { // time + for (arma::uword s = 0; s < S; s++) { // from states + Btmp.col(s).rows(0, M(c) - 1) = softmax(gamma_B(c).slice(s) * X_B.slice(i).col(t)); + } + B(c).slice(t) = Btmp.t(); + } + } else { + for (arma::uword s = 0; s < S; s++) { // from states + Btmp.col(s).rows(0, M(c) - 1) = softmax( + gamma_B(c).slice(s) * X_B.slice(i).col(0) + ); + } + B(c).each_slice() = Btmp.t(); + } + log_B(c) = arma::log(B(c)); + } + } + + void update_probs(const arma::uword i) { + update_pi(i); + update_A(i); + update_B(i); + } + + void update_log_py(const arma::uword i) { + log_py.zeros(); + for (arma::uword t = 0; t < Ti(i); t++) { + for (arma::uword c = 0; c < C; c++) { + log_py.col(t) += log_B(c).slice(t).col(obs(c, t, i)); + } + } + } +}; +#endif diff --git a/src/nhmm_mstep.cpp b/src/nhmm_mstep.cpp new file mode 100644 index 00000000..9b111888 --- /dev/null +++ b/src/nhmm_mstep.cpp @@ -0,0 +1,311 @@ +// #include "eta_to_gamma.h" +// #include "get_parameters.h" +// #include "logsumexp.h" +// #include "nhmm.h" +// #include "sum_to_zero.h" +// #include +// +// struct nhmm_opt_data { +// nhmm model; +// arma::vec E_Pi; +// arma::mat E_A; +// arma::mat E_B; +// nhmm_opt_data(const nhmm& model_, const arma::vec& E_Pi_, +// const arma::vec& E_A_, const arma::vec& E_B_): model(model_), +// E_Pi(E_Pi_), E_A(E_A_), E_B(E_B_) {} +// }; +// // Global counter for function evaluations +// static int iter = 0; +// +// // Define actual objective function +// double objective_pi(const arma::vec& x, arma::vec& grad, void *data) { +// iter++; +// // cast generic void* pointer data to a pointer to a nhmm_opt_data type +// nhmm_opt_data* opt_data = static_cast(data); +// // model is a pointer to a model of opt_data +// nhmm* model = &(opt_data->model); +// model->eta_pi = arma::mat(x.memptr(), model->S - 1, model->K_pi); +// model->gamma_pi = sum_to_zero(model->eta_pi, model->Qs); +// arma::vec Pi(model->S); +// double value = 0; +// arma::mat Qt = (model->Qs).t(); +// for (arma::uword i = 0; i < model->N; i++) { +// if (model->iv_pi || i == 0) { +// Pi = get_pi(model->gamma_pi, model->X_pi.col(i)); +// } +// value -= arma::as_scalar(opt_data->E_Pi.t() * model->gamma_pi * model->X_pi.col(i) - sum(opt_data->E_Pi) * logSumExp(model->gamma_pi * model->X_pi.col(i))); +// grad += Qt * (opt_data->E_Pi - sum(opt_data->E_Pi) * Pi) * model->X_pi.col(i).t(); +// } +// return value; +// } +// +// // Wrapper function for NLopt to interface with Armadillo +// double c_objective_pi(unsigned n, const double *x, double *grad, void *data) { +// // Wrap raw pointer `x` in an Armadillo vector (read/write access) +// arma::vec x_vec(const_cast(x), n, false, true); +// // Wrap the gradient pointer `grad` in an Armadillo vector +// arma::vec grad_vec(grad, n, false, true); +// // Call the Armadillo-based objective function +// return objective_pi(x_vec, grad_vec, data); +// } +// +// // // Wrapper function for NLopt to interface with Armadillo +// // double c_objective_A(unsigned n, const double *x, double *grad, void *data) { +// // // Wrap raw pointer `x` in an Armadillo vector (read/write access) +// // arma::vec x_vec(const_cast(x), n, false, true); +// // +// // // Wrap the gradient pointer `grad` in an Armadillo vector +// // arma::vec grad_vec(grad, n, false, true); +// // +// // // Call the Armadillo-based function +// // return objective_A(x_vec, grad_vec, data); +// // } +// // +// // // Wrapper function for NLopt to interface with Armadillo +// // double c_objective_B(unsigned n, const double *x, double *grad, void *data) { +// // // Wrap raw pointer `x` in an Armadillo vector (read/write access) +// // arma::vec x_vec(const_cast(x), n, false, true); +// // +// // // Wrap the gradient pointer `grad` in an Armadillo vector +// // arma::vec grad_vec(grad, n, false, true); +// // +// // // Call the Armadillo-based function +// // return objective_B(x_vec, grad_vec, data); +// // } +// +// +// // double objective_A(const arma::vec& x, arma::vec& grad, void *data) { +// // iter++; +// // nhmm* model = static_cast(data.model); +// // arma::vec E_A = static_cast(data.E_A); +// // unsigned state = static_cast(data.state); +// // arma::mat eta_A = arma::mat(x.memptr(), model->S - 1, model->K_A); +// // arma::mat gamma_A = sum_to_zero(model->eta_A, model->Qs); +// // arma::vec A(model->S); +// // double value = 0; +// // arma::mat Qt = (model->Qs).t(); +// // for (arma::uword i = 0; i < model->N; i++) { +// // if (model->iv_A || i == 0) { +// // A = get_pi(model->gamma_A, model->X_A.col(i)); +// // } +// // value -= (E_Pi.t() * gamma_pi * X_pi.col(i) - sum(E_Pi) * logSumExp(model->gamma_pi * model->X_pi.col(i))); +// // grad += Qt * (E_Pi - sum(E_Pi) * Pi) * model->X.col(i).t(); +// // } +// // return value; +// // } +// // double objective_pi(const arma::vec& x, arma::vec& grad, void *data) { +// // iter++; +// // nhmm* model = static_cast(data); +// // model->eta_pi = arma::mat(x.memptr(), model->S - 1, model->K_pi); +// // model->gamma_pi = sum_to_zero(model->eta_pi, model->Qs); +// // arma::vec Pi(model->S); +// // double value = 0; +// // arma::mat Qt = (model->Qs).t(); +// // for (arma::uword i = 0; i < model->N; i++) { +// // if (model->iv_pi || i == 0) { +// // Pi = get_pi(model->gamma_pi, model->X_pi.col(i)); +// // } +// // value -= (E_Pi.t() * gamma_pi * X_pi.col(i) - sum(E_Pi) * logSumExp(model->gamma_pi * model->X_pi.col(i))); +// // grad += Qt * (E_Pi - sum(E_Pi) * Pi) * model->X.col(i).t(); +// // } +// // return value; +// // } +// void nhmm::mstep( +// const arma::vec E_Pi, const arma::cube E_A, const arma::cube E_B, +// const double xtol_abs, const double ftol_abs, const double xtol_rel, +// const double ftol_rel, arma::uword maxeval) { +// +// nhmm_opt_data opt_data(model, E_Pi, E_A, E_B); +// // pi +// nlopt_opt opt_pi = nlopt_create(NLOPT_LD_LBFGS, model.np_pi); +// nlopt_set_min_objective(opt_pi, c_objective_pi, &opt_data); +// nlopt_set_xtol_abs1(opt_pi, xtol_abs); +// nlopt_set_ftol_abs(opt_pi, ftol_abs); +// nlopt_set_xtol_rel(opt_pi, xtol_rel); +// nlopt_set_ftol_rel(opt_pi, ftol_rel); +// nlopt_set_maxeval(opt_pi, maxeval); +// arma::vec x = arma::vectorise(model.eta_pi); +// double minf; +// iter = 0; // Reset counter +// int status = nlopt_optimize(opt_pi, x.memptr(), &minf); +// nlopt_destroy(opt_pi); +// +// // // A +// // nlopt_opt opt_A = nlopt_create(NLOPT_LD_LBFGS, model.np_pi); +// // nlopt_set_min_objective(opt_A, c_objective_A, &model); +// // nlopt_set_xtol_abs(opt_A, xtol_abs); +// // nlopt_set_ftol_abs(opt_A, ftol_abs); +// // nlopt_set_xtol_rel(opt_A, xtol_rel); +// // nlopt_set_ftol_rel(opt_A, ftol_rel); +// // nlopt_set_maxeval(opt_A, maxeval); +// // arma::vec x = arma::vectorise(model.eta_A); +// // double minf; +// // iter = 0; // Reset counter +// // int status = nlopt_optimize(opt_A, x.memptr(), &minf); +// // nlopt_destroy(opt_A); +// // +// // // B +// // nlopt_opt opt_B = nlopt_create(NLOPT_LD_LBFGS, model.np_pi); +// // nlopt_set_min_objective(opt_B, c_objective_B, &model); +// // nlopt_set_xtol_abs(opt_B, xtol_abs); +// // nlopt_set_ftol_abs(opt_B, ftol_abs); +// // nlopt_set_xtol_rel(opt_B, xtol_rel); +// // nlopt_set_ftol_rel(opt_B, ftol_rel); +// // nlopt_set_maxeval(opt_B, maxeval); +// // arma::vec x = arma::vectorise(model.eta_B); +// // double minf; +// // iter = 0; // Reset counter +// // int status = nlopt_optimize(opt_B, x.memptr(), &minf); +// // nlopt_destroy(opt_B); +// // +// } +// // +// // double nhmm_sc_obj( +// // arma::vec& grad, +// // const arma::mat& Qs, const arma::mat& Qm, +// // arma::mat& eta_pi, const arma::mat& X_pi, +// // arma::cube& eta_A, const arma::cube& X_A, +// // arma::cube& eta_B, const arma::cube& X_B, +// // const arma::umat& obs, const bool iv_pi, const bool iv_A, const bool iv_B, +// // const bool tv_A, const bool tv_B, const arma::uvec& Ti, +// // const arma::vec E_Pi, const arma::cube E_A, const arma::cube E_B) { +// // +// // arma::uword N = X_A.n_slices; +// // arma::uword T = X_A.n_cols; +// // arma::uword S = eta_A.n_slices; +// // arma::uword M = eta_B.n_rows + 1; +// // +// // arma::mat gamma_pi = eta_to_gamma(eta_pi, Qs); +// // arma::cube gamma_A = eta_to_gamma(eta_A, Qs); +// // arma::cube gamma_B = eta_to_gamma(eta_B, Qm); +// // arma::vec log_Pi(S); +// // arma::cube log_A(S, S, T); +// // arma::cube log_B(S, M, T); +// // arma::vec Pi(S); +// // arma::cube A(S, S, T); +// // arma::cube B(S, M, T); +// // double nll = 0; +// // for (arma::uword i = 0; i < N; i++) { +// // +// // if (iv_pi || i == 0) { +// // Pi = get_log_pi(gamma_pi, X_pi.col(i)); +// // log_Pi = arma::log(Pi); +// // } +// // if (iv_A || i == 0) { +// // A = get_A(gamma_A, X_A.slice(i), tv_A); +// // log_A = arma::log(A); +// // } +// // if (iv_B || i == 0) { +// // B = get_B(gamma_B, X_B.slice(i), tv_B, false); +// // log_B = arma::log(B); +// // } +// // for (arma::uword s = 0; s < S; ++s) { +// // double pi_s = arma::dot(gamma_pi.col(s), X_pi.row(s)); +// // nll -= E_Pi(s) * std::log(pi_s); +// // for (arma::uword j = 0; j < gamma_pi.n_rows; ++j) { +// // grad_pi(j, s) -= E_Pi(s) * (X_pi(j, s) - pi_s * gamma_pi(j, s)) / pi_s; +// // } +// // } +// // for (arma::uword s = 0; s < S; ++s) { +// // for (arma::uword s_next = 0; s_next < S; ++s_next) { +// // for (arma::uword t = 0; t < E_A.n_slices; ++t) { +// // double A_ss = arma::dot(gamma_A.slice(s).col(s_next), X_A.slice(t).row(s)); +// // nll -= E_A(s, s_next, t) * std::log(A_ss); +// // for (arma::uword j = 0; j < gamma_A.n_rows; ++j) { +// // grad_A(j, s, s_next) -= E_A(s, s_next, t) * (X_A(j, t) - A_ss * gamma_A(j, s)) / A_ss; +// // } +// // } +// // } +// // } +// // +// // // Emission Matrix Contribution to NLL and Gradients +// // for (arma::uword s = 0; s < S; ++s) { +// // for (arma::uword m = 0; m < M; ++m) { +// // for (arma::uword t = 0; t < E_B.n_slices; ++t) { +// // double B_sm = arma::dot(gamma_B.slice(s).col(m), X_B.slice(t).row(s)); +// // nll -= E_B(s, m, t) * std::log(B_sm); +// // for (arma::uword j = 0; j < gamma_B.n_rows; ++j) { +// // grad_B(j, s, m) -= E_B(s, m, t) * (X_B(j, t) - B_sm * gamma_B(j, s)) / B_sm; +// // } +// // } +// // } +// // } +// // +// // arma::uword N = X_A.n_slices; +// // arma::uword T = X_A.n_cols; +// // arma::uword S = eta_A.n_slices; +// // arma::uword M = eta_B.n_rows + 1; +// // arma::vec loglik(N); +// // arma::mat log_alpha(S, T); +// // arma::mat log_beta(S, T); +// // arma::mat log_py(S, T); +// // +// // arma::vec Pi(S); +// // arma::cube A(S, S, T); +// // arma::cube B(S, M + 1, T); +// // arma::vec log_Pi(S); +// // arma::cube log_A(S, S, T); +// // arma::cube log_B(S, M + 1, T); +// // +// // arma::mat grad_pi(S - 1, X_pi.n_rows, arma::fill::zeros); +// // arma::cube grad_A(S - 1, X_A.n_rows, S, arma::fill::zeros); +// // arma::cube grad_B(M - 1, X_B.n_rows, S, arma::fill::zeros); +// // +// // arma::mat gamma_pi = eta_to_gamma(eta_pi, Qs.t()); +// // arma::cube gamma_A = eta_to_gamma(eta_A, Qs.t()); +// // arma::cube gamma_B = eta_to_gamma(eta_B, Qm.t()); +// // for (arma::uword i = 0; i < N; i++) { +// // if (iv_pi || i == 0) { +// // Pi = get_pi(gamma_pi, X_pi.col(i)); +// // log_Pi = arma::log(Pi); +// // } +// // if (iv_A || i == 0) { +// // A = get_A(gamma_A, X_A.slice(i), tv_A); +// // log_A = arma::log(A); +// // } +// // if (iv_B || i == 0) { +// // B = get_B(gamma_B, X_B.slice(i), true, tv_B); +// // log_B = arma::log(B); +// // } +// // for (arma::uword t = 0; t < Ti(i); t++) { +// // log_py.col(t) = log_B.slice(t).col(obs(t, i)); +// // } +// // log_alpha = univariate_forward_nhmm(log_Pi, log_A, log_py); +// // log_beta = univariate_backward_nhmm(log_A, log_py); +// // double ll = logSumExp(log_alpha.col(T - 1)); +// // if (!std::isfinite(ll)) { +// // grad.fill(arma::datum::inf); +// // return arma::datum::inf; +// // } +// // loglik(i) = ll; +// // // gradient wrt gamma_pi +// // grad_pi += gradient_wrt_pi(Qs, log_py, log_beta, ll, Pi, X_pi, i); +// // // gradient wrt gamma_A +// // for (arma::uword t = 0; t < (Ti(i) - 1); t++) { +// // for (arma::uword s = 0; s < S; s++) { +// // grad_A.slice(s) += gradient_wrt_A(Qs, log_py, log_alpha, log_beta, ll, A, X_A, i, t, s); +// // } +// // } +// // // gradient wrt gamma_B +// // for (arma::uword s = 0; s < S; s++) { +// // if (obs(0, i) < M) { +// // grad_B.slice(s) += gradient_wrt_B_t0(Qm, obs, log_Pi, log_beta, ll, B, X_B, i, s); +// // } +// // for (arma::uword t = 0; t < (Ti(i) - 1); t++) { +// // if (obs(t + 1, i) < M) { +// // grad_B.slice(s) += gradient_wrt_B(Qm, obs, log_alpha, log_beta, ll, log_A, B, X_B, i, s, t); +// // } +// // } +// // } +// // } +// // size_t n_pi = (S - 1) * X_pi.n_rows; +// // size_t n_A = (S - 1) * X_A.n_rows * S; +// // size_t n_B = (M - 1) * X_B.n_rows * S; +// // size_t idx = 0; +// // grad.subvec(idx, n_pi - 1) = -arma::vectorise(grad_pi); +// // idx += n_pi; +// // grad.subvec(idx, idx + n_A - 1) = -arma::vectorise(grad_A); +// // idx += n_A; +// // grad.subvec(idx, idx + n_B - 1) = -arma::vectorise(grad_B); +// // return -sum(loglik); +// // } diff --git a/src/nhmm_sc.h b/src/nhmm_sc.h new file mode 100644 index 00000000..0a726685 --- /dev/null +++ b/src/nhmm_sc.h @@ -0,0 +1,77 @@ +#ifndef NHMM_SC_H +#define NHMM_SC_H + +#include +#include "create_Q.h" +#include "eta_to_gamma.h" +#include "softmax.h" +#include "nhmm_base.h" + +struct nhmm_sc : public nhmm_base { + + const arma::umat& obs; + arma::cube eta_B; + const arma::uword M; + arma::mat Qm; + arma::cube gamma_B; + // these store Pi, A, B, and log_p(y) of _one_ id we are currently working with + arma::cube B; + arma::cube log_B; + + nhmm_sc( + const arma::uword S_, + const arma::mat& X_pi_, + const arma::cube& X_s_, + const arma::cube& X_o_, + const arma::uvec& Ti_, + const bool iv_pi_, + const bool iv_A_, + const bool iv_B_, + const bool tv_A_, + const bool tv_B_, + const arma::umat& obs_, + arma::mat& eta_pi_, + arma::cube& eta_A_, + arma::cube& eta_B_) + : nhmm_base(S_, X_pi_, X_s_, X_o_, Ti_, iv_pi_, iv_A_, iv_B_, tv_A_, tv_B_, eta_pi_, eta_A_), + obs(obs_), + eta_B(eta_B_), + M(eta_B_.n_rows + 1), + Qm(create_Q(M)), + gamma_B(eta_to_gamma(eta_B, Qm)), + B(S, M + 1, T), + log_B(S, M + 1, T) {} + + void update_B(const arma::uword i) { + arma::mat Btmp(M + 1, S, arma::fill::ones); + if (tv_B) { + for (arma::uword t = 0; t < Ti(i); t++) { // time + for (arma::uword s = 0; s < S; s++) { // from states + Btmp.col(s).rows(0, M - 1) = softmax(gamma_B.slice(s) * X_B.slice(i).col(t)); + } + B.slice(t) = Btmp.t(); + } + } else { + for (arma::uword s = 0; s < S; s++) { // from states + Btmp.col(s).rows(0, M - 1) = softmax( + gamma_B.slice(s) * X_B.slice(i).col(0) + ); + } + B.each_slice() = Btmp.t(); + } + log_B = arma::log(B); + } + + void update_probs(const arma::uword i) { + update_pi(i); + update_A(i); + update_B(i); + } + + void update_log_py(const arma::uword i) { + for (arma::uword t = 0; t < Ti(i); t++) { + log_py.col(t) = log_B.slice(t).col(obs(t, i)); + } + } +}; +#endif diff --git a/src/simulate_nhmm.cpp b/src/nhmm_simulate.cpp similarity index 62% rename from src/simulate_nhmm.cpp rename to src/nhmm_simulate.cpp index 70429852..b387ba71 100644 --- a/src/simulate_nhmm.cpp +++ b/src/nhmm_simulate.cpp @@ -5,13 +5,13 @@ // [[Rcpp::export]] Rcpp::List simulate_nhmm_singlechannel( - const arma::mat& eta_pi, const arma::mat& X_i, - const arma::cube& eta_A, const arma::cube& X_s, - const arma::cube& eta_B, const arma::cube& X_o) { - unsigned int N = X_s.n_slices; - unsigned int T = X_s.n_cols; - unsigned int S = eta_A.n_slices; - unsigned int M = eta_B.n_rows + 1; + const arma::mat& eta_pi, const arma::mat& X_pi, + const arma::cube& eta_A, const arma::cube& X_A, + const arma::cube& eta_B, const arma::cube& X_B) { + arma::uword N = X_A.n_slices; + arma::uword T = X_A.n_cols; + arma::uword S = eta_A.n_slices; + arma::uword M = eta_B.n_rows + 1; arma::ucube y(1, T, N); arma::umat z(T, N); arma::mat gamma_pi = eta_to_gamma(eta_pi); @@ -22,13 +22,13 @@ Rcpp::List simulate_nhmm_singlechannel( arma::cube B(S, M, T); arma::uvec seqS = arma::linspace(0, S - 1, S); arma::uvec seqM = arma::linspace(0, M - 1, M); - for (unsigned int i = 0; i < N; i++) { - Pi = get_pi(gamma_pi, X_i.col(i)); - A = get_A(gamma_A, X_s.slice(i)); - B = get_B(gamma_B, X_o.slice(i)); + for (arma::uword i = 0; i < N; i++) { + Pi = get_pi(gamma_pi, X_pi.col(i)); + A = get_A(gamma_A, X_A.slice(i)); + B = get_B(gamma_B, X_B.slice(i)); z(0, i) = arma::as_scalar(Rcpp::RcppArmadillo::sample(seqS, 1, false, Pi)); y(0, 0, i) = arma::as_scalar(Rcpp::RcppArmadillo::sample(seqM, 1, false, B.slice(0).row(z(0, i)).t())); - for (unsigned int t = 1; t < T; t++) { + for (arma::uword t = 1; t < T; t++) { z(t, i) = arma::as_scalar(Rcpp::RcppArmadillo::sample(seqS, 1, false, A.slice(t).row(z(t - 1, i)).t())); y(0, t, i) = arma::as_scalar(Rcpp::RcppArmadillo::sample(seqM, 1, false, B.slice(t).row(z(t, i)).t())); } @@ -40,14 +40,14 @@ Rcpp::List simulate_nhmm_singlechannel( } // [[Rcpp::export]] Rcpp::List simulate_nhmm_multichannel( - const arma::mat& eta_pi, const arma::mat& X_i, - const arma::cube& eta_A, const arma::cube& X_s, - const arma::field& eta_B, const arma::cube& X_o, + const arma::mat& eta_pi, const arma::mat& X_pi, + const arma::cube& eta_A, const arma::cube& X_A, + const arma::field& eta_B, const arma::cube& X_B, const arma::uvec& M) { - unsigned int N = X_s.n_slices; - unsigned int T = X_s.n_cols; - unsigned int S = eta_A.n_slices; - unsigned int C = M.n_elem; + arma::uword N = X_A.n_slices; + arma::uword T = X_A.n_cols; + arma::uword S = eta_A.n_slices; + arma::uword C = M.n_elem; arma::ucube y(C, T, N); arma::umat z(T, N); @@ -60,20 +60,20 @@ Rcpp::List simulate_nhmm_multichannel( arma::field B(C); arma::uvec seqS = arma::linspace(0, S - 1, S); arma::field seqM(C); - for (unsigned int c = 0; c < C; c++) { + for (arma::uword c = 0; c < C; c++) { seqM(c) = arma::linspace(0, M(c) - 1, M(c)); } - for (unsigned int i = 0; i < N; i++) { - Pi = get_pi(gamma_pi, X_i.col(i)); - A = get_A(gamma_A, X_s.slice(i)); - B = get_B(gamma_B, X_o.slice(i), M); + for (arma::uword i = 0; i < N; i++) { + Pi = get_pi(gamma_pi, X_pi.col(i)); + A = get_A(gamma_A, X_A.slice(i)); + B = get_B(gamma_B, X_B.slice(i), M); z(0, i) = arma::as_scalar(Rcpp::RcppArmadillo::sample(seqS, 1, false, Pi)); - for (unsigned int c = 0; c < C; c++) { + for (arma::uword c = 0; c < C; c++) { y(c, 0, i) = arma::as_scalar(Rcpp::RcppArmadillo::sample(seqM(c), 1, false, B(c).slice(0).row(z(0, i)).t())); } - for (unsigned int t = 1; t < T; t++) { + for (arma::uword t = 1; t < T; t++) { z(t, i) = arma::as_scalar(Rcpp::RcppArmadillo::sample(seqS, 1, false, A.slice(t).row(z(t - 1, i)).t())); - for (unsigned int c = 0; c < C; c++) { + for (arma::uword c = 0; c < C; c++) { y(c, t, i) = arma::as_scalar(Rcpp::RcppArmadillo::sample(seqM(c), 1, false, B(c).slice(t).row(z(t, i)).t())); } } @@ -86,15 +86,15 @@ Rcpp::List simulate_nhmm_multichannel( // [[Rcpp::export]] Rcpp::List simulate_mnhmm_singlechannel( - const arma::field& eta_pi, const arma::mat& X_i, - const arma::field& eta_A, const arma::cube& X_s, - const arma::field& eta_B, const arma::cube& X_o, - const arma::mat& eta_omega, const arma::mat& X_d) { - unsigned int N = X_s.n_slices; - unsigned int T = X_s.n_cols; - unsigned int S = eta_A.n_slices; - unsigned int M = eta_B.n_rows + 1; - unsigned int D = eta_omega.n_rows + 1; + const arma::field& eta_pi, const arma::mat& X_pi, + const arma::field& eta_A, const arma::cube& X_A, + const arma::field& eta_B, const arma::cube& X_B, + const arma::mat& eta_omega, const arma::mat& X_omega) { + arma::uword N = X_A.n_slices; + arma::uword T = X_A.n_cols; + arma::uword S = eta_A.n_slices; + arma::uword M = eta_B.n_rows + 1; + arma::uword D = eta_omega.n_rows + 1; arma::ucube y(1, T, N); arma::umat z(T, N); @@ -109,15 +109,15 @@ Rcpp::List simulate_mnhmm_singlechannel( arma::uvec seqS = arma::linspace(0, S - 1, S); arma::uvec seqM = arma::linspace(0, M - 1, M); arma::uvec seqD = arma::linspace(0, D - 1, D); - for (unsigned int i = 0; i < N; i++) { - omega = get_omega(gamma_omega, X_d.col(i)); - unsigned int cluster = arma::as_scalar(Rcpp::RcppArmadillo::sample(seqD, 1, false, omega)); - Pi = get_pi(gamma_pi(cluster), X_i.col(i)); - A = get_A(gamma_A(cluster), X_s.slice(i)); - B = get_B(gamma_B(cluster), X_o.slice(i)); + for (arma::uword i = 0; i < N; i++) { + omega = get_omega(gamma_omega, X_omega.col(i)); + arma::uword cluster = arma::as_scalar(Rcpp::RcppArmadillo::sample(seqD, 1, false, omega)); + Pi = get_pi(gamma_pi(cluster), X_pi.col(i)); + A = get_A(gamma_A(cluster), X_A.slice(i)); + B = get_B(gamma_B(cluster), X_B.slice(i)); z(0, i) = arma::as_scalar(Rcpp::RcppArmadillo::sample(seqS, 1, false, Pi)); y(0, 0, i) = arma::as_scalar(Rcpp::RcppArmadillo::sample(seqM, 1, false, B.slice(0).row(z(0, i)).t())); - for (unsigned int t = 1; t < T; t++) { + for (arma::uword t = 1; t < T; t++) { z(t, i) = arma::as_scalar(Rcpp::RcppArmadillo::sample(seqS, 1, false, A.slice(t).row(z(t - 1, i)).t())); y(0, t, i) = arma::as_scalar(Rcpp::RcppArmadillo::sample(seqM, 1, false, B.slice(t).row(z(t, i)).t())); } @@ -132,16 +132,16 @@ Rcpp::List simulate_mnhmm_singlechannel( // [[Rcpp::export]] Rcpp::List simulate_mnhmm_multichannel( - const arma::field& eta_pi, const arma::mat& X_i, - const arma::field& eta_A, const arma::cube& X_s, - const arma::field& eta_B, const arma::cube& X_o, - const arma::mat& eta_omega, const arma::mat& X_d, + const arma::field& eta_pi, const arma::mat& X_pi, + const arma::field& eta_A, const arma::cube& X_A, + const arma::field& eta_B, const arma::cube& X_B, + const arma::mat& eta_omega, const arma::mat& X_omega, const arma::uvec& M) { - unsigned int N = X_s.n_slices; - unsigned int T = X_s.n_cols; - unsigned int S = eta_A(0).n_slices; - unsigned int D = eta_omega.n_rows + 1; - unsigned int C = M.n_elem; + arma::uword N = X_A.n_slices; + arma::uword T = X_A.n_cols; + arma::uword S = eta_A(0).n_slices; + arma::uword D = eta_omega.n_rows + 1; + arma::uword C = M.n_elem; arma::ucube y(C, T, N); arma::umat z(T, N); arma::mat gamma_omega = eta_to_gamma(eta_omega); @@ -153,24 +153,24 @@ Rcpp::List simulate_mnhmm_multichannel( arma::cube A(S, S, T); arma::field B(C); arma::field seqM(C); - for (unsigned int c = 0; c < C; c++) { + for (arma::uword c = 0; c < C; c++) { seqM(c) = arma::linspace(0, M(c) - 1, M(c)); } arma::uvec seqS = arma::linspace(0, S - 1, S); arma::uvec seqD = arma::linspace(0, D - 1, D); - for (unsigned int i = 0; i < N; i++) { - omega = get_omega(gamma_omega, X_d.col(i)); - unsigned int cluster = arma::as_scalar(Rcpp::RcppArmadillo::sample(seqD, 1, false, omega)); - Pi = get_pi(gamma_pi(cluster), X_i.col(i)); - A = get_A(gamma_A(cluster), X_s.slice(i)); - B = get_B(gamma_B.rows(cluster * C, (cluster + 1) * C - 1), X_o.slice(i), M); + for (arma::uword i = 0; i < N; i++) { + omega = get_omega(gamma_omega, X_omega.col(i)); + arma::uword cluster = arma::as_scalar(Rcpp::RcppArmadillo::sample(seqD, 1, false, omega)); + Pi = get_pi(gamma_pi(cluster), X_pi.col(i)); + A = get_A(gamma_A(cluster), X_A.slice(i)); + B = get_B(gamma_B.rows(cluster * C, (cluster + 1) * C - 1), X_B.slice(i), M); z(0, i) = arma::as_scalar(Rcpp::RcppArmadillo::sample(seqS, 1, false, Pi)); - for (unsigned int c = 0; c < C; c++) { + for (arma::uword c = 0; c < C; c++) { y(c, 0, i) = arma::as_scalar(Rcpp::RcppArmadillo::sample(seqM(c), 1, false, B(c).slice(0).row(z(0, i)).t())); } - for (unsigned int t = 1; t < T; t++) { + for (arma::uword t = 1; t < T; t++) { z(t, i) = arma::as_scalar(Rcpp::RcppArmadillo::sample(seqS, 1, false, A.slice(t).row(z(t - 1, i)).t())); - for (unsigned int c = 0; c < C; c++) { + for (arma::uword c = 0; c < C; c++) { y(c, t, i) = arma::as_scalar(Rcpp::RcppArmadillo::sample(seqM(c), 1, false, B(c).slice(t).row(z(t, i)).t())); } } @@ -180,4 +180,4 @@ Rcpp::List simulate_mnhmm_multichannel( Rcpp::Named("observations") = Rcpp::wrap(y), Rcpp::Named("states") = Rcpp::wrap(z) ); -} \ No newline at end of file +} diff --git a/src/nhmm_viterbi.cpp b/src/nhmm_viterbi.cpp new file mode 100644 index 00000000..fbddfc65 --- /dev/null +++ b/src/nhmm_viterbi.cpp @@ -0,0 +1,93 @@ +// Viterbi algorithm for NHMMs +#include "nhmm_viterbi.h" +#include "nhmm_sc.h" +#include "nhmm_mc.h" +#include "mnhmm_sc.h" +#include "mnhmm_mc.h" + +// [[Rcpp::export]] +Rcpp::List viterbi_nhmm_singlechannel( + arma::mat& eta_pi, const arma::mat& X_pi, + arma::cube& eta_A, const arma::cube& X_A, + arma::cube& eta_B, const arma::cube& X_B, + const arma::umat& obs, const arma::uvec Ti, + const bool iv_pi, const bool iv_A, const bool iv_B, + const bool tv_A, const bool tv_B) { + + nhmm_sc model( + eta_A.n_slices, X_pi, X_A, X_B, Ti, + iv_pi, iv_A, iv_B, tv_A, tv_B, obs, eta_pi, eta_A, eta_B + ); + arma::umat q(model.T, model.N, arma::fill::value(arma::datum::nan)); + arma::vec logp(model.N); + viterbi_nhmm(model, q, logp); + return Rcpp::List::create( + Rcpp::Named("q") = Rcpp::wrap(q), + Rcpp::Named("logp") = Rcpp::wrap(logp) + ); +} +// [[Rcpp::export]] +Rcpp::List viterbi_nhmm_multichannel( + arma::mat& eta_pi, const arma::mat& X_pi, + arma::cube& eta_A, const arma::cube& X_A, + arma::field& eta_B, const arma::cube& X_B, + const arma::ucube& obs, const arma::uvec Ti, + const bool iv_pi, const bool iv_A, const bool iv_B, + const bool tv_A, const bool tv_B) { + + nhmm_mc model( + eta_A.n_slices, X_pi, X_A, X_B, Ti, + iv_pi, iv_A, iv_B, tv_A, tv_B, obs, eta_pi, eta_A, eta_B + ); + arma::umat q(model.T, model.N, arma::fill::value(arma::datum::nan)); + arma::vec logp(model.N); + viterbi_nhmm(model, q, logp); + return Rcpp::List::create( + Rcpp::Named("q") = Rcpp::wrap(q), + Rcpp::Named("logp") = Rcpp::wrap(logp) + ); +} +// [[Rcpp::export]] +Rcpp::List viterbi_mnhmm_singlechannel( + arma::mat& eta_omega, const arma::mat& X_omega, + arma::field& eta_pi, const arma::mat& X_pi, + arma::field& eta_A, const arma::cube& X_A, + arma::field& eta_B, const arma::cube& X_B, + const arma::umat& obs, const arma::uvec Ti, + const bool iv_omega, const bool iv_pi, const bool iv_A, const bool iv_B, + const bool tv_A, const bool tv_B) { + + mnhmm_sc model( + eta_A(0).n_slices, eta_A.n_rows, X_omega, X_pi, X_A, X_B, Ti, iv_omega, + iv_pi, iv_A, iv_B, tv_A, tv_B, obs, eta_omega, eta_pi, eta_A, eta_B + ); + arma::umat q(model.T, model.N, arma::fill::value(arma::datum::nan)); + arma::vec logp(model.N); + viterbi_mnhmm(model, q, logp); + return Rcpp::List::create( + Rcpp::Named("q") = Rcpp::wrap(q), + Rcpp::Named("logp") = Rcpp::wrap(logp) + ); +} +// [[Rcpp::export]] +Rcpp::List viterbi_mnhmm_multichannel( + arma::mat& eta_omega, const arma::mat& X_omega, + arma::field& eta_pi, const arma::mat& X_pi, + arma::field& eta_A, const arma::cube& X_A, + arma::field& eta_B, const arma::cube& X_B, + const arma::ucube& obs, const arma::uvec Ti, + const bool iv_omega, const bool iv_pi, const bool iv_A, const bool iv_B, + const bool tv_A, const bool tv_B) { + + mnhmm_mc model( + eta_A(0).n_slices, eta_A.n_rows, X_omega, X_pi, X_A, X_B, Ti, iv_omega, + iv_pi, iv_A, iv_B, tv_A, tv_B, obs, eta_omega, eta_pi, eta_A, eta_B + ); + arma::umat q(model.T, model.N, arma::fill::value(arma::datum::nan)); + arma::vec logp(model.N); + viterbi_mnhmm(model, q, logp); + return Rcpp::List::create( + Rcpp::Named("q") = Rcpp::wrap(q), + Rcpp::Named("logp") = Rcpp::wrap(logp) + ); +} diff --git a/src/nhmm_viterbi.h b/src/nhmm_viterbi.h new file mode 100644 index 00000000..3d1267b9 --- /dev/null +++ b/src/nhmm_viterbi.h @@ -0,0 +1,72 @@ +//Viterbi algorithm for NHMM and MHMM, single_sequence +#ifndef VITERBI_NHMM_H +#define VITERBI_NHMM_H + +#include + +template +double univariate_viterbi_nhmm( + subcol& q, + const arma::vec& log_pi, + const arma::cube& log_A, + const arma::mat& log_py) { + + arma::uword S = log_py.n_rows; + arma::uword T = log_py.n_cols; + + arma::mat delta(S, T); + arma::umat phi(S, T); + delta.col(0) = log_pi + log_py.col(0); + phi.col(0).zeros(); + for (arma::uword t = 1; t < T; t++) { + for (arma::uword j = 0; j < S; j++) { + phi(j, t) = (delta.col(t - 1) + log_A.slice(t).col(j)).index_max(); + delta(j, t) = delta(phi(j, t), t - 1) + log_A(phi(j, t), j, t) + log_py(j, t); + } + } + q(T - 1) = delta.col(T - 1).index_max(); + for (int t = (T - 2); t >= 0; t--) { + q(t) = phi(q(t + 1), t + 1); + } + return delta.col(T - 1).max(); +} + +template +void viterbi_nhmm(Model& model, arma::umat& q, arma::vec& logp) { + for (arma::uword i = 0; i < model.N; i++) { + model.update_probs(i); + model.update_log_py(i); + arma::subview_col subcol = q.col(i); + logp(i) = univariate_viterbi_nhmm( + subcol, + model.log_Pi, + model.log_A.slices(0, model.Ti(i) - 1), + model.log_py.cols(0, model.Ti(i) - 1) + ); + } +} +template +void viterbi_mnhmm(Model& model, arma::umat& q, arma::vec& logp) { + logp.fill(-arma::datum::inf); + double logp_d; + arma::uvec q_d(q.n_rows); + for (arma::uword i = 0; i < model.N; i++) { + model.update_omega(i); + model.update_probs(i); + model.update_log_py(i); + for (arma::uword d = 0; d < model.D; d++) { + logp_d = univariate_viterbi_nhmm( + q_d, + model.omega(d) + model.log_Pi(d), + model.log_A(d).slices(0, model.Ti(i) - 1), + model.log_py.slice(d).cols(0, model.Ti(i) - 1) + ); + if (logp_d > logp(i)) { + logp(i) = logp_d; + q.col(i) = q_d; + } + } + } +} + +#endif diff --git a/src/objective.cpp b/src/objective.cpp index 1ab6920f..6e4c80ee 100644 --- a/src/objective.cpp +++ b/src/objective.cpp @@ -6,15 +6,15 @@ // [[Rcpp::export]] Rcpp::List objective(const arma::mat& transition, const arma::cube& emission, const arma::vec& init, arma::ucube& obs, const arma::umat& ANZ, - const arma::ucube& BNZ, const arma::uvec& INZ, const arma::uvec& nSymbols, unsigned int threads) { + const arma::ucube& BNZ, const arma::uvec& INZ, const arma::uvec& nSymbols, arma::uword threads) { arma::vec grad(arma::accu(ANZ) + arma::accu(BNZ) + arma::accu(INZ), arma::fill::zeros); - unsigned int error = 0; + arma::uword error = 0; double ll = 0; #pragma omp parallel for if(obs.n_slices >= threads) schedule(static) reduction(+:ll) num_threads(threads) \ default(shared) //shared(grad, nSymbols, ANZ, BNZ, INZ, obs, init, transition, emission, error, arma::fill::zeros) - for (unsigned int k = 0; k < obs.n_slices; k++) { + for (arma::uword k = 0; k < obs.n_slices; k++) { if (error == 0) { arma::mat alpha(emission.n_rows, obs.n_cols); //m,n arma::vec scales(obs.n_cols); //n @@ -29,7 +29,7 @@ Rcpp::List objective(const arma::mat& transition, const arma::cube& emission, arma::vec gradArow(emission.n_rows); arma::mat gradA(emission.n_rows, emission.n_rows); - for (unsigned int i = 0; i < emission.n_rows; i++) { + for (arma::uword i = 0; i < emission.n_rows; i++) { arma::uvec ind = arma::find(ANZ.row(i)); if (ind.n_elem > 0) { @@ -38,10 +38,10 @@ Rcpp::List objective(const arma::mat& transition, const arma::cube& emission, gradA.each_row() -= transition.row(i); gradA.each_col() %= transition.row(i).t(); - for (unsigned int t = 0; t < (obs.n_cols - 1); t++) { - for (unsigned int j = 0; j < emission.n_rows; j++) { + for (arma::uword t = 0; t < (obs.n_cols - 1); t++) { + for (arma::uword j = 0; j < emission.n_rows; j++) { double tmp = 1.0; - for (unsigned int r = 0; r < obs.n_rows; r++) { + for (arma::uword r = 0; r < obs.n_rows; r++) { tmp *= emission(j, obs(r, t + 1, k), r); } gradArow(j) += alpha(i, t) * tmp * beta(j, t + 1); @@ -55,30 +55,30 @@ Rcpp::List objective(const arma::mat& transition, const arma::cube& emission, } } // emissionMatrix - for (unsigned int r = 0; r < obs.n_rows; r++) { + for (arma::uword r = 0; r < obs.n_rows; r++) { arma::vec gradBrow(nSymbols(r)); arma::mat gradB(nSymbols(r), nSymbols(r)); - for (unsigned int i = 0; i < emission.n_rows; i++) { + for (arma::uword i = 0; i < emission.n_rows; i++) { arma::uvec ind = arma::find(BNZ.slice(r).row(i)); if (ind.n_elem > 0) { gradBrow.zeros(); gradB.eye(); gradB.each_row() -= emission.slice(r).row(i).subvec(0, nSymbols(r) - 1); gradB.each_col() %= emission.slice(r).row(i).subvec(0, nSymbols(r) - 1).t(); - for (unsigned int j = 0; j < nSymbols(r); j++) { + for (arma::uword j = 0; j < nSymbols(r); j++) { if (obs(r, 0, k) == j) { double tmp = 1.0; - for (unsigned int r2 = 0; r2 < obs.n_rows; r2++) { + for (arma::uword r2 = 0; r2 < obs.n_rows; r2++) { if (r2 != r) { tmp *= emission(i, obs(r2, 0, k), r2); } } gradBrow(j) += init(i) * tmp * beta(i, 0); } - for (unsigned int t = 0; t < (obs.n_cols - 1); t++) { + for (arma::uword t = 0; t < (obs.n_cols - 1); t++) { if (obs(r, t + 1, k) == j) { double tmp = 1.0; - for (unsigned int r2 = 0; r2 < obs.n_rows; r2++) { + for (arma::uword r2 = 0; r2 < obs.n_rows; r2++) { if (r2 != r) { tmp *= emission(i, obs(r2, t + 1, k), r2); } @@ -107,9 +107,9 @@ Rcpp::List objective(const arma::mat& transition, const arma::cube& emission, gradI.eye(); gradI.each_row() -= init.t(); gradI.each_col() %= init; - for (unsigned int j = 0; j < emission.n_rows; j++) { + for (arma::uword j = 0; j < emission.n_rows; j++) { double tmp = 1.0; - for (unsigned int r = 0; r < obs.n_rows; r++) { + for (arma::uword r = 0; r < obs.n_rows; r++) { tmp *= emission(j, obs(r, 0, k), r); } gradIrow(j) += tmp * beta(j, 0); @@ -128,7 +128,7 @@ Rcpp::List objective(const arma::mat& transition, const arma::cube& emission, grad += grad_k; // gradmat.col(k) = grad_k; } -// for (unsigned int ii = 0; ii < grad_k.n_elem; ii++) { +// for (arma::uword ii = 0; ii < grad_k.n_elem; ii++) { // #pragma omp atomic // grad(ii) += grad_k(ii); // } diff --git a/src/objectivex.cpp b/src/objectivex.cpp index 65b91118..1ab907f3 100644 --- a/src/objectivex.cpp +++ b/src/objectivex.cpp @@ -9,9 +9,9 @@ Rcpp::List objectivex(const arma::mat& transition, const arma::cube& emission, const arma::vec& init, const arma::ucube& obs, const arma::umat& ANZ, const arma::ucube& BNZ, const arma::uvec& INZ, const arma::uvec& nSymbols, const arma::mat& coef, const arma::mat& X, arma::uvec& numberOfStates, - unsigned int threads) { + arma::uword threads) { - unsigned int q = coef.n_rows; + arma::uword q = coef.n_rows; arma::vec grad( arma::accu(ANZ) + arma::accu(BNZ) + arma::accu(INZ) + (numberOfStates.n_elem- 1) * q, arma::fill::zeros); @@ -25,16 +25,16 @@ Rcpp::List objectivex(const arma::mat& transition, const arma::cube& emission, arma::mat initk(emission.n_rows, obs.n_slices); - for (unsigned int k = 0; k < obs.n_slices; k++) { + for (arma::uword k = 0; k < obs.n_slices; k++) { initk.col(k) = init % reparma(weights.col(k), numberOfStates); } arma::uvec cumsumstate = arma::cumsum(numberOfStates); - unsigned int error = 0; + arma::uword error = 0; double ll = 0; #pragma omp parallel for if(obs.n_slices >= threads) schedule(static) reduction(+:ll) num_threads(threads) default(shared) - for (unsigned int k = 0; k < obs.n_slices; k++) { + for (arma::uword k = 0; k < obs.n_slices; k++) { if (error == 0) { arma::mat alpha(emission.n_rows, obs.n_cols); //m,n arma::vec scales(obs.n_cols); //n @@ -48,12 +48,12 @@ Rcpp::List objectivex(const arma::mat& transition, const arma::cube& emission, // transitionMatrix if (arma::accu(ANZ) > 0) { - for (unsigned int jj = 0; jj < numberOfStates.n_elem; jj++) { + for (arma::uword jj = 0; jj < numberOfStates.n_elem; jj++) { arma::vec gradArow(numberOfStates(jj)); arma::mat gradA(numberOfStates(jj), numberOfStates(jj)); int ind_jj = cumsumstate(jj) - numberOfStates(jj); - for (unsigned int i = 0; i < numberOfStates(jj); i++) { + for (arma::uword i = 0; i < numberOfStates(jj); i++) { arma::uvec ind = arma::find(ANZ.row(ind_jj + i).subvec(ind_jj, cumsumstate(jj) - 1)); if (ind.n_elem > 0) { @@ -63,10 +63,10 @@ Rcpp::List objectivex(const arma::mat& transition, const arma::cube& emission, gradA.each_col() %= transition.row(ind_jj + i).subvec(ind_jj, cumsumstate(jj) - 1).t(); - for (unsigned int j = 0; j < numberOfStates(jj); j++) { - for (unsigned int t = 0; t < (obs.n_cols - 1); t++) { + for (arma::uword j = 0; j < numberOfStates(jj); j++) { + for (arma::uword t = 0; t < (obs.n_cols - 1); t++) { double tmp = alpha(ind_jj + i, t); - for (unsigned int r = 0; r < obs.n_rows; r++) { + for (arma::uword r = 0; r < obs.n_rows; r++) { tmp *= emission(ind_jj + j, obs(r, t + 1, k), r); } gradArow(j) += tmp * beta(ind_jj + j, t + 1); @@ -83,30 +83,30 @@ Rcpp::List objectivex(const arma::mat& transition, const arma::cube& emission, } if (arma::accu(BNZ) > 0) { // emissionMatrix - for (unsigned int r = 0; r < obs.n_rows; r++) { + for (arma::uword r = 0; r < obs.n_rows; r++) { arma::vec gradBrow(nSymbols(r)); arma::mat gradB(nSymbols(r), nSymbols(r)); - for (unsigned int i = 0; i < emission.n_rows; i++) { + for (arma::uword i = 0; i < emission.n_rows; i++) { arma::uvec ind = arma::find(BNZ.slice(r).row(i)); if (ind.n_elem > 0) { gradBrow.zeros(); gradB.eye(); gradB.each_row() -= emission.slice(r).row(i).subvec(0, nSymbols(r) - 1); gradB.each_col() %= emission.slice(r).row(i).subvec(0, nSymbols(r) - 1).t(); - for (unsigned int j = 0; j < nSymbols(r); j++) { + for (arma::uword j = 0; j < nSymbols(r); j++) { if (obs(r, 0, k) == j) { double tmp = initk(i, k); - for (unsigned int r2 = 0; r2 < obs.n_rows; r2++) { + for (arma::uword r2 = 0; r2 < obs.n_rows; r2++) { if (r2 != r) { tmp *= emission(i, obs(r2, 0, k), r2); } } gradBrow(j) += tmp * beta(i, 0); } - for (unsigned int t = 0; t < (obs.n_cols - 1); t++) { + for (arma::uword t = 0; t < (obs.n_cols - 1); t++) { if (obs(r, t + 1, k) == j) { double tmp = beta(i, t + 1); - for (unsigned int r2 = 0; r2 < obs.n_rows; r2++) { + for (arma::uword r2 = 0; r2 < obs.n_rows; r2++) { if (r2 != r) { tmp *= emission(i, obs(r2, t + 1, k), r2); } @@ -125,15 +125,15 @@ Rcpp::List objectivex(const arma::mat& transition, const arma::cube& emission, } } if (arma::accu(INZ) > 0) { - for (unsigned int i = 0; i < numberOfStates.n_elem; i++) { + for (arma::uword i = 0; i < numberOfStates.n_elem; i++) { int ind_i = cumsumstate(i) - numberOfStates(i); arma::uvec ind = arma::find( INZ.subvec(ind_i, cumsumstate(i) - 1)); if (ind.n_elem > 0) { arma::vec gradIrow(numberOfStates(i), arma::fill::zeros); - for (unsigned int j = 0; j < numberOfStates(i); j++) { + for (arma::uword j = 0; j < numberOfStates(i); j++) { double tmp = weights(i, k); - for (unsigned int r = 0; r < obs.n_rows; r++) { + for (arma::uword r = 0; r < obs.n_rows; r++) { tmp *= emission(ind_i + j, obs(r, 0, k), r); } gradIrow(j) += tmp * beta(ind_i + j, 0); @@ -149,12 +149,12 @@ Rcpp::List objectivex(const arma::mat& transition, const arma::cube& emission, } } } - for (unsigned int jj = 1; jj < numberOfStates.n_elem; jj++) { - unsigned int ind_jj = (cumsumstate(jj) - numberOfStates(jj)); + for (arma::uword jj = 1; jj < numberOfStates.n_elem; jj++) { + arma::uword ind_jj = (cumsumstate(jj) - numberOfStates(jj)); - for (unsigned int j = 0; j < emission.n_rows; j++) { + for (arma::uword j = 0; j < emission.n_rows; j++) { double tmp = 1.0; - for (unsigned int r = 0; r < obs.n_rows; r++) { + for (arma::uword r = 0; r < obs.n_rows; r++) { tmp *= emission(j, obs(r, 0, k), r); } if ((j >= ind_jj) && (j < cumsumstate(jj))) { diff --git a/src/optCoef.cpp b/src/optCoef.cpp index 6cc7c960..7770c128 100644 --- a/src/optCoef.cpp +++ b/src/optCoef.cpp @@ -1,7 +1,7 @@ //Estimation of beta coefficients #include "optcoef.h" -unsigned int optCoef(arma::mat& weights, const arma::ucube& obs, const arma::cube& emission, +arma::uword optCoef(arma::mat& weights, const arma::ucube& obs, const arma::cube& emission, const arma::mat& bsi, arma::mat& coef, const arma::mat& X, const arma::uvec& cumsumstate, const arma::uvec& numberOfStates, int trace) { @@ -18,7 +18,7 @@ unsigned int optCoef(arma::mat& weights, const arma::ucube& obs, const arma::cub } arma::mat coefnew(coef.n_rows, coef.n_cols - 1); - for (unsigned int i = 0; i < (weights.n_rows - 1); i++) { + for (arma::uword i = 0; i < (weights.n_rows - 1); i++) { coefnew.col(i) = coef.col(i + 1) - tmpvec.subvec(i * X.n_cols, (i + 1) * X.n_cols - 1); } change = arma::accu(arma::abs(coef.submat(0, 1, coef.n_rows - 1, coef.n_cols - 1) - coefnew)) @@ -48,11 +48,11 @@ arma::vec gCoef(const arma::ucube& obs, const arma::mat& bsi, arma::vec grad(q * (weights.n_rows - 1), arma::fill::zeros); double tmp; - for (unsigned int k = 0; k < obs.n_slices; k++) { - for (unsigned int jj = 1; jj < numberOfStates.n_elem; jj++) { - for (unsigned int j = 0; j < emission.n_rows; j++) { + for (arma::uword k = 0; k < obs.n_slices; k++) { + for (arma::uword jj = 1; jj < numberOfStates.n_elem; jj++) { + for (arma::uword j = 0; j < emission.n_rows; j++) { tmp = 1.0; - for (unsigned int r = 0; r < obs.n_rows; r++) { + for (arma::uword r = 0; r < obs.n_rows; r++) { tmp *= emission(j, obs(r, 0, k), r); } if ((j >= (cumsumstate(jj) - numberOfStates(jj))) && (j < cumsumstate(jj))) { @@ -72,10 +72,10 @@ arma::mat hCoef(const arma::mat& weights, const arma::mat& X) { int p = X.n_cols; arma::mat hess(p * (weights.n_rows - 1), p * (weights.n_rows - 1), arma::fill::zeros); - for (unsigned int i = 0; i < X.n_rows; i++) { + for (arma::uword i = 0; i < X.n_rows; i++) { arma::mat XX = X.row(i).t() * X.row(i); - for (unsigned int j = 0; j < (weights.n_rows - 1); j++) { - for (unsigned int k = 0; k < (weights.n_rows - 1); k++) { + for (arma::uword j = 0; j < (weights.n_rows - 1); j++) { + for (arma::uword k = 0; k < (weights.n_rows - 1); k++) { if (j != k) { hess.submat(j * p, k * p, (j + 1) * p - 1, (k + 1) * p - 1) += XX * weights(j + 1, i) * weights(k + 1, i); diff --git a/src/optcoef.h b/src/optcoef.h index 8f6809a2..1a9172d4 100644 --- a/src/optcoef.h +++ b/src/optcoef.h @@ -3,7 +3,7 @@ #define ARMA_WARN_LEVEL 1 #include -unsigned int optCoef(arma::mat& weights, const arma::ucube& obs, const arma::cube& emission, +arma::uword optCoef(arma::mat& weights, const arma::ucube& obs, const arma::cube& emission, const arma::mat& bsi, arma::mat& coef, const arma::mat& X, const arma::uvec& cumsumstate, const arma::uvec& numberOfStates, int trace); @@ -15,7 +15,7 @@ arma::mat hCoef(const arma::mat& weights, const arma::mat& X); //log-space versions -unsigned int log_optCoef(arma::mat& weights, const arma::ucube& obs, const arma::cube& emission, const arma::mat& initk, +arma::uword log_optCoef(arma::mat& weights, const arma::ucube& obs, const arma::cube& emission, const arma::mat& initk, const arma::cube& beta, const arma::vec& ll, arma::mat& coef, const arma::mat& X, const arma::uvec& cumsumstate, const arma::uvec& numberOfStates, int trace); diff --git a/src/reparma.cpp b/src/reparma.cpp index 5f69923e..2cc617d4 100644 --- a/src/reparma.cpp +++ b/src/reparma.cpp @@ -4,7 +4,7 @@ arma::vec reparma(const arma::vec& x, const arma::uvec& y) { arma::vec res(sum(y)); int ind = 0; - for (unsigned int i = 0; i < y.n_elem; ++i) { + for (arma::uword i = 0; i < y.n_elem; ++i) { std::fill(res.begin() + ind, res.begin() + ind + y(i), x(i)); ind += y(i); } diff --git a/src/sum_to_zero.cpp b/src/sum_to_zero.cpp index d9adbd01..dfb095ef 100644 --- a/src/sum_to_zero.cpp +++ b/src/sum_to_zero.cpp @@ -2,7 +2,7 @@ arma::mat sum_to_zero(const arma::mat& x, const arma::mat& Q) { arma::mat y(x.n_rows + 1, x.n_cols); - for (unsigned int i = 0; i < x.n_cols; i++) { + for (arma::uword i = 0; i < x.n_cols; i++) { y.col(i) = Q * x.col(i); } return y; diff --git a/src/uv_forwardbackward.cpp b/src/uv_forwardbackward.cpp index 7faf442d..3696e57b 100644 --- a/src/uv_forwardbackward.cpp +++ b/src/uv_forwardbackward.cpp @@ -6,14 +6,14 @@ void uvForward(const arma::sp_mat& transition_t, const arma::cube& emission, con const arma::umat& obs, arma::mat& alpha, arma::vec& scales) { alpha.col(0) = init; - for (unsigned int r = 0; r < obs.n_rows; r++) { + for (arma::uword r = 0; r < obs.n_rows; r++) { alpha.col(0) %= emission.slice(r).col(obs(r, 0)); } scales(0) = 1.0 / sum(alpha.col(0)); alpha.col(0) *= scales(0); - for (unsigned int t = 1; t < obs.n_cols; t++) { + for (arma::uword t = 1; t < obs.n_cols; t++) { alpha.col(t) = transition_t * alpha.col(t - 1); - for (unsigned int r = 0; r < obs.n_rows; r++) { + for (arma::uword r = 0; r < obs.n_rows; r++) { alpha.col(t) %= emission.slice(r).col(obs(r, t)); } scales(t) = 1.0 / sum(alpha.col(t)); @@ -28,7 +28,7 @@ void uvBackward(const arma::sp_mat& transition, const arma::cube& emission, beta.col(obs.n_cols - 1).fill(scales(obs.n_cols - 1)); for (int t = obs.n_cols - 2; t >= 0; t--) { arma::vec tmpbeta = beta.col(t + 1); - for (unsigned int r = 0; r < obs.n_rows; r++) { + for (arma::uword r = 0; r < obs.n_rows; r++) { tmpbeta %= emission.slice(r).col(obs(r, t + 1)); } beta.col(t) = transition * tmpbeta * scales(t); diff --git a/src/viterbi.cpp b/src/viterbi.cpp index 8656286d..ce2aa916 100644 --- a/src/viterbi.cpp +++ b/src/viterbi.cpp @@ -9,17 +9,17 @@ Rcpp::List viterbi(const arma::mat& transition, const arma::cube& emission, arma::vec logp(obs.n_slices); arma::mat delta(emission.n_rows, obs.n_cols); arma::umat phi(emission.n_rows, obs.n_cols); - for (unsigned int k = 0; k < obs.n_slices; k++) { + for (arma::uword k = 0; k < obs.n_slices; k++) { delta.col(0) = init; - for (unsigned int r = 0; r < emission.n_slices; r++) { + for (arma::uword r = 0; r < emission.n_slices; r++) { delta.col(0) += emission.slice(r).col(obs(r, 0, k)); } phi.col(0).zeros(); - for (unsigned int t = 1; t < obs.n_cols; t++) { - for (unsigned int j = 0; j < emission.n_rows; j++) { + for (arma::uword t = 1; t < obs.n_cols; t++) { + for (arma::uword j = 0; j < emission.n_rows; j++) { phi(j, t) = (delta.col(t - 1) + transition.col(j)).index_max(); delta(j, t) = delta(phi(j, t), t - 1) + transition(phi(j, t), j); - for (unsigned int r = 0; r < emission.n_slices; r++) { + for (arma::uword r = 0; r < emission.n_slices; r++) { delta(j, t) += emission(j, obs(r, t, k), r); } } diff --git a/src/viterbi_nhmm.cpp b/src/viterbi_nhmm.cpp deleted file mode 100644 index f478ffc8..00000000 --- a/src/viterbi_nhmm.cpp +++ /dev/null @@ -1,200 +0,0 @@ -//Viterbi algorithm for NHMM and MHMM, single_sequence -#include "get_parameters.h" -#include "eta_to_gamma.h" -#include "viterbi_nhmm.h" - -double univariate_viterbi_nhmm( - const arma::vec& log_init, - const arma::cube& log_transition, - const arma::mat& log_py, - arma::subview_col q) { - - unsigned int S = log_py.n_rows; - unsigned int T = log_py.n_cols; - - arma::mat delta(S, T); - arma::umat phi(S, T); - delta.col(0) = log_init + log_py.col(0); - phi.col(0).zeros(); - for (unsigned int t = 1; t < T; t++) { - for (unsigned int j = 0; j < S; j++) { - phi(j, t) = (delta.col(t - 1) + log_transition.slice(t).col(j)).index_max(); - delta(j, t) = delta(phi(j, t), t - 1) + log_transition(phi(j, t), j, t) + log_py(j, t); - } - } - q(T - 1) = delta.col(T - 1).index_max(); - for (int t = (T - 2); t >= 0; t--) { - q(t) = phi(q(t + 1), t + 1); - } - return delta.col(T - 1).max(); -} -// [[Rcpp::export]] -Rcpp::List viterbi_nhmm_singlechannel( - const arma::mat& eta_pi, const arma::mat& X_i, - const arma::cube& eta_A, const arma::cube& X_s, - const arma::cube& eta_B, const arma::cube& X_o, - const arma::umat& obs) { - - unsigned int N = X_s.n_slices; - unsigned int T = X_s.n_cols; - unsigned int S = eta_A.n_slices; - unsigned int M = eta_B.n_rows + 1; - arma::umat q(T, N, arma::fill::zeros); - arma::vec logp(N); - arma::mat log_py(S, T); - arma::vec log_Pi(S); - arma::cube log_A(S, S, T); - arma::cube log_B(S, M + 1, T); - arma::mat gamma_pi = eta_to_gamma(eta_pi); - arma::cube gamma_A = eta_to_gamma(eta_A); - arma::cube gamma_B = eta_to_gamma(eta_B); - for (unsigned int i = 0; i < N; i++) { - log_Pi = get_log_pi(gamma_pi, X_i.col(i)); - log_A = get_log_A(gamma_A, X_s.slice(i)); - log_B = get_log_B(gamma_B, X_o.slice(i), true, true); - for (unsigned int t = 0; t < T; t++) { - log_py.col(t) = log_B.slice(t).col(obs(t, i)); - } - logp(i) = univariate_viterbi_nhmm(log_Pi, log_A, log_py, q.col(i)); - } - return Rcpp::List::create( - Rcpp::Named("q") = Rcpp::wrap(q), - Rcpp::Named("logp") = Rcpp::wrap(logp) - ); -} - -// [[Rcpp::export]] -Rcpp::List viterbi_nhmm_multichannel( - const arma::mat& eta_pi, const arma::mat& X_i, - const arma::cube& eta_A, const arma::cube& X_s, - const arma::field& eta_B, const arma::cube& X_o, - const arma::ucube& obs, const arma::uvec M) { - - unsigned int N = X_s.n_slices; - unsigned int T = X_s.n_cols; - unsigned int S = eta_A.n_slices; - unsigned int C = obs.n_rows; - arma::umat q(T, N, arma::fill::zeros); - arma::vec logp(N); - arma::mat log_py(S, T); - arma::vec log_Pi(S); - arma::cube log_A(S, S, T); - arma::field log_B(C); - arma::mat gamma_pi = eta_to_gamma(eta_pi); - arma::cube gamma_A = eta_to_gamma(eta_A); - arma::field gamma_B= eta_to_gamma(eta_B); - for (unsigned int i = 0; i < N; i++) { - log_py.zeros(); - log_Pi = get_log_pi(gamma_pi, X_i.col(i)); - log_A = get_log_A(gamma_A, X_s.slice(i)); - log_B = get_log_B(gamma_B, X_o.slice(i), M, true, true); - for (unsigned int t = 0; t < T; t++) { - for (unsigned int c = 0; c < C; c++) { - log_py.col(t) += log_B(c).slice(t).col(obs(c, t, i)); - } - } - logp(i) = univariate_viterbi_nhmm(log_Pi, log_A, log_py, q.col(i)); - } - - return Rcpp::List::create( - Rcpp::Named("q") = Rcpp::wrap(q), - Rcpp::Named("logp") = Rcpp::wrap(logp) - ); -} - -// [[Rcpp::export]] -Rcpp::List viterbi_mnhmm_singlechannel( - const arma::field& eta_pi, const arma::mat& X_i, - const arma::field& eta_A, const arma::cube& X_s, - const arma::field& eta_B, const arma::cube& X_o, - const arma::mat& eta_omega, const arma::mat& X_d, - const arma::umat& obs) { - - unsigned int N = X_s.n_slices; - unsigned int T = X_s.n_cols; - unsigned int S = eta_A(0).n_slices; - unsigned int D = eta_omega.n_rows + 1; - unsigned int SD = S * D; - unsigned int M = eta_B(0).n_rows + 1; - arma::umat q(T, N, arma::fill::zeros); - arma::vec logp(N); - arma::mat log_py(SD, T); - arma::vec log_Pi(SD); - arma::cube log_A(SD, SD, T, arma::fill::value(-arma::datum::inf)); - arma::cube log_B(SD, M + 1, T); - arma::vec log_omega(D); - arma::mat gamma_omega = eta_to_gamma(eta_omega); - arma::field gamma_pi = eta_to_gamma(eta_pi); - arma::field gamma_A = eta_to_gamma(eta_A); - arma::field gamma_B = eta_to_gamma(eta_B); - for (unsigned int i = 0; i < N; i++) { - log_omega = get_log_omega(gamma_omega, X_d.col(i)); - for (unsigned int d = 0; d < D; d++) { - log_Pi.rows(d * S, (d + 1) * S - 1) = log_omega(d) + - get_log_pi(gamma_pi(d), X_i.col(i)); - log_A.tube(d * S, d * S, (d + 1) * S - 1, (d + 1) * S - 1) = - get_log_A(gamma_A(d), X_s.slice(i)); - log_B.rows(d * S, (d + 1) * S - 1) = get_log_B( - gamma_B(d), X_o.slice(i), true, true - ); - } - for (unsigned int t = 0; t < T; t++) { - log_py.col(t) = log_B.slice(t).col(obs(t, i)); - } - logp(i) = univariate_viterbi_nhmm(log_Pi, log_A, log_py, q.col(i)); - } - return Rcpp::List::create( - Rcpp::Named("q") = Rcpp::wrap(q), - Rcpp::Named("logp") = Rcpp::wrap(logp) - ); -} -// [[Rcpp::export]] -Rcpp::List viterbi_mnhmm_multichannel( - const arma::field& eta_pi, const arma::mat& X_i, - const arma::field& eta_A, const arma::cube& X_s, - const arma::field& eta_B, const arma::cube& X_o, - const arma::mat& eta_omega, const arma::mat& X_d, - const arma::ucube& obs, const arma::uvec M) { - unsigned int N = X_s.n_slices; - unsigned int T = X_s.n_cols; - unsigned int S = eta_A(0).n_slices; - unsigned int D = eta_omega.n_rows + 1; - unsigned int SD = S * D; - unsigned int C = obs.n_rows; - arma::umat q(T, N, arma::fill::zeros); - arma::vec logp(N); - arma::mat log_py(SD, T); - arma::vec log_Pi(SD); - arma::cube log_A(SD, SD, T, arma::fill::value(-arma::datum::inf)); - arma::field log_B(C); - arma::vec log_omega(D); - arma::mat gamma_omega = eta_to_gamma(eta_omega); - arma::field gamma_pi = eta_to_gamma(eta_pi); - arma::field gamma_A = eta_to_gamma(eta_A); - arma::field gamma_B = eta_to_gamma(eta_B); - for (unsigned int i = 0; i < N; i++) { - log_omega = get_log_omega(gamma_omega, X_d.col(i)); - for (unsigned int d = 0; d < D; d++) { - log_Pi.rows(d * S, (d + 1) * S - 1) = log_omega(d) + - get_log_pi(gamma_pi(d), X_i.col(i)); - log_A.tube(d * S, d * S, (d + 1) * S - 1, (d + 1) * S - 1) = - get_log_A(gamma_A(d), X_s.slice(i)); - log_B = get_log_B( - gamma_B.rows(d * C, (d + 1) * C - 1), X_o.slice(i), M, true, true - ); - for (unsigned int t = 0; t < T; t++) { - for (unsigned int s = 0; s < S; s++) { - log_py(d * S + s, t) = 0; - for (unsigned int c = 0; c < C; c++) { - log_py(d * S + s, t) += log_B(c)(s, obs(c, t, i), t); - } - } - } - } - logp(i) = univariate_viterbi_nhmm(log_Pi, log_A, log_py, q.col(i)); - } - return Rcpp::List::create( - Rcpp::Named("q") = Rcpp::wrap(q), - Rcpp::Named("logp") = Rcpp::wrap(logp) - ); -} diff --git a/src/viterbi_nhmm.h b/src/viterbi_nhmm.h deleted file mode 100644 index d3336ebe..00000000 --- a/src/viterbi_nhmm.h +++ /dev/null @@ -1,12 +0,0 @@ -#ifndef VITERBI_NHMM_H -#define VITERBI_NHMM_H - -#include - -double univariate_viterbi_nhmm( - const arma::vec& log_init, - const arma::cube& log_transition, - const arma::mat& log_py, - arma::subview_col q); - -#endif \ No newline at end of file diff --git a/src/viterbix.cpp b/src/viterbix.cpp index 6d1ab80b..29f0e3d3 100644 --- a/src/viterbix.cpp +++ b/src/viterbix.cpp @@ -11,19 +11,19 @@ Rcpp::List viterbix(const arma::mat& transition, const arma::cube& emission, arma::mat lweights = exp(X * coef).t(); lweights.each_row() /= sum(lweights, 0); lweights = log(lweights); - for (unsigned int k = 0; k < obs.n_slices; k++) { + for (arma::uword k = 0; k < obs.n_slices; k++) { arma::mat delta(emission.n_rows, obs.n_cols); arma::umat phi(emission.n_rows, obs.n_cols); delta.col(0) = init + reparma(lweights.col(k), numberOfStates); - for (unsigned int r = 0; r < emission.n_slices; r++) { + for (arma::uword r = 0; r < emission.n_slices; r++) { delta.col(0) += emission.slice(r).col(obs(r, 0, k)); } phi.col(0).zeros(); - for (unsigned int t = 1; t < obs.n_cols; t++) { - for (unsigned int j = 0; j < emission.n_rows; j++) { + for (arma::uword t = 1; t < obs.n_cols; t++) { + for (arma::uword j = 0; j < emission.n_rows; j++) { phi(j, t) = (delta.col(t - 1) + transition.col(j)).index_max(); delta(j, t) = delta(phi(j, t), t - 1) + transition(phi(j, t), j); - for (unsigned int r = 0; r < emission.n_slices; r++) { + for (arma::uword r = 0; r < emission.n_slices; r++) { delta(j, t) += emission(j, obs(r, t, k), r); } } diff --git a/tests/testthat/test-build_nhmm.R b/tests/testthat/test-build_nhmm.R index 975493f9..aa64efd6 100644 --- a/tests/testthat/test-build_nhmm.R +++ b/tests/testthat/test-build_nhmm.R @@ -113,3 +113,4 @@ test_that("build_nhmm works with missing observations", { 62L, 63L, 64L, 65L) ) }) + diff --git a/tests/testthat/test-forward_backward.R b/tests/testthat/test-forward_backward.R index bc61369b..ab2421e4 100644 --- a/tests/testthat/test-forward_backward.R +++ b/tests/testthat/test-forward_backward.R @@ -65,7 +65,7 @@ test_that("'forward_backward' works for single-channel 'nhmm'", { expect_error( fit <- estimate_nhmm( hmm_biofam$observations[[1]][1:10,], n_states = 3, - restarts = 2, threads = 1, maxeval = 2 + restarts = 2, maxeval = 2 ), NA ) @@ -118,7 +118,7 @@ test_that("'forward_backward' works for single-channel 'mnhmm'", { expect_error( fit <- estimate_mnhmm( hmm_biofam$observations[[1]], n_states = 4, n_clusters = 2, - restarts = 2, threads = 1, maxeval = 1 + restarts = 2, maxeval = 1 ), NA ) diff --git a/tests/testthat/test-gradients.R b/tests/testthat/test-gradients.R index 95fe885d..293e1d85 100644 --- a/tests/testthat/test-gradients.R +++ b/tests/testthat/test-gradients.R @@ -28,40 +28,37 @@ test_that("Gradients for singlechannel-NHMM are correct", { n_i <- attr(model, "np_pi") n_s <- attr(model, "np_A") n_o <- attr(model, "np_B") - X_i <- model$X_initial - X_s <- model$X_transition - X_o <- model$X_emission - K_i <- nrow(X_i) - K_s <- nrow(X_s) - K_o <- nrow(X_o) + X_pi <- model$X_pi + X_A <- model$X_A + X_B <- model$X_B + K_pi <- nrow(X_pi) + K_A <- nrow(X_A) + K_B <- nrow(X_B) obs <- create_obsArray(model) obs <- array(obs, dim(obs)[2:3]) pars <- rnorm(n_i + n_s + n_o) - Qs <- t(create_Q(S)) - Qm <- t(create_Q(M)) f <- function(pars) { - eta_pi <- create_eta_pi_nhmm(pars[seq_len(n_i)], S, K_i) - eta_A <- create_eta_A_nhmm(pars[n_i + seq_len(n_s)], S, K_s) + eta_pi <- create_eta_pi_nhmm(pars[seq_len(n_i)], S, K_pi) + eta_A <- create_eta_A_nhmm(pars[n_i + seq_len(n_s)], S, K_A) eta_B <- create_eta_B_nhmm( - pars[n_i + n_s + seq_len(n_o)], S, M, K_o + pars[n_i + n_s + seq_len(n_o)], S, M, K_B ) -log_objective_nhmm_singlechannel( - Qs, Qm, - eta_pi, X_i, - eta_A, X_s, - eta_B, X_o, + eta_pi, X_pi, + eta_A, X_A, + eta_B, X_B, obs, TRUE, TRUE, TRUE, TRUE, TRUE, model$sequence_lengths)$loglik } g <- function(pars) { - eta_pi <- create_eta_pi_nhmm(pars[seq_len(n_i)], S, K_i) - eta_A <- create_eta_A_nhmm(pars[n_i + seq_len(n_s)], S, K_s) + eta_pi <- create_eta_pi_nhmm(pars[seq_len(n_i)], S, K_pi) + eta_A <- create_eta_A_nhmm(pars[n_i + seq_len(n_s)], S, K_A) eta_B <- create_eta_B_nhmm( - pars[n_i + n_s + seq_len(n_o)], S, M, K_o + pars[n_i + n_s + seq_len(n_o)], S, M, K_B ) -unname(unlist(log_objective_nhmm_singlechannel( - Qs, Qm, eta_pi, X_i, eta_A, X_s, eta_B, X_o, + eta_pi, X_pi, eta_A, X_A, eta_B, X_B, obs, TRUE, TRUE, TRUE, TRUE, TRUE, model$sequence_lengths)[-1])) } expect_equal(g(pars), numDeriv::grad(f, pars)) @@ -107,37 +104,35 @@ test_that("Gradients for multichannel-NHMM are correct", { n_i <- attr(model, "np_pi") n_s <- attr(model, "np_A") n_o <- attr(model, "np_B") - X_i <- model$X_initial - X_s <- model$X_transition - X_o <- model$X_emission - K_i <- nrow(X_i) - K_s <- nrow(X_s) - K_o <- nrow(X_o) + X_pi <- model$X_pi + X_A <- model$X_A + X_B <- model$X_B + K_pi <- nrow(X_pi) + K_A <- nrow(X_A) + K_B <- nrow(X_B) obs <- create_obsArray(model) pars <- rnorm(n_i + n_s + n_o) - Qs <- t(create_Q(S)) - Qm <- lapply(M, function(m) t(create_Q(m))) f <- function(pars) { - eta_pi <- create_eta_pi_nhmm(pars[seq_len(n_i)], S, K_i) - eta_A <- create_eta_A_nhmm(pars[n_i + seq_len(n_s)], S, K_s) + eta_pi <- create_eta_pi_nhmm(pars[seq_len(n_i)], S, K_pi) + eta_A <- create_eta_A_nhmm(pars[n_i + seq_len(n_s)], S, K_A) eta_B <- create_eta_multichannel_B_nhmm( - pars[n_i + n_s + seq_len(n_o)], S, M, K_o + pars[n_i + n_s + seq_len(n_o)], S, M, K_B ) -log_objective_nhmm_multichannel( - Qs, Qm, eta_pi, X_i, eta_A, X_s, eta_B, X_o, - obs, M, TRUE, TRUE, TRUE, TRUE, TRUE, model$sequence_lengths)$loglik + eta_pi, X_pi, eta_A, X_A, eta_B, X_B, + obs, TRUE, TRUE, TRUE, TRUE, TRUE, model$sequence_lengths)$loglik } g <- function(pars) { - eta_pi <- create_eta_pi_nhmm(pars[seq_len(n_i)], S, K_i) - eta_A <- create_eta_A_nhmm(pars[n_i + seq_len(n_s)], S, K_s) + eta_pi <- create_eta_pi_nhmm(pars[seq_len(n_i)], S, K_pi) + eta_A <- create_eta_A_nhmm(pars[n_i + seq_len(n_s)], S, K_A) eta_B <- create_eta_multichannel_B_nhmm( - pars[n_i + n_s + seq_len(n_o)], S, M, K_o + pars[n_i + n_s + seq_len(n_o)], S, M, K_B ) -unname(unlist(log_objective_nhmm_multichannel( - Qs, Qm, eta_pi, X_i, eta_A, X_s, eta_B, X_o, - obs, M, TRUE, TRUE, TRUE, TRUE, TRUE, model$sequence_lengths)[-1])) + eta_pi, X_pi, eta_A, X_A, eta_B, X_B, + obs, TRUE, TRUE, TRUE, TRUE, TRUE, model$sequence_lengths)[-1])) } expect_equal(g(pars), numDeriv::grad(f, pars)) }) @@ -175,45 +170,42 @@ test_that("Gradients for singlechannel-MNHMM are correct", { n_s <- attr(model, "np_A") n_o <- attr(model, "np_B") n_d <- attr(model, "np_omega") - X_i <- model$X_initial - X_s <- model$X_transition - X_o <- model$X_emission - X_d <- model$X_cluster - K_i <- nrow(X_i) - K_s <- nrow(X_s) - K_o <- nrow(X_o) - K_d <- nrow(X_d) + X_pi <- model$X_pi + X_A <- model$X_A + X_B <- model$X_B + X_omega <- model$X_omega + K_pi <- nrow(X_pi) + K_A <- nrow(X_A) + K_B <- nrow(X_B) + K_omega <- nrow(X_omega) obs <- create_obsArray(model) obs <- array(obs, dim(obs)[2:3]) pars <- rnorm(n_i + n_s + n_o + n_d) - Qs <- t(create_Q(S)) - Qm <- t(create_Q(M)) - Qd <- t(create_Q(D)) f <- function(pars) { - eta_pi <- create_eta_pi_mnhmm(pars[seq_len(n_i)], S, K_i, D) - eta_A <- create_eta_A_mnhmm(pars[n_i + seq_len(n_s)], S, K_s, D) + eta_pi <- create_eta_pi_mnhmm(pars[seq_len(n_i)], S, K_pi, D) + eta_A <- create_eta_A_mnhmm(pars[n_i + seq_len(n_s)], S, K_A, D) eta_B <- create_eta_B_mnhmm( - pars[n_i + n_s + seq_len(n_o)], S, M, K_o, D + pars[n_i + n_s + seq_len(n_o)], S, M, K_B, D ) eta_omega <- create_eta_omega_mnhmm( - pars[n_i + n_s + n_o + seq_len(n_d)], D, K_d + pars[n_i + n_s + n_o + seq_len(n_d)], D, K_omega ) -log_objective_mnhmm_singlechannel( - Qs, Qm, Qd, eta_pi, X_i, eta_A, X_s, eta_B, X_o, eta_omega, X_d, + eta_omega, X_omega, eta_pi, X_pi, eta_A, X_A, eta_B, X_B, obs, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, model$sequence_lengths)$loglik } g <- function(pars) { - eta_pi <- create_eta_pi_mnhmm(pars[seq_len(n_i)], S, K_i, D) - eta_A <- create_eta_A_mnhmm(pars[n_i + seq_len(n_s)], S, K_s, D) + eta_pi <- create_eta_pi_mnhmm(pars[seq_len(n_i)], S, K_pi, D) + eta_A <- create_eta_A_mnhmm(pars[n_i + seq_len(n_s)], S, K_A, D) eta_B <- create_eta_B_mnhmm( - pars[n_i + n_s + seq_len(n_o)], S, M, K_o, D + pars[n_i + n_s + seq_len(n_o)], S, M, K_B, D ) eta_omega <- create_eta_omega_mnhmm( - pars[n_i + n_s + n_o + seq_len(n_d)], D, K_d + pars[n_i + n_s + n_o + seq_len(n_d)], D, K_omega ) -unname(unlist(log_objective_mnhmm_singlechannel( - Qs, Qm, Qd, eta_pi, X_i, eta_A, X_s, eta_B, X_o, eta_omega, X_d, + eta_omega, X_omega, eta_pi, X_pi, eta_A, X_A, eta_B, X_B, obs, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, model$sequence_lengths)[-1])) } expect_equal(g(pars), numDeriv::grad(f, pars)) @@ -262,51 +254,48 @@ test_that("Gradients for multichannel-MNHMM are correct", { n_s <- attr(model, "np_A") n_o <- attr(model, "np_B") n_d <- attr(model, "np_omega") - X_i <- model$X_initial - X_s <- model$X_transition - X_o <- model$X_emission - X_d <- model$X_cluster - K_i <- nrow(X_i) - K_s <- nrow(X_s) - K_o <- nrow(X_o) - K_d <- nrow(X_d) + X_pi <- model$X_pi + X_A <- model$X_A + X_B <- model$X_B + X_omega <- model$X_omega + K_pi <- nrow(X_pi) + K_A <- nrow(X_A) + K_B <- nrow(X_B) + K_omega <- nrow(X_omega) obs <- create_obsArray(model) pars <- rnorm(n_i + n_s + n_o + n_d) - Qs <- t(create_Q(S)) - Qm <- lapply(M, function(m) t(create_Q(m))) - Qd <- t(create_Q(D)) f <- function(pars) { - eta_pi <- create_eta_pi_mnhmm(pars[seq_len(n_i)], S, K_i, D) - eta_A <- create_eta_A_mnhmm(pars[n_i + seq_len(n_s)], S, K_s, D) + eta_pi <- create_eta_pi_mnhmm(pars[seq_len(n_i)], S, K_pi, D) + eta_A <- create_eta_A_mnhmm(pars[n_i + seq_len(n_s)], S, K_A, D) eta_B <- unlist( create_eta_multichannel_B_mnhmm( - pars[n_i + n_s + seq_len(n_o)], S, M, K_o, D + pars[n_i + n_s + seq_len(n_o)], S, M, K_B, D ), recursive = FALSE ) eta_omega <- create_eta_omega_mnhmm( - pars[n_i + n_s + n_o + seq_len(n_d)], D, K_d + pars[n_i + n_s + n_o + seq_len(n_d)], D, K_omega ) -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, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, model$sequence_lengths)$loglik + eta_omega, X_omega, eta_pi, X_pi, eta_A, X_A, eta_B, X_B, + obs, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, model$sequence_lengths)$loglik } g <- function(pars) { - eta_pi <- create_eta_pi_mnhmm(pars[seq_len(n_i)], S, K_i, D) - eta_A <- create_eta_A_mnhmm(pars[n_i + seq_len(n_s)], S, K_s, D) + eta_pi <- create_eta_pi_mnhmm(pars[seq_len(n_i)], S, K_pi, D) + eta_A <- create_eta_A_mnhmm(pars[n_i + seq_len(n_s)], S, K_A, D) eta_B <- unlist( create_eta_multichannel_B_mnhmm( - pars[n_i + n_s + seq_len(n_o)], S, M, K_o, D + pars[n_i + n_s + seq_len(n_o)], S, M, K_B, D ), recursive = FALSE ) eta_omega <- create_eta_omega_mnhmm( - pars[n_i + n_s + n_o + seq_len(n_d)], D, K_d + pars[n_i + n_s + n_o + seq_len(n_d)], D, K_omega ) -unname(unlist(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, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, model$sequence_lengths)[-1])) + eta_omega, X_omega, eta_pi, X_pi, eta_A, X_A, eta_B, X_B, + obs, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, model$sequence_lengths)[-1])) } expect_equal(g(pars), numDeriv::grad(f, pars)) }) diff --git a/tests/testthat/test-hidden_paths.R b/tests/testthat/test-hidden_paths.R index e430188a..a47cee6c 100644 --- a/tests/testthat/test-hidden_paths.R +++ b/tests/testthat/test-hidden_paths.R @@ -72,7 +72,7 @@ test_that("'hidden_paths' works for 'mnhmm'", { expect_error( fit <- estimate_mnhmm( hmm_biofam$observations[[1]], n_states = 3, n_clusters = 2, - restarts = 2, threads = 1, maxeval = 1 + restarts = 2, maxeval = 1 ), NA ) diff --git a/tests/testthat/test-posterior_probs.R b/tests/testthat/test-posterior_probs.R index d3ae8ffe..9a76b571 100644 --- a/tests/testthat/test-posterior_probs.R +++ b/tests/testthat/test-posterior_probs.R @@ -55,7 +55,7 @@ test_that("'posterior_probs' works for 'nhmm'", { expect_error( fit <- estimate_nhmm( hmm_biofam$observations[[1]], n_states = 3, - restarts = 2, threads = 1, maxeval = 1 + restarts = 2, maxeval = 1 ), NA )