Ejemplo n.º 1
0
//' 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);
        }
}
Ejemplo n.º 2
0
//' @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);
}
Ejemplo n.º 3
0
// 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);
}
Ejemplo n.º 4
0
//' 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());
}