//' Evaluate the log-density of the measurement process by calling measurement //' process density functions via external Xptr. //' //' @param emitmat matrix of emission probabilities //' @param obsmat matrix containing the data //' @param statemat matrix containing the compartment counts at the observation //' times //' @param measproc_indmat logical matrix indicating which compartments are //' observed at every observation time //' @param parameters numeric vector of parameter values //' @param constants numeric vector of constants //' @param tcovar_censusmat numeric vector of time-varying covariate values //' @param d_meas_ptr external pointer to measurement process density function //' //' @export // [[Rcpp::export]] void evaluate_d_measure(Rcpp::NumericMatrix& emitmat, const Rcpp::NumericMatrix& obsmat, const Rcpp::NumericMatrix& statemat, const Rcpp::LogicalMatrix& measproc_indmat, const Rcpp::NumericVector& parameters, const Rcpp::NumericVector& constants, const Rcpp::NumericMatrix& tcovar_censusmat, SEXP d_meas_ptr) { // get dimensions Rcpp::IntegerVector emit_dims = emitmat.attr("dim"); // evaluate the densities for(int j=0; j < emit_dims[0]; ++j) { // args: emitmat, emit_inds, record_ind, record, state, parameters, constants, tcovar, pointer CALL_D_MEASURE(emitmat, measproc_indmat.row(j), j, obsmat.row(j), statemat.row(j), parameters, constants, tcovar_censusmat.row(j), d_meas_ptr); } }
//' @title Calculating validation scores between two adjacency matrices //' //' @description //' This function calculates the validation scores between two adjacency matrices. //' //' @param inf_mat matrix. It should be adjacency matrix of inferred network. //' @param true_mat matrix. It should be adjacency matrix of true network. // [[Rcpp::export]] Rcpp::NumericVector rcpp_validate(Rcpp::NumericMatrix inf_mat, Rcpp::NumericMatrix true_mat) { if(inf_mat.ncol() != true_mat.ncol()) { throw std::invalid_argument( "Two input matrices should have the same number of columns." ); } if(inf_mat.nrow() != true_mat.nrow()) { throw std::invalid_argument( "Two input matrices should have the same number of rows." ); } int tp=0; int tn=0; int fp=0; int fn=0; for(signed int i=0; i<inf_mat.nrow(); i++) { //Convert R objects into C++ objects. Rcpp::NumericVector xr = inf_mat.row(i); Rcpp::NumericVector yr = true_mat.row(i); std::vector<int> x = Rcpp::as<std::vector <int> >(xr); std::vector<int> y = Rcpp::as<std::vector <int> >(yr); std::vector<int> z; //Calculate the frequency of numbers. //tp=true positive [1,1], tn=true negative [0,0], fp=false positive [1,0], fn=false negative [0,1]. for(unsigned int k=0; k<x.size(); k++) { z.push_back(x[k] + y[k]); //Calculate the summation of x and y between each element. if(z[k] == 2) { tp += 1; } else if(z[k] == 0) { tn += 1; } else if(z[k] == 1) { if(x[k] == 0) { fp += 1; } else { fn += 1; } } else { throw std::invalid_argument("Error in calculating the contigency table."); } } } //std::vector<int> output{tp, tn, fp, fn}; c++11 only int tmp_arr[4] = {tp, tn, fp, fn}; std::vector<int> output(&tmp_arr[0], &tmp_arr[0]+4); return Rcpp::wrap(output); }
// gradient-descent ------------------------------------------------------------ //' @title Regular gradient descent for latent factor model with covariates //' @param X The ratings matrix. Unobserved entries must be marked NA. Users //' must be along rows, and tracks must be along columns. //' @param Z The covariates associated with each pair. This must be shaped as an //' array with users along rows, tracks along columns, and features along //' slices. //' @param k_factors The number of latent factors for the problem. //' @param lambdas The regularization parameters for P, Q, and beta, respectively. //' @param n_iter The number of gradient descent iterations to run. //' @param batch_samples The proportion of the observed entries to sample in the //' gradient for each factor in the gradient descent. //' @param batch_factors The proportion of latent factors to update at each //' iteration. //' @param gamma The step-size in the gradient descent. //' @param verbose Print the objective at each iteration of the descent? //' @return A list with the following elements, \cr //' $P The learned user latent factors. \cr //' $Q The learned track latent factors. \cr //' $beta The learned regression coefficients. //' @export // [[Rcpp::export]] Rcpp::List svd_cov(Rcpp::NumericMatrix X, Rcpp::NumericVector Z_vec, int k_factors, Rcpp::NumericVector lambdas, int n_iter, double batch_samples, double batch_factors, double gamma_pq, double gamma_beta, bool verbose) { // convert to arma Rcpp::IntegerVector Z_dim = Z_vec.attr("dim"); arma::cube Z(Z_vec.begin(), Z_dim[0], Z_dim[1], Z_dim[2], false); // initialize results int m = X.nrow(); int n = X.ncol(); int l = Z_dim[2]; arma::mat P = 1.0 / sqrt(m) * arma::randn(m, k_factors); arma::mat Q = 1.0 / sqrt(n) * arma::randn(n, k_factors); arma::vec beta = 1.0 / sqrt(l) * arma::randn(l); arma::vec objs = arma::zeros(n_iter); // perform gradient descent steps for(int cur_iter = 0; cur_iter < n_iter; cur_iter++) { // update user factors arma::uvec cur_factors = get_batch_ix(m, batch_factors); for(int i = 0; i < cur_factors.n_elem; i++) { int cur_ix = cur_factors(i); P.row(cur_ix) = update_factor(X.row(cur_ix), Z(arma::span(cur_ix), arma::span(), arma::span()), arma::conv_to<arma::vec>::from(P.row(cur_ix)), Q, beta, batch_samples, lambdas[0], gamma_pq).t(); } // update track factors cur_factors = get_batch_ix(n, batch_factors); for(int j = 0; j < cur_factors.n_elem; j++) { int cur_ix = cur_factors(j); Q.row(cur_ix) = update_factor(X.column(cur_ix), Z(arma::span(), arma::span(cur_ix), arma::span()), arma::conv_to<arma::vec>::from(Q.row(cur_ix)), P, beta, batch_samples, lambdas[1], gamma_pq).t(); } // update regression coefficients beta = update_beta(Rcpp::as<arma::mat>(X), Z, P, Q, beta, lambdas[2], gamma_beta); objs[cur_iter] = objective_fun(Rcpp::as<arma::mat>(X), Z, P, Q, beta, lambdas); if(verbose) { printf("iteration %d \n", cur_iter); printf("Objective: %g \n", objs[cur_iter]); } } return Rcpp::List::create(Rcpp::Named("P") = P, Rcpp::Named("Q") = Q, Rcpp::Named("beta") = beta, Rcpp::Named("objs") = objs); }
//' Simulate an LNA path using a non-centered parameterization for the //' log-transformed counting process LNA. //' //' @param lna_times vector of interval endpoint times //' @param lna_draws vector of N(0,1) draws to be mapped to the path //' @param lna_pars numeric matrix of parameters, constants, and time-varying //' covariates at each of the lna_times //' @param init_start index in the parameter vector where the initial compartment //' volumes start //' @param param_update_inds logical vector indicating at which of the times the //' LNA parameters need to be updated. //' @param stoich_matrix stoichiometry matrix giving the changes to compartments //' from each reaction //' @param forcing_inds logical vector of indicating at which times in the //' time-varying covariance matrix a forcing is applied. //' @param forcing_matrix matrix containing the forcings. //' @param max_attempts maximum number of tries if the first increment is rejected //' @param step_size initial step size for the ODE solver (adapted internally, //' but too large of an initial step can lead to failure in stiff systems). //' @param lna_pointer external pointer to the compiled LNA integration function. //' @param set_pars_pointer external pointer to the function for setting LNA pars. //' @return list containing the stochastic perturbations (i.i.d. N(0,1) draws) and //' the LNA path on its natural scale which is determined by the perturbations. //' //' @export // [[Rcpp::export]] Rcpp::List propose_lna(const arma::rowvec& lna_times, const Rcpp::NumericVector& lna_draws, const Rcpp::NumericMatrix& lna_pars, const Rcpp::IntegerVector& lna_param_inds, const Rcpp::IntegerVector& lna_tcovar_inds, const int init_start, const Rcpp::LogicalVector& param_update_inds, const arma::mat& stoich_matrix, const Rcpp::LogicalVector& forcing_inds, const arma::uvec& forcing_tcov_inds, const arma::mat& forcings_out, const arma::cube& forcing_transfers, int max_attempts, double step_size, SEXP lna_pointer, SEXP set_pars_pointer) { // get the dimensions of various objects int n_events = stoich_matrix.n_cols; // number of transition events, e.g., S2I, I2R int n_comps = stoich_matrix.n_rows; // number of model compartments (all strata) int n_odes = n_events + n_events*n_events; // number of ODEs int n_times = lna_times.n_elem; // number of times at which the LNA must be evaluated int n_tcovar = lna_tcovar_inds.size(); // number of time-varying covariates or parameters int n_forcings = forcing_tcov_inds.n_elem; // number of forcings // for use with forcings double forcing_flow = 0; arma::vec forcing_distvec(n_comps, arma::fill::zeros); // initialize the objects used in each time interval double t_L = 0; double t_R = 0; Rcpp::NumericVector current_params = lna_pars.row(0); // vector for storing the current parameter values CALL_SET_ODE_PARAMS(current_params, set_pars_pointer); // set the parameters in the odeintr namespace // initial state vector - copy elements from the current parameter vector arma::vec init_volumes(current_params.begin() + init_start, n_comps); // initialize the LNA objects - the vector for storing the current state Rcpp::NumericVector lna_state_vec(n_odes); // vector to store the results of the ODEs arma::vec lna_drift(n_events, arma::fill::zeros); // incidence mean vector (natural scale) arma::mat lna_diffusion(n_events, n_events, arma::fill::zeros); // diffusion matrix arma::vec log_lna(n_events, arma::fill::zeros); // LNA increment, log scale arma::vec nat_lna(n_events, arma::fill::zeros); // LNA increment, natural scale // Objects for computing the eigen decomposition of the LNA covariance matrices arma::vec svd_d(n_events, arma::fill::zeros); arma::mat svd_U(n_events, n_events, arma::fill::zeros); arma::mat svd_V(n_events, n_events, arma::fill::zeros); bool good_svd = true; // matrix in which to store the LNA path arma::mat lna_path(n_events+1, n_times, arma::fill::zeros); // incidence path arma::mat prev_path(n_comps+1, n_times, arma::fill::zeros); // prevalence path (compartment volumes) lna_path.row(0) = lna_times; prev_path.row(0) = lna_times; prev_path(arma::span(1,n_comps), 0) = init_volumes; // apply forcings if called for - applied after censusing at the first time if(forcing_inds[0]) { // distribute the forcings proportionally to the compartment counts in the applicable states for(int j=0; j < n_forcings; ++j) { forcing_flow = lna_pars(0, forcing_tcov_inds[j]); forcing_distvec = forcing_flow * normalise(forcings_out.col(j) % init_volumes, 1); init_volumes += forcing_transfers.slice(j) * forcing_distvec; } } // sample the stochastic perturbations - use Rcpp RNG for safety Rcpp::NumericVector draws_rcpp(Rcpp::clone(lna_draws)); arma::mat draws(draws_rcpp.begin(), n_events, n_times-1, true); // iterate over the time sequence, solving the LNA over each interval for(int j=0; j < (n_times-1); ++j) { // set the times of the interval endpoints t_L = lna_times[j]; t_R = lna_times[j+1]; // Reset the LNA state vector and integrate the LNA ODEs over the next interval to 0 std::fill(lna_state_vec.begin(), lna_state_vec.end(), 0.0); CALL_INTEGRATE_STEM_ODE(lna_state_vec, t_L, t_R, step_size, lna_pointer); // transfer the elements of the lna_state_vec to the process objects std::copy(lna_state_vec.begin(), lna_state_vec.begin() + n_events, lna_drift.begin()); std::copy(lna_state_vec.begin() + n_events, lna_state_vec.end(), lna_diffusion.begin()); // map the stochastic perturbation to the LNA path on its natural scale try{ if(lna_drift.has_nan() || lna_diffusion.has_nan()) { good_svd = false; throw std::runtime_error("Integration failed."); } else { good_svd = arma::svd(svd_U, svd_d, svd_V, lna_diffusion); // compute the SVD } if(!good_svd) { throw std::runtime_error("SVD failed."); } else { svd_d.elem(arma::find(svd_d < 0)).zeros(); // zero out negative sing. vals svd_V.each_row() %= arma::sqrt(svd_d).t(); // multiply rows of V by sqrt(d) svd_U *= svd_V.t(); // complete svd_sqrt svd_U.elem(arma::find(lna_diffusion == 0)).zeros(); // zero out numerical errors log_lna = lna_drift + svd_U * draws.col(j); // map the LNA draws } } catch(std::exception & err) { // reinstatiate the SVD objects arma::vec svd_d(n_events, arma::fill::zeros); arma::mat svd_U(n_events, n_events, arma::fill::zeros); arma::mat svd_V(n_events, n_events, arma::fill::zeros); // forward the exception forward_exception_to_r(err); } catch(...) { ::Rf_error("c++ exception (unknown reason)"); } // compute the LNA increment nat_lna = arma::vec(expm1(Rcpp::NumericVector(log_lna.begin(), log_lna.end()))); // update the compartment volumes init_volumes += stoich_matrix * nat_lna; // throw errors for negative increments or negative volumes try{ if(any(nat_lna < 0)) { throw std::runtime_error("Negative increment."); } if(any(init_volumes < 0)) { throw std::runtime_error("Negative compartment volumes."); } } catch(std::exception &err) { forward_exception_to_r(err); } catch(...) { ::Rf_error("c++ exception (unknown reason)"); } // save the increment and the prevalence lna_path(arma::span(1,n_events), j+1) = nat_lna; prev_path(arma::span(1,n_comps), j+1) = init_volumes; // apply forcings if called for - applied after censusing the path if(forcing_inds[j+1]) { // distribute the forcings proportionally to the compartment counts in the applicable states for(int s=0; s < n_forcings; ++s) { forcing_flow = lna_pars(j+1, forcing_tcov_inds[s]); forcing_distvec = forcing_flow * normalise(forcings_out.col(s) % init_volumes, 1); init_volumes += forcing_transfers.slice(s) * forcing_distvec; } // throw errors for negative negative volumes try{ if(any(init_volumes < 0)) { throw std::runtime_error("Negative compartment volumes."); } } catch(std::exception &err) { forward_exception_to_r(err); } catch(...) { ::Rf_error("c++ exception (unknown reason)"); } } // update the parameters if they need to be updated if(param_update_inds[j+1]) { // time-varying covariates and parameters std::copy(lna_pars.row(j+1).end() - n_tcovar, lna_pars.row(j+1).end(), current_params.end() - n_tcovar); } // copy the compartment volumes to the current parameters std::copy(init_volumes.begin(), init_volumes.end(), current_params.begin() + init_start); // set the lna parameters and reset the LNA state vector CALL_SET_ODE_PARAMS(current_params, set_pars_pointer); } // return the paths return Rcpp::List::create(Rcpp::Named("draws") = draws, Rcpp::Named("lna_path") = lna_path.t(), Rcpp::Named("prev_path") = prev_path.t()); }