// Bellman recursion using row rearrangement //[[Rcpp::export]] Rcpp::List Bellman(const arma::mat& grid, Rcpp::NumericVector reward_, const arma::cube& scrap, Rcpp::NumericVector control_, const arma::cube& disturb, const arma::vec& weight) { // Passing R objects to C++ const std::size_t n_grid = grid.n_rows; const std::size_t n_dim = grid.n_cols; const arma::ivec r_dims = reward_.attr("dim"); const std::size_t n_pos = r_dims(3); const std::size_t n_action = r_dims(2); const std::size_t n_dec = r_dims(4) + 1; const arma::cube reward(reward_.begin(), n_grid, n_dim * n_action * n_pos, n_dec - 1, false); const arma::ivec c_dims = control_.attr("dim"); arma::cube control2; arma::imat control; bool full_control; if (c_dims.n_elem == 3) { full_control = false; arma::cube temp_control2(control_.begin(), n_pos, n_action, n_pos, false); control2 = temp_control2; } else { full_control = true; arma::mat temp_control(control_.begin(), n_pos, n_action, false); control = arma::conv_to<arma::imat>::from(temp_control); } const std::size_t n_disturb = disturb.n_slices; // Bellman recursion arma::cube value(n_grid, n_dim * n_pos, n_dec); arma::cube cont(n_grid, n_dim * n_pos, n_dec - 1, arma::fill::zeros); arma::mat d_value(n_grid, n_dim); Rcpp::Rcout << "At dec: " << n_dec - 1 << "..."; for (std::size_t pp = 0; pp < n_pos; pp++) { value.slice(n_dec - 1).cols(n_dim * pp, n_dim * (pp + 1) - 1) = scrap.slice(pp); } for (int tt = (n_dec - 2); tt >= 0; tt--) { Rcpp::Rcout << tt; // Approximating the continuation value for (std::size_t pp = 0; pp < n_pos; pp++) { cont.slice(tt).cols(n_dim * pp, n_dim * (pp + 1) - 1) = Expected(grid, value.slice(tt + 1).cols(pp * n_dim, n_dim * (pp + 1) - 1), disturb, weight); } Rcpp::Rcout << ".."; // Optimise value function if (full_control) { BellmanOptimal(grid, control, value, reward, cont, tt); } else { BellmanOptimal2(grid, control2, value, reward, cont, tt); } Rcpp::Rcout << "."; } return Rcpp::List::create(Rcpp::Named("value") = value, Rcpp::Named("expected") = cont); }
//' Update eigen values, vectors, and inverse matrices for irms //' //' @param tpm_prods array of transition probability matrix products //' @param tpms array of transition probability matrices //' @param pop_mat population level bookkeeping matrix //' @param obstimes vector of observation times //' //' @return Updated eigenvalues, eigenvectors, and inverse matrices // [[Rcpp::export]] void tpmProdSeqs(Rcpp::NumericVector& tpm_prods, Rcpp::NumericVector& tpms, const Rcpp::IntegerVector obs_time_inds) { // Get indices int n_obs = obs_time_inds.size(); Rcpp::IntegerVector tpmDims = tpms.attr("dim"); // Ensure obs_time_inds starts at 0 Rcpp::IntegerVector obs_inds = obs_time_inds - 1; // Set array pointers arma::cube prod_arr(tpm_prods.begin(), tpmDims[0], tpmDims[1], tpmDims[2], false); arma::cube tpm_arr(tpms.begin(), tpmDims[0], tpmDims[1], tpmDims[2], false); // Generate tpm products and store them in the appropriate spots in the tpm product array for(int j = 0; j < (n_obs - 1); ++j) { prod_arr.slice(obs_inds[j+1] - 1) = tpm_arr.slice(obs_inds[j+1] - 1); for(int k = (obs_inds[j+1] - 2); k > (obs_inds[j] - 1); --k) { prod_arr.slice(k) = tpm_arr.slice(k) * prod_arr.slice(k + 1); } } }
// 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); }
//[[Rcpp::export]] Rcpp::List map_data_set(Rcpp::NumericMatrix data_, Rcpp::NumericVector inpar,bool lc_) { svec parnames = Rcpp::as<svec>(inpar.attr("names")); dataobject* data = new dataobject(data_,parnames); data->map_uid(); data->locate_tran(lc_); data -> idata_row(); Rcpp::List ans = data->ex_port(); delete data; return(ans); }
//[[Rcpp::export]] arma::cube PathDisturb(const arma::vec& start, Rcpp::NumericVector disturb_) { // R objects to C++ const arma::ivec d_dims = disturb_.attr("dim"); const std::size_t n_dim = d_dims(0); const std::size_t n_dec = d_dims(3) + 1; const std::size_t n_path = d_dims(2); const arma::cube disturb(disturb_.begin(), n_dim, n_dim * n_path, n_dec - 1, false); // Simulating the sample paths arma::cube path(n_path, n_dim, n_dec); // Assign starting values for (std::size_t ii = 0; ii < n_dim; ii++) { path.slice(0).col(ii).fill(start(ii)); } // Disturb the paths for (std::size_t pp = 0; pp < n_path; pp++) { for (std::size_t tt = 1; tt < n_dec; tt++) { path.slice(tt).row(pp) = path.slice(tt - 1).row(pp) * arma::trans(disturb.slice(tt - 1).cols(n_dim * pp, n_dim * (pp + 1) - 1)); } } return path; }
// Calculate the martingale increments using the row rearrangement //[[Rcpp::export]] arma::cube AddDual(const arma::cube& path, Rcpp::NumericVector subsim_, const arma::vec& weight, Rcpp::NumericVector value_, Rcpp::Function Scrap_) { // R objects to C++ const std::size_t n_path = path.n_rows; const arma::ivec v_dims = value_.attr("dim"); const std::size_t n_grid = v_dims(0); const std::size_t n_dim = v_dims(1); const std::size_t n_pos = v_dims(2); const std::size_t n_dec = v_dims(3); const arma::cube value(value_.begin(), n_grid, n_dim * n_pos, n_dec, false); const arma::ivec s_dims = subsim_.attr("dim"); const std::size_t n_subsim = s_dims(2); const arma::cube subsim(subsim_.begin(), n_dim, n_dim * n_subsim * n_path, n_dec - 1, false); // Duals arma::cube mart(n_path, n_pos, n_dec - 1); arma::mat temp_state(n_subsim * n_path, n_dim); arma::mat fitted(n_grid, n_dim); std::size_t ll; Rcpp::Rcout << "Additive duals at dec: "; // Find averaged value for (std::size_t tt = 0; tt < (n_dec - 2); tt++) { Rcpp::Rcout << tt << "..."; // 1 step subsimulation #pragma omp parallel for private(ll) for (std::size_t ii = 0; ii < n_path; ii++) { for (std::size_t ss = 0; ss < n_subsim; ss++) { ll = n_subsim * ii + ss; temp_state.row(ll) = weight(ss) * path.slice(tt).row(ii) * arma::trans(subsim.slice(tt).cols(n_dim * ll, n_dim * (ll + 1) - 1)); } } // Averaging for (std::size_t pp = 0; pp < n_pos; pp++) { fitted = value.slice(tt + 1).cols(n_dim * pp, n_dim * (pp + 1) - 1); mart.slice(tt).col(pp) = arma::conv_to<arma::vec>::from(arma::sum(arma::reshape( OptimalValue(temp_state, fitted), n_subsim, n_path))); // Subtract the path realisation mart.slice(tt).col(pp) -= OptimalValue(path.slice(tt + 1), fitted); } } // Scrap value Rcpp::Rcout << n_dec - 1 << "..."; // 1 step subsimulation #pragma omp parallel for private(ll) for (std::size_t ii = 0; ii < n_path; ii++) { for (std::size_t ss = 0; ss < n_subsim; ss++) { ll = n_subsim * ii + ss; temp_state.row(n_path * ss + ii) = path.slice(n_dec - 2).row(ii) * arma::trans(subsim.slice(n_dec - 2).cols(n_dim * ll, n_dim * (ll + 1) - 1)); } } // Averaging arma::mat subsim_scrap(n_subsim * n_path, n_pos); subsim_scrap = Rcpp::as<arma::mat>(Scrap_( Rcpp::as<Rcpp::NumericMatrix>(Rcpp::wrap(temp_state)))); arma::mat scrap(n_path, n_pos); scrap = Rcpp::as<arma::mat>(Scrap_( Rcpp::as<Rcpp::NumericMatrix>(Rcpp::wrap(path.slice(n_dec - 1))))); for (std::size_t pp = 0; pp < n_pos; pp++) { mart.slice(n_dec - 2).col(pp) = arma::reshape(subsim_scrap.col(pp), n_path, n_subsim) * weight; // Subtract the path realisation mart.slice(n_dec - 2).col(pp) -= scrap.col(pp); } Rcpp::Rcout << "done\n"; return mart; }
//[[Rcpp::export]] Rcpp::List AddDualBounds(const arma::cube& path, Rcpp::NumericVector control_, Rcpp::Function Reward_, Rcpp::Function Scrap_, const arma::cube& mart, const arma::ucube& path_action) { // Extract parameters const std::size_t n_dec = path.n_slices; const std::size_t n_path = path.n_rows; const std::size_t n_dim = path.n_cols; const arma::ivec c_dims = control_.attr("dim"); const std::size_t n_pos = c_dims(0); const std::size_t n_action = c_dims(1); arma::imat control; // full control arma::cube control2; // partial control bool full_control; if (c_dims.n_elem == 3) { full_control = false; arma::cube temp_control2(control_.begin(), n_pos, n_action, n_pos, false); control2 = temp_control2; } else { full_control = true; arma::mat temp_control(control_.begin(), n_pos, n_action, false); control = arma::conv_to<arma::imat>::from(temp_control); } // Initialise with scrap value arma::cube primals(n_path, n_pos, n_dec); primals.slice(n_dec - 1) = Rcpp::as<arma::mat>( Scrap_(Rcpp::as<Rcpp::NumericMatrix>(Rcpp::wrap(path.slice(n_dec - 1))))); arma::cube duals = primals; // Perform the backward induction arma::uword policy; arma::cube reward(n_path, n_action, n_pos); if (full_control) { // For the full control case arma::uword next; for (int tt = (n_dec - 2); tt >= 0; tt--) { reward = Rcpp::as<arma::cube>(Reward_( Rcpp::as<Rcpp::NumericMatrix>(Rcpp::wrap(path.slice(tt))), tt + 1)); #pragma omp parallel for private(policy, next) for (std::size_t ii = 0; ii < n_path; ii++) { for (std::size_t pp = 0; pp < n_pos; pp++) { // Primal values policy = path_action(ii, pp, tt) - 1; // R to C indexing next = control(pp, policy) - 1; primals(ii, pp, tt) = reward(ii, policy, pp) + mart(ii, next, tt) + primals(ii, next, tt + 1); // Dual values next = control(pp, 0) - 1; duals(ii, pp, tt) = reward(ii, 0, pp) + mart(ii, next, tt) + duals(ii, next, tt + 1); for (std::size_t aa = 1; aa < n_action; aa++) { next = control(pp, aa) - 1; duals(ii, pp, tt) = std::max(reward(ii, aa, pp) + mart(ii, next, tt) + duals(ii, next, tt + 1), duals(ii, pp, tt)); } } } } } else { // Positions evolve randomly arma::rowvec mod(n_pos); arma::rowvec prob_weight(n_pos); for (int tt = (n_dec - 2); tt >= 0; tt--) { reward = Rcpp::as<arma::cube>(Reward_( Rcpp::as<Rcpp::NumericMatrix>(Rcpp::wrap(path.slice(tt))), tt + 1)); #pragma omp parallel for private(policy, prob_weight, mod) for (std::size_t ii = 0; ii < n_path; ii++) { for (std::size_t pp = 0; pp < n_pos; pp++) { // Primal values mod = primals.slice(tt + 1).row(ii) + mart.slice(tt).row(ii); policy = path_action(ii, pp, tt) - 1; prob_weight = control2.tube(pp, policy); primals(ii, pp, tt) = reward(ii, policy, pp) + arma::sum(prob_weight % mod); // Dual values mod = duals.slice(tt + 1).row(ii) + mart.slice(tt).row(ii); prob_weight = control2.tube(pp, 0); duals(ii, pp, tt) = reward(ii, 0, pp) + arma::sum(prob_weight % mod); for (std::size_t aa = 1; aa < n_action; aa++) { prob_weight = control2.tube(pp, aa); duals(ii, pp, tt) = std::max(reward(ii, aa, pp) + arma::sum(prob_weight % mod), duals(ii, pp, tt)); } } } } } return Rcpp::List::create(Rcpp::Named("primal") = primals, Rcpp::Named("dual") = duals); }
// [[Rcpp::export]] XPtrImage magick_image_readbitmap_double(Rcpp::NumericVector x){ Rcpp::IntegerVector dims(x.attr("dim")); return magick_image_bitmap(x.begin(), Magick::DoublePixel, dims[0], dims[1], dims[2]); }