NumericVector inclusionProb(const NumericVector& prob, const int& size) { // prob ... vector of initial probability weights // size ... sample size // check initial result int i; // index for loops int nneg = 0; // number of negative values int N = prob.size(); // number of observations double sum = 0.0; // sum of probability weights NumericVector result(N); // inclusion probabilities for(i = 0; i < N; i++) { if(prob[i] < 0.0) { result[i] = 0.0; // set negative values to 0 nneg++; // count negative values } else { result[i] = prob[i]; if(prob[i] > 0.0) { sum += prob[i]; // add current element to sum } } } if(nneg > 0) warning("negative probability weights are set to 0"); // compute inclusion probabilities if(sum > 0.0) { int ngeq1 = 0; // number of values >= 1 for(i = 0; i < N; i++) { if(result[i] > 0.0) { result[i] = result[i] * size / sum; // initial adjustment if(result[i] >= 1.0) ngeq1++; // count values >= 1 } } // values >= 1 are set to 1 and the others are readjusted if(ngeq1 > 0) { int nset = 0; // ??? // I think this results in an infinite loop while(ngeq1 != nset) { // compute sum of values less than 1 sum = 0.0; // reset sum for(i = 0; i < N; i++) { if(result[i] > 0.0 && result[i] < 1.0) { sum += result[i]; // add current element to sum } } // readjust values if(sum > 0.0) { for(i = 0; i < N; i++) { if(result[i] > 0.0 && result[i] < 1.0) { result[i] = result[i] * (size-ngeq1) / sum; } } } nset = ngeq1; // recount values >= 1 and set them to 1 ngeq1 = 0; for(i = 0; i < N; i++) { if(result[i] >= 1.0) { result[i] = 1.0; ngeq1++; // count values >= 1 } } } } } return result; }
// [[Rcpp::export]] double sample_beta_scalar(NumericVector y, List x, NumericMatrix groups, NumericMatrix beta, List gamma, NumericVector delta, NumericMatrix z, double alpha, double sigma2, List bs_beta, double s2_beta, int p_id, int k_id) { double out; NumericVector params(2); double sum_term = 0.0; double sum_term2 = 0.0; double sum_term2a = 0.0; double sum_term2b = 0.0; double sum_term3 = 0.0; double sum_term4 = 0.0; NumericMatrix x_tmp = x(k_id); NumericMatrix bs_beta_tmp = bs_beta(k_id); for (int i = 0; i < y.size(); i++) { double term = 0.0; for (int j = 0; j < x_tmp.ncol(); j++) { term += bs_beta_tmp(j, p_id) * x_tmp(i, j); } sum_term += term * term; sum_term2 += y[i] * term; sum_term2a += alpha * term; for (int k = 0; k < z.ncol(); k++) { sum_term2b += term * delta[k] * z(i, k); } for (int q = 0; q < gamma.size(); q++) { NumericVector gamma_q = gamma[q]; int group_set = groups(i, q); sum_term3 += gamma_q[group_set] * term; } for (int k2 = 0; k2 < beta.nrow(); k2++) { NumericMatrix bs_beta_k = bs_beta[k2]; NumericMatrix x_k = x[k2]; if (k2 != k_id) { for (int s = 0; s < beta.ncol(); s++) { for (int j = 0; j < x_k.ncol(); j++) { sum_term4 += term * beta(k2, s) * bs_beta_k(j, s) * x_k(i, j); } } } else { for (int s = 0; s < beta.ncol(); s++) { if (s != p_id) { for (int j = 0; j < x_k.ncol(); j++) { sum_term4 += term * beta(k2, s) * bs_beta_k(j, s) * x_k(i, j); } } } } } } //Calculate params[1] params[1] = (sigma2 * s2_beta) / (s2_beta * sum_term + sigma2); //Calculate params[0] params[0] = params[1] * (-1.0 / (2.0 * sigma2)) * (-2.0 * sum_term2 + 2.0 * sum_term2a + 2.0 * sum_term2b + 2.0 * sum_term4 + 2.0 * sum_term3); //Calculate loglik out = rnorm(1, params[0], sqrt(params[1]))[0]; return out; }
// [[Rcpp::export]] List naive_cluster(NumericVector D, IntegerVector K, double threshold) { int M = K.size(); std::vector<std::vector<int> > result(M); std::vector<std::vector<double> > result_distances(M); std::vector<pair_dist> dst(D.size()); std::map<int, std::set<topic_index> > clusters; // initialization int c = 0; for (int m = 0; m < M; ++m) { result[m].resize(K[m]); result_distances[m].resize(K[m]); for (int k = 0; k < K[m]; ++k) { result[m][k] = c; clusters[c].insert(topic_index(m, k)); ++c; } } // brute force: we'll just write down which index in D // corresponds to which pair of topics, copying over D like space // is cheap or something. D is assumed to go block-by-block row-wise // along a block-upper-triangular matrix whose (I, J) block is the // K_I x K_J matrix of distances between topics in models I and J. // Within each block D runs rowwise along the block. // Zero blocks are omitted. int d = 0; // runs along D for (int m1 = 0; m1 < M - 1; ++m1) { for (int m2 = m1 + 1; m2 < M; ++m2) { for (int k1 = 0; k1 < K[m1]; ++k1) { for (int k2 = 0; k2 < K[m2]; ++k2) { if (d >= dst.size()) { stop("The length of D is not consistent with K"); } dst[d].d = D[d]; dst[d].t1.first = m1; dst[d].t1.second = k1; dst[d].t2.first = m2; dst[d].t2.second = k2; d += 1; } } } } if (d != D.size()) { stop("The length of D is not consistent with K"); } pair_dist_cmp pdc; std::sort(dst.begin(), dst.end(), pdc); int r1, r2; std::set<int> sect; bool allow; for (std::vector<pair_dist>::iterator d = dst.begin(); d != dst.end(); ++d) { if (d->d > threshold) { // then we're done break; } #ifdef __NAIVE_CLUSTER_LOG__ Rcout << d->t1.first << " "; Rcout << d->t1.second << " | "; Rcout << d->t2.first << " "; Rcout << d->t2.second << " ["; Rcout << d->d << "]"; #endif // get current cluster assignments r1 = result[d->t1.first][d->t1.second]; r2 = result[d->t2.first][d->t2.second]; if (r1 == r2) { #ifdef __NAIVE_CLUSTER_LOG__ Rcout << "...already merged." << std::endl; #endif continue; // they're already merged } if (r1 > r2) { std::swap(r1, r2); // guarantee r1 < r2 } std::set<topic_index> &c1 = clusters[r1]; std::set<topic_index> &c2 = clusters[r2]; if (c1.size() == M || c2.size() == M) { // if either cluster is full, merge is impossible #ifdef __NAIVE_CLUSTER_LOG__ Rcout << "...cluster full." << std::endl; #endif continue; } // Check whether the two clusters share topics from the same model sect.clear(); allow = true; #ifdef __NAIVE_CLUSTER_LOG__ Rcout << " c1 " << "(" << r1 << "):"; #endif for (std::set<topic_index>::iterator t = c1.begin(); t != c1.end(); ++t) { #ifdef __NAIVE_CLUSTER_LOG__ Rcout << " " << t->first; #endif sect.insert(t->first); } #ifdef __NAIVE_CLUSTER_LOG__ Rcout << " c2:" << "(" << r2 << "):"; #endif for (std::set<topic_index>::iterator t = c2.begin(); t != c2.end() && allow; ++t) { // if same model: cluster disallowed #ifdef __NAIVE_CLUSTER_LOG__ Rcout << " " << t->first; #endif allow = (sect.count(t->first) == 0); } if (!allow) { #ifdef __NAIVE_CLUSTER_LOG__ Rcout << "...disallowed." << std::endl; #endif continue; } #ifdef __NAIVE_CLUSTER_LOG__ Rcout << "...merge." << std::endl; #endif // otherwise: merge for (std::set<topic_index>::iterator t = c2.begin(); t != c2.end(); ++t) { c1.insert(*t); result[t->first][t->second] = r1; result_distances[t->first][t->second] = d->d; } clusters.erase(r2); // also deletes the associated set object } return List::create( _["clusters"] = wrap(result), _["distances"] = wrap(result_distances) ); }
// [[Rcpp::export]] List SDP_single_foreq(int tmax, NumericVector res_bs, int cons_bs, int xc, NumericVector rep_gain, NumericMatrix f_m, NumericVector mort, List dec_ls, NumericVector rho_vec, NumericMatrix c_learn, NumericVector g_forage, NumericVector c_forage, List W_nr, List istar_nr, int N_init, int tsim, double alpha, double beta, double comp) { //Note: //Here, state variables are in standard format double xc_state = (double) xc; //state //To use a state variable X as an INDEX, it must be an INTEGER, and X=X-1 xc = xc - 1; //Index //Book-keeping //Establish iniital variables required for the SDP int num_res = res_bs.size(); //How many decisions? Count columns on first decision matrix NumericMatrix dec_ex = dec_ls(0); //int num_dec = dec_ex.ncol(); int max_enc = f_m.nrow(); //Rows = encounters; Columns = resources //This is a state, not an index, so should equal cons_bs double xmax = (double) cons_bs; //Vectors for output IntegerVector pop_size(tsim); IntegerVector recruit_size(tsim); //OTHERS //Number of starting individuals int N = N_init; //Initialize the record-keeping of states //Record the state vector for each individual //Which of these individuals are alive (they all start out alive) IntegerVector alive(N); for (int n=0; n<N; n++) { alive(n) = 1; } int num_alive = sum(alive); //so num_alive = N at first //This records the energetic state of each individual... values will change over time IntegerVector state_v(N); for (int i=0; i<N; i++) { state_v(i) = xmax; //The initial state is full health } //Record the time vector for each individual IntegerVector time_v(N); for (int i=0; i<N; i++) { time_v(i) = 1; //tmax-1; } //Record the current resource for each individual IntegerVector res_v(N); for (int i=0; i<N; i++) { NumericVector rdraw_v = runif(1); double rdraw = as<double>(rdraw_v); //The initial resource is randomly drawn for each individual //Random draw is between 0 and num_res-1... so already 'indexed' res_v(i) = (int) floor(rdraw*(num_res)); } //What are the optimal decisions for the current individual-level states? IntegerVector dec_v(N); for (int i=0; i<N; i++) { //res_v is already indexed //state_v and time_v are states, not indices, so alter by -1 IntegerMatrix istar_t = istar_nr(res_v(i)); //Grab the istar for the focal resource dec_v(i) = istar_t(state_v(i)-1,time_v(i)-1); //Grab the decision for a given state and time t=0; } //TO EXPORT //Record initial pop size pop_size(0) = num_alive; recruit_size(0) = 0; List trophic_int(tsim); List energetic_state(tsim); List temporal_state(tsim); List decision_state(tsim); List fitness(tsim); trophic_int(0) = res_v; energetic_state(0) = state_v; temporal_state(0) = time_v; decision_state(0) = dec_v; NumericVector ind_fit(N); for (int i=0; i<N; i++) { NumericMatrix W_matrix = W_nr(res_v(i)); ind_fit(i) = W_matrix(state_v(i)-1,time_v(i)-1); } fitness(0) = ind_fit; Rcpp::Rcout << "I got here " << num_alive << std::endl; //Begin time iteration (this is the simulation time) //Sim time iterations stop at tsim - 1 for (int t=0; t<(tsim-1); t++) { //Rcpp::Rcout << "tsim = " << t << std::endl; //Book-keeping //Reset metrics (first iteration will be repetitive, but oh well) //How many individuals are currently alive? int N = num_alive; //Create vector to record reproductive events (1,0) IntegerVector rep_success(N); //To save the spawning stock biomass IntegerVector SSB_v(N); //To save the 'next' values for the energetic vector NumericVector x_next_rd(N); //To save the 'next' resouce consumed IntegerVector res_next(N); //To save the 'next' values for the time vector //IntegerVector t_next(N); //Individual fitness values NumericVector ind_fit(N); //Begin Individual iterations... Note: N will change with each t for (int n=0; n<N; n++) { //Rcpp::Rcout << "N = " << n << std::endl; //Define states for the individual //Current energetic state (state) int ind_x = state_v(n); //Current temporal state (state) //int ind_t = time_v(n); //Current (focal) resource (index) int ind_r = res_v(n); //Decision matrix associated with current resource (state) int ind_d = dec_v(n); //Reporting //Rcpp::Rcout << "n = " << n << std::endl; //Rcpp::Rcout << "ind_r = " << ind_r << std::endl; //Rcpp::Rcout << "ind_d = " << ind_d << std::endl; //Rcpp::Rcout << "ind_x = " << ind_x << std::endl; //REPRODUCTION //What is the probability that the individual will reproduce? double rep_prob = rep_gain(ind_x-1); //Does the individual reproduce in this timestep? //Take care of reproduction after n iterations... to include density dependence NumericVector rdraw_v = runif(1); double rdraw = as<double>(rdraw_v); if (rdraw < rep_prob) { rep_success(n) = 1; SSB_v(n) = ind_x; } else { rep_success(n) = 0; SSB_v(n) = 0; } //Longevity mortality + Stochastic mortality //If the individual has not reached it's max longevity int stochmort; if (time_v(n) < tmax-1) { double pr_stochmort = mort(ind_r); //ind_r is index already NumericVector rdraw_stochmort_v = runif(1); double rdraw_stochmort = as<double>(rdraw_stochmort_v); if (rdraw_stochmort < pr_stochmort) { //Individual dies stochmort = 1; } else { //Individual survives stochmort = 0; } } else { stochmort = 1; //All individuals that reach tmax die } //The following steps are only relevant for surviving individuals if (stochmort == 0) { //Choose next resource as a function of the preference probability distribution NumericMatrix pref_prob_m = dec_ls(ind_r); //ind_r is index already NumericVector pref_prob(num_res); IntegerVector pref_num(num_res); IntegerVector num_prob(num_res); for (int i=0;i<num_res; i++) { pref_prob(i) = pref_prob_m(i,ind_d-1); //The number of each 'resource index' to choose across //Zeros will screw this up pref_num(i) = (int) floor(pref_prob(i)*1000) + 1; //+1 to ensure no zeros } int tot_num = sum(pref_num); //The p_bin starts at 0 and ends at num_res-1... so it is already an index IntegerVector p_bin(tot_num); int tic = 0; for (int i=0; i<num_res; i++) { int num = pref_num(i); for (int j=0; j<num; j++) { p_bin(tic) = i; tic = tic + 1; } } NumericVector rdraw_v = runif(1); double rdraw = as<double>(rdraw_v); //Random draw between 0 and tot_num... int draw = (int) floor(rdraw*(tot_num)); //This defines the next resource (the index for the next resource) //NOTE: this is an index, as it has been for res res_next(n) = p_bin(draw); //How many of this resource is found? NumericVector k_prob(max_enc+1); IntegerVector k_num(max_enc+1); for (int i=0; i<(max_enc+1); i++) { //there are max_enc+1 indices k_prob(i) = f_m(i,res_next(n)); //res_next is already an index //Zeros will screw this up k_num(i) = (int) floor(k_prob(i)*1000) + 1; //+1 to ensure no zeros } tot_num = sum(k_num); IntegerVector k_bin(tot_num); tic = 0; //These k values are not 'k', but the k index //This index will grab the appropriate value in the rho vector for (int i=0; i<(max_enc+1); i++) { int num = k_num(i); for (int j=0; j<num; j++) { k_bin(tic) = i; tic = tic + 1; } } rdraw_v = runif(1); rdraw = as<double>(rdraw_v); draw = (int) floor(rdraw*tot_num); //This defines the index for the resource amt / rho int k = k_bin(draw); //What is the probability of catching the resource: rho_vec(k) //Rcpp::Rcout << "k= " << k << std::endl; //Must be k-1 because k is a state, and needs to be used as an index double rho = rho_vec(k-1); //Is the prey capture successfull? //Energetic dynamics rdraw_v = runif(1); double x_next; //state double d_ind_x = (double) ind_x; //double current state rdraw = as<double>(rdraw_v); if (rdraw < rho) { //If food is captured (res_next is an index) x_next = d_ind_x + g_forage(res_next(n)) - c_forage(res_next(n)); } else { //If food is not captured x_next = d_ind_x - c_forage(res_next(n)); } //Turn state x_next into nearest integer x_next_rd(n) = (double) round(x_next); //Boundary conditions and determine whether individual dies if (x_next_rd(n) < xc_state) { x_next_rd(n) = 0; alive(n) = 0; } //Rcpp::Rcout << "Made it here; t = " << t << std::endl; if (x_next_rd(n) > xmax) { x_next_rd(n) = xmax; alive(n) = 1; } //If individual suffers stochastic mortality } else { x_next_rd(n) = 0; alive(n) = 0; } //end stochmort if statement //Record individual fitness value NumericMatrix W_matrix = W_nr(res_next(n)); ind_fit(n) = W_matrix(x_next_rd(n)-1,time_v(n)-1); //Next individual time integer //Shouldn't matter if we advance time for dead individuals. Culling occurs later //t_next(n) = time_v(n) + 1; } //end individual iterations num_alive = sum(alive); //Density-dependent Reproduction :: TODO //Must add on new individuals to the current state vectors //This is the sum of biomass that is reproducing in this timestep //Regardless of mortality double SSB = sum(SSB_v); double recruitB = (alpha*SSB) / (1 + beta*pow(SSB,1/comp)); //The number of new individuals: Recruit biomass / mass of individual int num_recruits = (int) round(recruitB/xmax); //int num_recruits = 0; //Total individual count = surviving individuals + recruits int new_N = num_alive + num_recruits; //Rcpp::Rcout << "num_alive = " << num_alive << std::endl; //Rcpp::Rcout << "recruit = " << num_recruits << std::endl; //Rcpp::Rcout << "Total = " << new_N << std::endl; //Add on new individuals IntegerVector new_alive(new_N); IntegerVector new_state_v(new_N); IntegerVector new_res_v(new_N); IntegerVector new_dec_v(new_N); IntegerVector new_time_v(new_N); NumericVector new_ind_fit(new_N); //Transcribe over values for states at NEXT time interval if (num_alive > 0) { int tic = 0; for (int i=0; i<N; i++) { //only do this for surviving individuals if (alive(i) == 1) { new_alive(tic) = alive(i); new_state_v(tic) = x_next_rd(i); //state new_res_v(tic) = res_next(i); //index new_time_v(tic) = time_v(i) + 1; //advance time interval IntegerMatrix istar_t = istar_nr(new_res_v(tic)); //Grab the istar for the focal resource new_dec_v(tic) = istar_t(new_state_v(tic)-1,new_time_v(tic)-1); new_ind_fit(tic) = ind_fit(i); tic = tic + 1; } } } //Export metrics :: These are for surviving individuals (not counting recruits) //Distribution of individuals consuming each resource at time t trophic_int(t+1) = new_res_v; //Distribution of individual energetic states over time (distribution) energetic_state(t+1) = new_state_v; //Distribution of individuals at each ind_timestep at time t (distribution) temporal_state(t+1) = new_time_v; //Distribution of decisions at time t decision_state(t+1) = new_dec_v; //Distribution of fitness values at time t fitness(t+1) = new_ind_fit; //Exports //Initiate new values for recruits if (num_recruits > 0) { int tic = 0; //just for the rdraw_v index for (int i=num_alive; i<new_N; i++) { new_alive(i) = 1; //Recruits are all alive new_state_v(i) = xmax; //Initial energetic state is xmax new_time_v(i) = 1; //Randomly draw initial resource NumericVector rdraw_v = runif(1); double rdraw = as<double>(rdraw_v); new_res_v(i) = (int) floor(rdraw*(num_res)); IntegerMatrix istar_t = istar_nr(new_res_v(i)); //Grab the istar for the focal resource new_dec_v(i) = istar_t(new_state_v(i)-1,new_time_v(i)-1); //Grab the decision for a given state and time t=0; tic = tic + 1; } } //RESET //How many individuals are there? num_alive = sum(new_alive); //Redefine states only for alive individuals state_v = new_state_v; time_v = new_time_v; res_v = new_res_v; dec_v = new_dec_v; alive = new_alive; //EXPORT //Save variables pop_size(t+1) = num_alive; recruit_size(t+1) = num_recruits; } //end simulation time iterations List output(7); output(0) = pop_size; output(1) = energetic_state; output(2) = temporal_state; output(3) = decision_state; output(4) = trophic_int; output(5) = fitness; output(6) = recruit_size; //output(1) = ; return output; }
/* Function to run breadth-first search, returning only sets of connected components that reside on the boundary of the districts */ List bsearch_boundary(List aList, arma::vec boundary) { /* Inputs to function: aList: adjacency list boundary: vector of boundary element indicators (as arma) */ // Get indices of boundary units arma::uvec boundary_indices = find(boundary == 1); // Container - outputted of breadth search, a list List bsearch; // Container - partition vector, gets added to bsearch when queue is empty NumericVector partition; // Set mark vector - ledger of which indices have been reached NumericVector mark(aList.size()); // Set queue vector NumericVector q; // Initialize breadth search with first element in boundary_indices mark(boundary_indices(0)) = boundary_indices(0); partition.push_back(boundary_indices(0)); q = aList(boundary_indices(0)); // Initialize objects inside loop int u; bool in_part; NumericVector adj_u; int i; int v; // Begin do{} loop - run until number of elements in boundary_indices is 0 do{ // Begin while{} loop - run until q is empty while(q.size() > 0){ // Dequeue first element in queue u = q(0); // Mark that element in ledger mark(u) = u; // Check if element is in the partition - add to partition if false in_part = is_true(any(partition == u)); if(in_part == false){ partition.push_back(u); } // Get adjacency vector for unit u adj_u = aList(u); // Loop through elements of adj_u, add to queue and mark if not reached if(adj_u.size() > 0){ // Start loop for(i = 0; i < adj_u.size(); i++){ // Reach element v v = adj_u(i); /* Check if already reached - if false, mark, add to partition, and add to queue */ if(is_true(any(mark == v)) == FALSE){ mark(v) = v; partition.push_back(v); q.push_back(v); } } } // Erase dequeued element from queue when done searching q.erase(q.begin()); } // Handling an empty queue if(q.size() == 0){ /* First, find boundary units that are in the reached partition and remove them from boundary_units vector */ for(i = boundary_indices.n_elem - 1; i >= 0; i--){ if(is_true(any(partition == boundary_indices(i))) == TRUE){ boundary_indices.shed_row(i); } } // Store the partition, clear partition vector bsearch.push_back(partition); partition.erase(partition.begin(), partition.end()); // Re-initialize breadth search from new starting value if nonempty if(boundary_indices.n_elem > 0){ q = aList(boundary_indices(0)); mark(boundary_indices(0)) = boundary_indices(0); partition.push_back(boundary_indices(0)); } } }while(boundary_indices.n_elem > 0); // Get breadth search size int bsearch_size = bsearch.size(); // Get weight_boundary vector double weight_boundary = (double)countpartitions(aList) / bsearch_size; List out; out["bsearch"] = bsearch; out["npartitions"] = bsearch_size; out["weight_boundary"] = weight_boundary; return out; }
// [[Rcpp::export]] double g(NumericVector x) { return x.size(); }
// just an R interface to the coxfit routine, for regression testing purposes. SEXP cpp_coxfit(SEXP R_interface) { // --------------- // get R objects: // extract survival times R_interface = CDR(R_interface); SEXP R_survTimes = CAR(R_interface); // censoring status R_interface = CDR(R_interface); SEXP R_censInd = CAR(R_interface); // offsets R_interface = CDR(R_interface); SEXP R_offsets = CAR(R_interface); // design matrix R_interface = CDR(R_interface); SEXP R_X= CAR(R_interface); // and the tie method R_interface = CDR(R_interface); SEXP R_method = CAR(R_interface); // --------------- // unpack R objects: // survival times const NumericVector n_survTimes = R_survTimes; //const AVector survTimes(n_survTimes.begin(), n_survTimes.size(), // false); // errors with const and stuff... what if we copy into new memory? const AVector survTimes(n_survTimes.begin(), n_survTimes.size()); // censoring status const IntVector censInd = as<IntVector>(R_censInd); // offsets const AVector offsets = as<NumericVector>(R_offsets); // design matrix const NumericMatrix n_X = R_X; //const AMatrix X(n_X.begin(), n_X.nrow(), // n_X.ncol(), false); //Same issue as above L717:721 const AMatrix X(n_X.begin(), n_X.nrow(), n_X.ncol()); // tie method const int method = as<int>(R_method); // --------------- // assign remaining arguments for Coxfit const int nObs = survTimes.size(); const AVector weights = arma::ones<AVector>(nObs); // --------------- // get new Coxfit object Coxfit cox(survTimes, censInd, X, weights, offsets, method); // do the fitting const int nIter = cox.fit(); // get results: need to do that first! CoxfitResults fit = cox.finalizeAndGetResults(); // check results cox.checkResults(); // pack results into R list and return that return List::create(_["coef"] = fit.coefs, _["imat"] = fit.imat, _["loglik"] = fit.loglik, _["nIter"] = nIter); }
// [[Rcpp::export]] NumericVector cumsum3(NumericVector x) { NumericVector res(x.size()); std::partial_sum(x.begin(), x.end(), res.begin()); return res; }
//[[Rcpp::export]] List quasiTR(NumericVector start, Function fn, Function gr, const List control) { using Eigen::VectorXi; using Eigen::Map; typedef MatrixXd optHessType; typedef LLT<optHessType> optPrecondType; int nvars = start.size(); double rad = as<double>(control["start.trust.radius"]); const double min_rad = as<double>(control["stop.trust.radius"]); const double tol = as<double>(control["cg.tol"]); const double prec = as<double>(control["prec"]); const int report_freq = as<int>(control["report.freq"]); const int report_level = as<int>(control["report.level"]); const int report_precision = as<int>(control["report.precision"]); const int maxit = as<int>(control["maxit"]); const double contract_factor = as<double>(control["contract.factor"]); const double expand_factor = as<double>(control["expand.factor"]); const double contract_threshold = as<double>(control["contract.threshold"]); const double expand_threshold_rad = as<double>(control["expand.threshold.radius"]); const double expand_threshold_ap = as<double>(control["expand.threshold.ap"]); const double function_scale_factor = as<double>(control["function.scale.factor"]); const int precond_refresh_freq = as<int>(control["precond.refresh.freq"]); const int precond_ID = as<int>(control["preconditioner"]); const int quasi_newton_method = as<int>(control["quasi.newton.method"]); const int trust_iter = as<int>(control["trust.iter"]); std::string method_string; if (quasi_newton_method==1) { method_string = "SR1"; } else { method_string = "BFGS"; } Rfunc func(nvars, fn, gr); Map<VectorXd> startX(start.begin(),nvars); // Control parameters for optimizer Trust_CG_Optimizer<Map<VectorXd>, Rfunc, optHessType, optPrecondType> opt(func, startX, rad, min_rad, tol, prec, report_freq, report_level, report_precision, maxit, contract_factor, expand_factor, contract_threshold, expand_threshold_rad, expand_threshold_ap, function_scale_factor, precond_refresh_freq, precond_ID, quasi_newton_method, trust_iter); opt.run(); // collect results and return VectorXd P(nvars); VectorXd grad(nvars); // return sparse hessian information in CSC format double fval, radius; int iterations; MB_Status status; status = opt.get_current_state(P, fval, grad, iterations, radius); List res; res = List::create(Rcpp::Named("fval") = Rcpp::wrap(fval), Rcpp::Named("solution") = Rcpp::wrap(P), Rcpp::Named("gradient") = Rcpp::wrap(grad), Rcpp::Named("iterations") = Rcpp::wrap(iterations), Rcpp::Named("status") = Rcpp::wrap((std::string) MB_strerror(status)), Rcpp::Named("trust.radius") = Rcpp::wrap(radius), Rcpp::Named("method") = Rcpp::wrap(method_string), Rcpp::Named("hessian.update.method") = Rcpp::wrap(quasi_newton_method) ); return(res); }
NumericVector sqrtCpp(const NumericVector & orig) { NumericVector vec(orig.size()); // create a target vector of the same size std::transform(orig.begin(), orig.end(), vec.begin(), sqrt_double); return(vec); }
// [[Rcpp::export]] List wasserstein_auto_(NumericVector p_, NumericVector q_, NumericMatrix cost_matrix_, double epsilon, double desired_alpha){ // compute distance between p and q // p corresponds to the weights of a N-sample // each q corresponds to the weights of a M-sample // Thus cost_matrix must be a N x M cost matrix // epsilon is a regularization parameter, equal to 1/lambda in some references int N = p_.size(); int M = q_.size(); Map<VectorXd> p(as<Map<VectorXd> >(p_)); Map<VectorXd> q(as<Map<VectorXd> >(q_)); Map<MatrixXd> cost_matrix(as<Map<MatrixXd> >(cost_matrix_)); // avoid to take exp(k) when k is less than -500, // as K then contains zeros, and then the upcoming computations divide by zero MatrixXd K = (cost_matrix.array() * (-1./epsilon)); // K = exp(- M / epsilon) for (int i = 0; i < N; i++){ for (int j = 0; j < M; j++){ if (K(i,j) < -500){ K(i,j) = exp(-500); } else { K(i,j) = exp(K(i,j)); } } } MatrixXd K_transpose = K.transpose(); MatrixXd K_tilde = p.array().inverse().matrix().asDiagonal() * K; // diag(1/p) %*% K VectorXd u = VectorXd::Constant(N, 1./N); // VectorXd marginal1, marginal2; MatrixXd transportmatrix; VectorXd v; double alpha = 0; double beta = 0; int niterations_max = 1000; int iteration = 0; // for (int iteration = 0; iteration < niterations; iteration ++){ while ((iteration < niterations_max) and (alpha < desired_alpha)){ iteration ++; u = 1. / (K_tilde * (q.array() / (K_transpose * u).array()).matrix()).array(); if (iteration % 10 == 1){ // check if criterion is satisfied v = q.array() / (K_transpose * u).array(); transportmatrix = u.col(0).asDiagonal() * K * v.col(0).asDiagonal(); marginal1 = transportmatrix.rowwise().sum(); marginal2 = transportmatrix.colwise().sum(); alpha = 10; for (int i = 0; i < N; i++){ beta = std::min(p(i) / marginal1(i), q(i) / marginal2(i)); alpha = std::min(alpha, beta); } // cerr << "alpha = " << alpha << endl; } } v = q.array() / (K_transpose * u).array(); // compute the optimal transport matrix between p and the first q transportmatrix = u.col(0).asDiagonal() * K * v.col(0).asDiagonal(); // MatrixXd uXIv = u.array() * ((K.array() * cost_matrix.array()).matrix() * v).array(); // NumericVector d = wrap(uXIv.colwise().sum()); return List::create(Named("transportmatrix") = wrap(transportmatrix), Named("u") = wrap(u), Named("v") = wrap(v), Named("iteration") = iteration); }
// [[Rcpp::depends(RcppArmadillo)]] // [[Rcpp::export]] List inseq(mat M, bool adjust=true) { int i, m, trun; mat mu=mean(M); //center the rows M.each_row() -= mu; int n=M.n_rows, p=M.n_cols; //Dtm is the vector of det(Sig)'s NumericVector Dtm; //gam_0 and gam_1 are for gam_2m and gam_2m+1, resp. mat gam0(p,p), gam1(p,p), Gam(p,p), Sig(p,p), Sig1(p,p), Gamadj(p,p), eigvec(p,p); //for adjustment, set initial increment in Gam=0 Gamadj.zeros(); //store the eigenvalues and eigenvectors of each Gam vec eigval(p),eigvalneg(p); double dtm; int sn= n/2; for (m=0; m<n/2; m++) { gam0.zeros(); gam1.zeros(); //calculate gam_2m (gam0) and gam_2m+1 (gam1) for(i=0; i<(n-2*m);i++) gam0+=trans(M.row(i))*M.row(i+2*m); gam0=gam0/n; for(i=0; i<(n-2*m-1);i++) gam1+=trans(M.row(i))*M.row(i+2*m+1); gam1=gam1/n; //Gam_m=gam_2m+gam_2m+1, then symmetrize Gam=gam0+gam1; Gam=(Gam+Gam.t())/2; if (m==0) Sig=-gam0+2*Gam; else Sig=Sig+2*Gam; if (eig_sym(Sig)(0)>0) { sn=m; break; } } if (sn>n/2-1) { stop("Not enough samples."); } Dtm=det(Sig); for (m=sn+1; m<n/2; m++) { gam0.zeros(); gam1.zeros(); //calculate gam_2m (gam0) and gam_2m+1 (gam1) for(i=0; i<(n-2*m);i++) gam0+=trans(M.row(i))*M.row(i+2*m); gam0=gam0/n; for(i=0; i<(n-2*m-1);i++) gam1+=trans(M.row(i))*M.row(i+2*m+1); gam1=gam1/n; //Gam_m=gam_2m+gam_2m+1, then symmetrize Gam=gam0+gam1; Gam=(Gam+Gam.t())/2; //Sig_m=Sig_m-1+2Gam_m Sig1=Sig+2*Gam; dtm=det(Sig1); //if dtm1>dtm, continue if (dtm<=Dtm(m-sn-1)) break; //update Sig Sig=Sig1; //record dtm Dtm.push_back(dtm); //to adjust the original Sig, subtract the negative part of Gam if (adjust) { //calculate eigenvalues and eigenvectors of Gam eig_sym(eigval,eigvec,Gam); eigvalneg=eigval; eigvalneg.elem(find(eigvalneg>0)).zeros(); Gamadj-=eigvec*diagmat(eigvalneg)*eigvec.t(); } } trun = Dtm.size()-1+sn; List res; res["Sig"]=Sig; res["Dtm"]=Dtm; res["trunc"]= trun; res["sn"]=sn; if (adjust) res["Sigadj"]=Sig+2*Gamadj; return res; }
// [[Rcpp::export]] List rocUtilsPerfsAllC(NumericVector thresholds, NumericVector controls, NumericVector cases, std::string direction) { NumericVector se(thresholds.size()); NumericVector sp(thresholds.size()); long tp, tn; long i; // iterator over cases & controls if (direction == ">") { for (long t = 0; t < thresholds.size(); t++) { if (t % 100 == 0) Rcpp::checkUserInterrupt(); double threshold = thresholds(t); tp = 0; for (i = 0; i < cases.size(); i++) { if (cases(i) <= threshold) { tp++; } } se(t) = (double)tp / cases.size(); tn = 0; for (i = 0; i < controls.size(); i++) { if (controls(i) > threshold) { tn++; } } sp(t) = (double)tn / controls.size(); } } else { for (long t = 0; t < thresholds.size(); t++) { if (t % 100 == 0) Rcpp::checkUserInterrupt(); double threshold = thresholds(t); tp = 0; for (i = 0; i < cases.size(); i++) { if (cases(i) >= threshold) { tp++; } } se(t) = (double)tp / cases.size(); long tn = 0; for (i = 0; i < controls.size(); i++) { if (controls(i) < threshold) { tn++; } } sp(t) = (double)tn / controls.size(); } } List ret; ret["se"] = se; ret["sp"] = sp; return(ret); }
SEXP cpp_sampleGlm(SEXP r_interface) { // ---------------------------------------------------------------------------------- // extract arguments // ---------------------------------------------------------------------------------- r_interface = CDR(r_interface); List rcpp_model(CAR(r_interface)); r_interface = CDR(r_interface); List rcpp_data(CAR(r_interface)); r_interface = CDR(r_interface); List rcpp_fpInfos(CAR(r_interface)); r_interface = CDR(r_interface); List rcpp_ucInfos(CAR(r_interface)); r_interface = CDR(r_interface); List rcpp_fixInfos(CAR(r_interface)); r_interface = CDR(r_interface); List rcpp_distribution(CAR(r_interface)); r_interface = CDR(r_interface); List rcpp_searchConfig(CAR(r_interface)); r_interface = CDR(r_interface); List rcpp_options(CAR(r_interface)); r_interface = CDR(r_interface); List rcpp_marginalz(CAR(r_interface)); // ---------------------------------------------------------------------------------- // unpack the R objects // ---------------------------------------------------------------------------------- // data: const NumericMatrix n_x = rcpp_data["x"]; const AMatrix x(n_x.begin(), n_x.nrow(), n_x.ncol()); const NumericMatrix n_xCentered = rcpp_data["xCentered"]; const AMatrix xCentered(n_xCentered.begin(), n_xCentered.nrow(), n_xCentered.ncol()); const NumericVector n_y = rcpp_data["y"]; const AVector y(n_y.begin(), n_y.size()); const IntVector censInd = as<IntVector>(rcpp_data["censInd"]); // FP configuration: // vector of maximum fp degrees const PosIntVector fpmaxs = as<PosIntVector>(rcpp_fpInfos["fpmaxs"]); // corresponding vector of fp column indices const PosIntVector fppos = rcpp_fpInfos["fppos"]; // corresponding vector of power set cardinalities const PosIntVector fpcards = rcpp_fpInfos["fpcards"]; // names of fp terms const StrVector fpnames = rcpp_fpInfos["fpnames"]; // UC configuration: const PosIntVector ucIndices = rcpp_ucInfos["ucIndices"]; List rcpp_ucColList = rcpp_ucInfos["ucColList"]; std::vector<PosIntVector> ucColList; for (R_len_t i = 0; i != rcpp_ucColList.length(); ++i) { ucColList.push_back(as<PosIntVector>(rcpp_ucColList[i])); } // fixed covariate configuration: const PosIntVector fixIndices = rcpp_fixInfos["fixIndices"]; List rcpp_fixColList = rcpp_fixInfos["fixColList"]; std::vector<PosIntVector> fixColList; for (R_len_t i = 0; i != rcpp_fixColList.length(); ++i) { fixColList.push_back(as<PosIntVector>(rcpp_fixColList[i])); } // distributions info: const double nullModelLogMargLik = as<double>(rcpp_distribution["nullModelLogMargLik"]); const double nullModelDeviance = as<double>(rcpp_distribution["nullModelDeviance"]); S4 rcpp_gPrior = rcpp_distribution["gPrior"]; List rcpp_family = rcpp_distribution["family"]; const bool tbf = as<bool>(rcpp_distribution["tbf"]); const bool doGlm = as<bool>(rcpp_distribution["doGlm"]); const double empiricalMean = as<double>(rcpp_distribution["yMean"]); const bool empiricalgPrior = as<bool>(rcpp_distribution["empiricalgPrior"]); // model search configuration: const bool useFixedc = as<bool>(rcpp_searchConfig["useFixedc"]); // options: const bool estimateMargLik = as<bool>(rcpp_options["estimateMargLik"]); const bool verbose = as<bool>(rcpp_options["verbose"]); const bool debug = as<bool>(rcpp_options["debug"]); const bool isNullModel = as<bool>(rcpp_options["isNullModel"]); const bool useFixedZ = as<bool>(rcpp_options["useFixedZ"]); const double fixedZ = as<double>(rcpp_options["fixedZ"]); #ifdef _OPENMP const bool useOpenMP = as<bool>(rcpp_options["useOpenMP"]); #endif S4 rcpp_mcmc = rcpp_options["mcmc"]; const PosInt iterations = rcpp_mcmc.slot("iterations"); const PosInt burnin = rcpp_mcmc.slot("burnin"); const PosInt step = rcpp_mcmc.slot("step"); // z density stuff: const RFunction logMarginalZdens(as<SEXP>(rcpp_marginalz["logDens"])); const RFunction marginalZgen(as<SEXP>(rcpp_marginalz["gen"])); // ---------------------------------------------------------------------------------- // further process arguments // ---------------------------------------------------------------------------------- // data: // only the intercept is always included, that is fixed, in the model IntSet fixedCols; fixedCols.insert(1); // totalnumber is set to 0 because we do not care about it. const DataValues data(x, xCentered, y, censInd, 0, fixedCols); // FP configuration: const FpInfo fpInfo(fpcards, fppos, fpmaxs, fpnames, x); // UC configuration: // determine sizes of the UC groups, and the total size == maximum size reached together by all // UC groups. PosIntVector ucSizes; PosInt maxUcDim = 0; for (std::vector<PosIntVector>::const_iterator cols = ucColList.begin(); cols != ucColList.end(); ++cols) { PosInt thisSize = cols->size(); maxUcDim += thisSize; ucSizes.push_back(thisSize); } const UcInfo ucInfo(ucSizes, maxUcDim, ucIndices, ucColList); // fix configuration: // determine sizes of the fix groups, and the total size == maximum size reached together by all // UC groups. PosIntVector fixSizes; PosInt maxFixDim = 0; for (std::vector<PosIntVector>::const_iterator cols = fixColList.begin(); cols != fixColList.end(); ++cols) { PosInt thisSize = cols->size(); maxFixDim += thisSize; fixSizes.push_back(thisSize); } const FixInfo fixInfo(fixSizes, maxFixDim, fixIndices, fixColList); // model configuration: GlmModelConfig config(rcpp_family, nullModelLogMargLik, nullModelDeviance, exp(fixedZ), rcpp_gPrior, data.response, debug, useFixedc, empiricalMean, empiricalgPrior); // model config/info: const Model thisModel(ModelPar(rcpp_model["configuration"], fpInfo), GlmModelInfo(as<List>(rcpp_model["information"]))); // the options const Options options(estimateMargLik, verbose, debug, isNullModel, useFixedZ, tbf, doGlm, iterations, burnin, step); // marginal z stuff const MarginalZ marginalZ(logMarginalZdens, marginalZgen); // use only one thread if we do not want to use openMP. #ifdef _OPENMP if(! useOpenMP) { omp_set_num_threads(1); } else { omp_set_num_threads(omp_get_num_procs()); } #endif // ---------------------------------------------------------------------------------- // prepare the sampling // ---------------------------------------------------------------------------------- Fitter fitter; int nCoefs; if(options.doGlm) { // construct IWLS object, which can be used for all IWLS stuff, // and also contains the design matrix etc fitter.iwlsObject = new Iwls(thisModel.par, data, fpInfo, ucInfo, fixInfo, config, config.linPredStart, options.useFixedZ, EPS, options.debug, options.tbf); nCoefs = fitter.iwlsObject->nCoefs; // check that we have the same answer about the null model as R //assert(fitter.iwlsObject->isNullModel == options.isNullModel); if(fitter.iwlsObject->isNullModel != options.isNullModel){ Rcpp::stop("sampleGlm.cpp:cpp_sampleGlm: isNullModel != options.isNullModel"); } } else { AMatrix design = getDesignMatrix(thisModel.par, data, fpInfo, ucInfo, fixInfo, false); fitter.coxfitObject = new Coxfit(data.response, data.censInd, design, config.weights, config.offsets, 1); // the number of coefficients (here it does not include the intercept!!) nCoefs = design.n_cols; // check that we do not have a null model here: // assert(nCoefs > 0); if(nCoefs <= 0){ Rcpp::stop("sampleGlm.cpp:cpp_sampleGlm: nCoefs <= 0"); } } // allocate sample container Samples samples(nCoefs, options.nSamples); // count how many proposals we have accepted: PosInt nAccepted(0); // at what z do we start? double startZ = useFixedZ ? fixedZ : thisModel.info.zMode; // start container with current things Mcmc now(marginalZ, data.nObs, nCoefs); if(doGlm) { // get the mode for beta given the mode of the approximated marginal posterior as z // if TBF approach is used, this will be the only time the IWLS is used, // because we only need the MLE and the Cholesky factor of its // precision matrix estimate, which do not depend on z. PosInt iwlsIterations = fitter.iwlsObject->startWithNewLinPred(40, // this is the corresponding g exp(startZ), // and the start value for the linear predictor is taken from the Glm model config config.linPredStart); // echo debug-level message? if(options.debug) { Rprintf("\ncpp_sampleGlm: Initial IWLS for high density point finished after %d iterations", iwlsIterations); } // this is the current proposal info: now.proposalInfo = fitter.iwlsObject->getResults(); // and this is the current parameters sample: now.sample = Parameter(now.proposalInfo.coefs, startZ); if(options.tbf) { // we will not compute this in the TBF case: now.logUnPosterior = R_NaReal; // start to compute the variance of the intercept parameter: // here the inverse cholesky factor of the precision matrix will // be stored. First, it's the identity matrix. AMatrix inverseQfactor = arma::eye(now.proposalInfo.qFactor.n_rows, now.proposalInfo.qFactor.n_cols); // do the inversion trs(false, false, now.proposalInfo.qFactor, inverseQfactor); // now we can compute the variance of the intercept estimate: const AVector firstCol = inverseQfactor.col(0); const double interceptVar = arma::dot(firstCol, firstCol); // ok, now alter the qFactor appropriately to reflect the // independence assumption between the intercept estimate // and the other coefficients estimates now.proposalInfo.qFactor.col(0) = arma::zeros<AVector>(now.proposalInfo.qFactor.n_rows); now.proposalInfo.qFactor(0, 0) = sqrt(1.0 / interceptVar); } else { // compute the (unnormalized) log posterior of the proposal now.logUnPosterior = fitter.iwlsObject->computeLogUnPosteriorDens(now.sample); } } else { PosInt coxfitIterations = fitter.coxfitObject->fit(); CoxfitResults coxResults = fitter.coxfitObject->finalizeAndGetResults(); fitter.coxfitObject->checkResults(); // echo debug-level message? if(options.debug) { Rprintf("\ncpp_sampleGlm: Cox fit finished after %d iterations", coxfitIterations); } // we will not compute this in the TBF case: now.logUnPosterior = R_NaReal; // compute the Cholesky factorization of the covariance matrix int info = potrf(false, coxResults.imat); // check that all went well if(info != 0) { std::ostringstream stream; stream << "dpotrf(coxResults.imat) got error code " << info << "in sampleGlm"; throw std::domain_error(stream.str().c_str()); } // compute the precision matrix, using the Cholesky factorization // of the covariance matrix now.proposalInfo.qFactor = arma::eye(now.proposalInfo.qFactor.n_rows, now.proposalInfo.qFactor.n_cols); info = potrs(false, coxResults.imat, now.proposalInfo.qFactor); // check that all went well if(info != 0) { std::ostringstream stream; stream << "dpotrs(coxResults.imat, now.proposalInfo.qFactor) got error code " << info << "in sampleGlm"; throw std::domain_error(stream.str().c_str()); } // compute the Cholesky factorization of the precision matrix info = potrf(false, now.proposalInfo.qFactor); // check that all went well if(info != 0) { std::ostringstream stream; stream << "dpotrf(now.proposalInfo.qFactor) got error code " << info << "in sampleGlm"; throw std::domain_error(stream.str().c_str()); } // the MLE of the coefficients now.proposalInfo.coefs = coxResults.coefs; } // so the parameter object "now" is then also the high density point // required for the marginal likelihood estimate: const Mcmc highDensityPoint(now); // we accept this starting value, so initialize "old" with the same ones Mcmc old(now); // ---------------------------------------------------------------------------------- // start sampling // ---------------------------------------------------------------------------------- // echo debug-level message? if(options.debug) { if(tbf) { Rprintf("\ncpp_sampleGlm: Starting MC simulation"); } else { Rprintf("\ncpp_sampleGlm: Starting MCMC loop"); } } // i_iter starts at 1 !! for(PosInt i_iter = 1; i_iter <= options.iterations; ++i_iter) { // echo debug-level message? if(options.debug) { Rprintf("\ncpp_sampleGlm: Starting iteration no. %d", i_iter); } // ---------------------------------------------------------------------------------- // store the proposal // ---------------------------------------------------------------------------------- // sample one new log covariance factor z (other arguments than 1 are not useful // with the current setup of the RFunction wrapper class) now.sample.z = marginalZ.gen(1); if(options.tbf) { if(options.isNullModel) { // note that we do not encounter this in the Cox case // assert(options.doGlm); if(!options.doGlm){ Rcpp::stop("sampleGlm.cpp:cpp_sampleGlm: options.doGlm should be TRUE"); } // draw the proposal coefs, which is here just the intercept now.sample.coefs = drawNormalVector(now.proposalInfo.coefs, now.proposalInfo.qFactor); } else { // here we have at least one non-intercept coefficient // get vector from N(0, I) AVector w = drawNormalVariates(now.proposalInfo.coefs.n_elem, 0.0, 1.0); // then solve L' * ret = w, and overwrite w with the result: trs(false, true, now.proposalInfo.qFactor, w); // compute the shrinkage factor t = g / (g + 1) const double g = exp(now.sample.z); //Previously used g directly, but if g=inf we need to use the limit // const double shrinkFactor = g / (g + 1.0); const double shrinkFactor = isinf(g) ? 1 : g / (g + 1.0); // scale the variance of the non-intercept coefficients // with this factor. // In the Cox case: no intercept present, so scale everything int startCoef = options.doGlm ? 1 : 0; w.rows(startCoef, w.n_rows - 1) *= sqrt(shrinkFactor); // also scale the mean of the non-intercept coefficients // appropriately: // In the Cox case: no intercept present, so scale everything now.sample.coefs = now.proposalInfo.coefs; now.sample.coefs.rows(startCoef, now.sample.coefs.n_rows - 1) *= shrinkFactor; // so altogether we have: now.sample.coefs += w; } ++nAccepted; } else // the generalized hyper-g prior case { // do 1 IWLS step, starting from the last linear predictor and the new z // (here the return value is not very interesting, as it must be 1) fitter.iwlsObject->startWithNewCoefs(1, exp(now.sample.z), now.sample.coefs); // get the results now.proposalInfo = fitter.iwlsObject->getResults(); // draw the proposal coefs: now.sample.coefs = drawNormalVector(now.proposalInfo.coefs, now.proposalInfo.qFactor); // compute the (unnormalized) log posterior of the proposal now.logUnPosterior = fitter.iwlsObject->computeLogUnPosteriorDens(now.sample); // ---------------------------------------------------------------------------------- // get the reverse jump normal density // ---------------------------------------------------------------------------------- // copy the old Mcmc object Mcmc reverse(old); // do again 1 IWLS step, starting from the sampled linear predictor and the old z fitter.iwlsObject->startWithNewCoefs(1, exp(reverse.sample.z), now.sample.coefs); // get the results for the reverse jump Gaussian: // only the proposal has changed in contrast to the old container, // the sample stays the same! reverse.proposalInfo = fitter.iwlsObject->getResults(); // ---------------------------------------------------------------------------------- // compute the proposal density ratio // ---------------------------------------------------------------------------------- // first the log of the numerator, i.e. log(f(old | new)): double logProposalRatioNumerator = reverse.computeLogProposalDens(); // second the log of the denominator, i.e. log(f(new | old)): double logProposalRatioDenominator = now.computeLogProposalDens(); // so the log proposal density ratio is double logProposalRatio = logProposalRatioNumerator - logProposalRatioDenominator; // ---------------------------------------------------------------------------------- // compute the posterior density ratio // ---------------------------------------------------------------------------------- double logPosteriorRatio = now.logUnPosterior - old.logUnPosterior; // ---------------------------------------------------------------------------------- // accept or reject proposal // ---------------------------------------------------------------------------------- double acceptanceProb = exp(logPosteriorRatio + logProposalRatio); if(unif() < acceptanceProb) { old = now; ++nAccepted; } else { now = old; } } // ---------------------------------------------------------------------------------- // store the sample? // ---------------------------------------------------------------------------------- // if the burnin was passed and we are at a multiple of step beyond that, then store // the sample. if((i_iter > options.burnin) && (((i_iter - options.burnin) % options.step) == 0)) { // echo debug-level message if(options.debug) { Rprintf("\ncpp_sampleGlm: Storing samples of iteration no. %d", i_iter); } // store the current parameter sample samples.storeParameters(now.sample); // ---------------------------------------------------------------------------------- // compute marginal likelihood terms // ---------------------------------------------------------------------------------- // compute marginal likelihood terms and save them? // (Note that the tbf bool is just for safety here, // the R function sampleGlm will set estimateMargLik to FALSE // when tbf is TRUE.) if(options.estimateMargLik && (! options.tbf)) { // echo debug-level message? if(options.debug) { Rprintf("\ncpp_sampleGlm: Compute marginal likelihood estimation terms"); } // ---------------------------------------------------------------------------------- // compute next term for the denominator // ---------------------------------------------------------------------------------- // draw from the high density point proposal distribution Mcmc denominator(highDensityPoint); denominator.sample.z = marginalZ.gen(1); fitter.iwlsObject->startWithNewLinPred(1, exp(denominator.sample.z), highDensityPoint.proposalInfo.linPred); denominator.proposalInfo = fitter.iwlsObject->getResults(); denominator.sample.coefs = drawNormalVector(denominator.proposalInfo.coefs, denominator.proposalInfo.qFactor); // get posterior density of the sample denominator.logUnPosterior = fitter.iwlsObject->computeLogUnPosteriorDens(denominator.sample); // get the proposal density at the sample double denominator_logProposalDensity = denominator.computeLogProposalDens(); // then the reverse stuff: // first we copy again the high density point Mcmc revDenom(highDensityPoint); // but choose the new sampled coefficients as starting point fitter.iwlsObject->startWithNewCoefs(1, exp(revDenom.sample.z), denominator.sample.coefs); revDenom.proposalInfo = fitter.iwlsObject->getResults(); // so the reverse proposal density is double revDenom_logProposalDensity = revDenom.computeLogProposalDens(); // so altogether the next term for the denominator is the following acceptance probability double denominatorTerm = denominator.logUnPosterior - highDensityPoint.logUnPosterior + revDenom_logProposalDensity - denominator_logProposalDensity; denominatorTerm = exp(fmin(0.0, denominatorTerm)); // ---------------------------------------------------------------------------------- // compute next term for the numerator // ---------------------------------------------------------------------------------- // compute the proposal density of the current sample starting from the high density point Mcmc numerator(now); fitter.iwlsObject->startWithNewLinPred(1, exp(numerator.sample.z), highDensityPoint.proposalInfo.linPred); numerator.proposalInfo = fitter.iwlsObject->getResults(); double numerator_logProposalDensity = numerator.computeLogProposalDens(); // then compute the reverse proposal density of the high density point when we start from the current // sample Mcmc revNum(highDensityPoint); fitter.iwlsObject->startWithNewCoefs(1, exp(revNum.sample.z), now.sample.coefs); revNum.proposalInfo = fitter.iwlsObject->getResults(); double revNum_logProposalDensity = revNum.computeLogProposalDens(); // so altogether the next term for the numerator is the following guy: double numeratorTerm = exp(fmin(revNum_logProposalDensity, highDensityPoint.logUnPosterior - now.logUnPosterior + numerator_logProposalDensity)); // ---------------------------------------------------------------------------------- // finally store both terms // ---------------------------------------------------------------------------------- samples.storeMargLikTerms(numeratorTerm, denominatorTerm); } } // ---------------------------------------------------------------------------------- // echo progress? // ---------------------------------------------------------------------------------- // echo debug-level message? if(options.debug) { Rprintf("\ncpp_sampleGlm: Finished iteration no. %d", i_iter); } if((i_iter % std::max(static_cast<int>(options.iterations / 100), 1) == 0) && options.verbose) { // display computation progress at each percent Rprintf("-"); } // end echo progress } // end MCMC loop // echo debug-level message? if(options.debug) { if(tbf) { Rprintf("\ncpp_sampleGlm: Finished MC simulation"); } else { Rprintf("\ncpp_sampleGlm: Finished MCMC loop"); } } // ---------------------------------------------------------------------------------- // build up return list for R and return that. // ---------------------------------------------------------------------------------- return List::create(_["samples"] = samples.convert2list(), _["nAccepted"] = nAccepted, _["highDensityPointLogUnPosterior"] = highDensityPoint.logUnPosterior); } // end cpp_sampleGlm
// [[Rcpp::export]] List or_gdp_em(NumericVector ryo, NumericMatrix rxo, SEXP ralpha, SEXP reta){ //Define Variables// int p=rxo.ncol(); int no=rxo.nrow(); double eta=Rcpp::as<double >(reta); double alpha=Rcpp::as<double >(ralpha); //Create Data// arma::mat xo(rxo.begin(), no, p, false); arma::colvec yo(ryo.begin(), ryo.size(), false); yo-=mean(yo); //Pre-Processing// Col<double> xoyo=xo.t()*yo; Col<double> B=xoyo/no; Col<double> Babs=abs(B); Mat<double> xoxo=xo.t()*xo; Mat<double> D=eye(p,p); Mat<double> Ip=eye(p,p); double yoyo=dot(yo,yo); double deltaB; double deltaphi; double phi=no/dot(yo-xo*B,yo-xo*B); double lp; //Create Trace Matrices Mat<double> B_trace(p,20000); Col<double> phi_trace(20000); Col<double> lpd_trace(20000); //Run EM Algorithm// cout << "Beginning EM Algorithm" << endl; int t=0; B_trace.col(t)=B; phi_trace(t)=phi; lpd_trace(t)=or_gdp_log_posterior_density(no,p,alpha,eta,yo,xo,B,phi); do{ t=t+1; Babs=abs(B); D=diagmat(sqrt(((eta+sqrt(phi)*Babs)%(sqrt(phi)*Babs))/(alpha+1))); B=D*solve(D*xoxo*D+Ip,D*xoyo); phi=(no+p-3)/(yoyo-dot(xoyo,B)); //Store Values// B_trace.col(t)=B; phi_trace(t)=phi; lpd_trace(t)=or_gdp_log_posterior_density(no,p,alpha,eta,yo,xo,B,phi); deltaB=dot(B_trace.col(t)-B_trace.col(t-1),B_trace.col(t)-B_trace.col(t-1)); deltaphi=phi_trace(t)-phi_trace(t-1); } while((deltaB>0.00001 || deltaphi>0.00001) && t<19999); cout << "EM Algorithm Converged in " << t << " Iterations" << endl; //Resize Trace Matrices// B_trace.resize(p,t); phi_trace.resize(t); lpd_trace.resize(t); return Rcpp::List::create( Rcpp::Named("B") = B, Rcpp::Named("B_trace") = B_trace, Rcpp::Named("phi") = phi, Rcpp::Named("phi_trace") = phi_trace, Rcpp::Named("lpd_trace") = lpd_trace ) ; }
//[[Rcpp::export]] List sparseTR(NumericVector start, Function fn, Function gr, Function hs, const List control) { // use this version when the user supplies his own Hessian function. // Hessian function must return a Matrix of class dgCMatrix using Eigen::VectorXi; using Eigen::Map; typedef SparseMatrix<double> optHessType; typedef SimplicialLLT<optHessType> optPrecondType; int nvars = start.size(); if (nvars<=0) throw MyException("Number of variables (starting values) must be positive\n",__FILE__, __LINE__); // Control parameters for optimizer double rad = as<double>(control["start.trust.radius"]); const double min_rad = as<double>(control["stop.trust.radius"]); const double tol = as<double>(control["cg.tol"]); const double prec = as<double>(control["prec"]); const int report_freq = as<int>(control["report.freq"]); const int report_level = as<int>(control["report.level"]); const int report_precision = as<int>(control["report.precision"]); const int maxit = as<int>(control["maxit"]); const double contract_factor = as<double>(control["contract.factor"]); const double expand_factor = as<double>(control["expand.factor"]); const double contract_threshold = as<double>(control["contract.threshold"]); const double expand_threshold_rad = as<double>(control["expand.threshold.radius"]); const double expand_threshold_ap = as<double>(control["expand.threshold.ap"]); const double function_scale_factor = as<double>(control["function.scale.factor"]); const int precond_refresh_freq = as<int>(control["precond.refresh.freq"]); const int precond_ID = as<int>(control["preconditioner"]); const int trust_iter = as<int>(control["trust.iter"]); Map<VectorXd> startX(start.begin(),nvars); Rcpp::S4 sh_ = hs(startX); Map<SparseMatrix<double> > sh = Rcpp::as<Map<SparseMatrix<double>>>(sh_); int nnz = (sh.nonZeros() + nvars)/2; RfuncHess func(nvars, nnz, fn, gr, hs); Trust_CG_Sparse<Map<VectorXd>, RfuncHess,optHessType, optPrecondType> opt(func, startX, rad, min_rad, tol, prec, report_freq, report_level, report_precision, maxit, contract_factor, expand_factor, contract_threshold, expand_threshold_rad, expand_threshold_ap, function_scale_factor, precond_refresh_freq, precond_ID, trust_iter); opt.run(); // collect results and return VectorXd P(nvars); VectorXd grad(nvars); optHessType hess(nvars,nvars); hess.reserve(nnz); double fval, radius; int iterations; MB_Status status; status = opt.get_current_state(P, fval, grad, hess, iterations, radius); List res; res = List::create(Rcpp::Named("fval") = Rcpp::wrap(fval), Rcpp::Named("solution") = Rcpp::wrap(P), Rcpp::Named("gradient") = Rcpp::wrap(grad), Rcpp::Named("hessian") = Rcpp::wrap(hess), Rcpp::Named("iterations") = Rcpp::wrap(iterations), Rcpp::Named("status") = Rcpp::wrap((std::string) MB_strerror(status)), Rcpp::Named("trust.radius") = Rcpp::wrap(radius), Rcpp::Named("nnz") = Rcpp::wrap(nnz), Rcpp::Named("method") = Rcpp::wrap("Sparse") ); return(res); }
//' Simulates the model when it is written as a C++ function using stl containers //' @export // [[Rcpp::export]] NumericMatrix ida_Cpp_stl(NumericVector times, NumericVector states_, NumericVector derivatives_, NumericVector parameters_, List forcings_data_, List settings, SEXP model_, SEXP jacobian_) { // Wrap the pointer to the model function with the correct signature dae_in_Cpp_stl* model = (dae_in_Cpp_stl *) R_ExternalPtrAddr(model_); // Wrap the pointer to the jacobian function with the correct signature jac_in_Cpp_stl* jacobian = nullptr; if(as<int>(settings["jacobian"]) == 1) jacobian = (jac_in_Cpp_stl *) R_ExternalPtrAddr(jacobian_); // Store all inputs in the data struct, prior conversion to stl and Armadillo classes int neq = states_.size(); vector<double> parameters{as<vector<double>>(parameters_)}; vector<double> states{as<vector<double>>(states_)}; vector<double> derivatives{as<vector<double>>(derivatives_)}; vector<mat> forcings_data(forcings_data_.size()); if(forcings_data_.size() > 0) for(int i = 0; i < forcings_data_.size(); i++) forcings_data[i] = as<mat>(forcings_data_[i]); data_ida_Cpp_stl data_model{parameters, forcings_data, neq, model, jacobian}; /* * Initialize IDA and pass all initial inputs * */ N_Vector y = nullptr; y = N_VNew_Serial(neq); for(int i = 0; i < neq; i++) { NV_Ith_S(y,i) = states[i]; } N_Vector yp = nullptr; yp = N_VNew_Serial(neq); for(int i = 0; i < neq; i++) { NV_Ith_S(yp,i) = derivatives[i]; } void *ida_mem = IDACreate(); // Shut up Sundials (errors not printed to the screen) int flag = IDASetErrFile(ida_mem, NULL); if(flag < 0.0) { if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);} if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);} ::Rf_error("Error in the IDASetErrFile function"); } // Initialize the Sundials solver. Here we pass initial N_Vector, the interface function and the initial time flag = IDAInit(ida_mem, ida_to_Cpp_stl, times[0], y, yp); if(flag < 0.0) { if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);} if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);} ::Rf_error("Error in the IDAInit function"); } // Tell Sundials the tolerance settings for error control flag = IDASStolerances(ida_mem, settings["rtol"], settings["atol"]); if(flag < 0.0) { if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);} if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);} ::Rf_error("Error in the IDASStolerances function"); } // Tell Sundials the number of state variables, so that I can allocate memory for the Jacobian flag = IDADense(ida_mem, neq); if(flag < 0.0) { if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);} if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);} ::Rf_error("Error in the IDADense function"); } // Give Sundials a pointer to the struct where all the user data is stored. It will be passed (untouched) to the interface as void pointer flag = IDASetUserData(ida_mem, &data_model); if(flag < 0.0) { if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);} if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);} ::Rf_error("Error in the IDASetUserData function"); } // Correct initial values flag = IDACalcIC(ida_mem, IDA_Y_INIT, times[1]); if(flag < 0.0) { if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);} if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);} ::Rf_error("Error in the IDACalcIC function"); } // Set maximum number of steps flag = IDASetMaxNumSteps(ida_mem, settings["maxsteps"]); if(flag < 0.0) { if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);} if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);} ::Rf_error("Error in the IDASetMaxNumSteps function"); } // Set maximum order of the integration flag = IDASetMaxOrd(ida_mem, settings["maxord"]); if(flag < 0.0) { if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);} if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);} ::Rf_error("Error in the IDASetMaxOrd function"); } // Set the initial step size flag = IDASetInitStep(ida_mem, settings["hini"]); if(flag < 0.0) { if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);} if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);} ::Rf_error("Error in the IDASetInitStep function"); } // Set the maximum step size flag = IDASetMaxStep(ida_mem, settings["hmax"]); if(flag < 0.0) { if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);} if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);} ::Rf_error("Error in the IDASetMaxStep function"); } // Set the maximum number of error test fails flag = IDASetMaxErrTestFails(ida_mem, settings["maxerr"]); if(flag < 0.0) { if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);} if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);} ::Rf_error("Error in the IDASetMaxErrTestFails function"); } // Set the maximum number of nonlinear iterations per step flag = IDASetMaxNonlinIters(ida_mem, settings["maxnonlin"]); if(flag < 0.0) { if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);} if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);} ::Rf_error("Error in the IDASetMaxNonlinIters function"); } // Set the maximum number of convergence failures flag = IDASetMaxConvFails(ida_mem, settings["maxconvfail"]); if(flag < 0.0) { if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);} if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);} ::Rf_error("Error in the IDASetMaxConvFails function"); } /* * Make a first call to the model to check that everything is ok and retrieve the number of observed variables * */ vector<double> forcings(forcings_data.size()); if(forcings_data.size() > 0) forcings = interpolate_list(forcings_data, times[0]); std::array<vector<double>, 2> first_call; try { first_call = model(times[0], states, derivatives, parameters, forcings); } catch(std::exception &ex) { if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);} if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);} forward_exception_to_r(ex); } catch(...) { if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);} if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);} ::Rf_error("c++ exception (unknown reason)"); } // Check length of time derivatives against the information passed through settings if(first_call[0].size() != neq) { if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);} if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);} ::Rf_error("Length of time derivatives returned by the model does not coincide with the number of state variables."); } /* * Fill up the output matrix with the values for the initial time * */ vector<double> observed; int nder = 0; if(first_call.size() == 2) { vector<double> temp = first_call[1]; observed.resize(temp.size()); observed = temp; nder = observed.size(); } vector<int> extract_states = as<vector<int>>(settings["which_states"]); vector<int> extract_observed = as<vector<int>>(settings["which_observed"]); mat output(times.size(), extract_states.size() + extract_observed.size() + 1); output.at(0,0) = times[0]; //for(auto i = 0; i < neq; i++) { // output(0,i+1) = states[i]; for(auto it = extract_states.begin(); it != extract_states.end(); it++) { if(*it > NV_LENGTH_S(y)) { Rcout << "The index " << *it << " exceeds the number of state variables of the model" << '\n'; if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);} if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);} ::Rf_error("Simulation exited because of error in extracting state variables"); } output.at(0,*it) = NV_Ith_S(y,*it - 1); } if(extract_observed.size() > 0) { //for(auto i = 0; i < nder; i++) // output(0,i + 1 + neq) = observed[i]; for(auto it = extract_observed.begin(); it != extract_observed.end(); it++) { if(*it > observed.size()) { Rcout << "The index " << *it << " exceeds the number of observed variables returned by the model" << '\n'; if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);} if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);} ::Rf_error("Simulation exited because of error in extracting observed variables"); } output.at(0,*it + extract_states.size()) = observed[*it - 1]; } } /* * Main time loop. Each timestep call cvode. Handle exceptions and fill up output * */ double t = times[0]; for(unsigned i = 1; i < times.size(); i++) { try { flag = IDASolve(ida_mem, times[i], &t, y, yp, IDA_NORMAL); for(auto h = 0; h < neq; h++) { if(as<bool>(settings["positive"])) { if(NV_Ith_S(y,h) < as<double>(settings["minimum"])) { Rcout << "The state variable at positon " << h << " became smaller than minimum: " << NV_Ith_S(y,h) << '\n'; if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);} if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);} ::Rf_error("At least one of the states became smaller than minimum"); } } } if(flag < 0.0) { switch(flag) { case -1: throw std::runtime_error("The solver took mxstep internal steps but could not reach tout."); break; case -2: throw std::runtime_error("The solver could not satisfy the accuracy demanded by the user for some internal step"); break; case -3: throw std::runtime_error("Error test failures occured too many times during one internal time step or minimum step size was reached"); break; case -4: throw std::runtime_error("Convergence test failures occurred too many times during one internal time step or minimum step size was reached."); break; case -5: throw std::runtime_error("The linear solver’s initialization function failed."); break; case -6: throw std::runtime_error("The linear solver’s setup function failed in an unrecoverable manner"); break; case -7: throw std::runtime_error("The linear solver’s solve function failed in an unrecoverable manner"); break; case -8: throw std::runtime_error("The right hand side function failed in an unrecoverable manner"); break; case -9: throw std::runtime_error("The right-hand side function failed at the first call."); break; case -10: throw std::runtime_error("The right-hand side function had repeated recoverable errors."); break; case -11: throw std::runtime_error("The right-hand side function had a recoverable errors but no recovery is possible."); break; case -25: throw std::runtime_error("The time t is outside the last step taken."); break; case -26: throw std::runtime_error("The output derivative vector is NULL."); break; case -27: throw std::runtime_error("The output and initial times are too close to each other."); break; } } } catch(std::exception &ex) { if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);} if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);} forward_exception_to_r(ex); } catch(...) { if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);} if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);} ::Rf_error("c++ exception (unknown reason)"); } // Write to the output matrix the new values of state variables and time output.at(i,0) = times[i]; //for(auto h = 0; h < neq; h++) output(i,h + 1) = NV_Ith_S(y,h); for(auto it = extract_states.begin(); it != extract_states.end(); it++) { output.at(i,*it) = NV_Ith_S(y,*it - 1); } } // If we have observed variables we call the model function again if(extract_observed.size() > 0 && flag >= 0.0) { for(unsigned i = 1; i < times.size(); i++) { // Get forcings values at time 0. if(forcings_data.size() > 0) forcings = interpolate_list(forcings_data, times[i]); // Get the simulate state variables for(auto j = 0; j < neq; j++) states[j] = output(i,j + 1); // Call the model function to retrieve total number of outputs and initial values for derived variables std::array<vector<double>, 2> model_call = model(times[i], states, derivatives, parameters, forcings); observed = model_call[1]; // Derived variables already stored by the interface function //for(auto j = 0; j < nder; j++) output(i,j + 1 + neq) = observed[j]; for(auto it = extract_observed.begin(); it != extract_observed.end(); it++) { output.at(i,*it + extract_states.size()) = observed[*it - 1]; } } } // De-allocate the N_Vector and the ida_mem structures if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);} if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);} return wrap(output); }
// [[Rcpp::export]] NumericVector pdistC2(double x, NumericVector ys) { NumericVector ans(ys.size()); ans = sqrt(pow(x - ys, 2)); return ans; }
NumericVector dbinom_glmb( NumericVector x, NumericVector N, NumericVector means, int lg){ int n = x.size() ; NumericVector res(n) ; for( int i=0; i<n; i++) res[i] = R::dbinom( round(x[i]*N[i]),round(N[i]), means[i], lg ) ; return res ; }
List EnelmC(List PITEMLL, List NODW, List Yl, List NU1) { // PITEMLL - item parameter estimates // NODW - quadrature nodes and weights // Yl - response matrices for each group in List // NU1 - null1 matrices for each group in List int ngru = PITEMLL.size(); // create return list List riqv_querG(ngru); List fiqG(ngru); // the group loop for(int gru = 0; gru < ngru; gru++) { // extract everything out of the Lists List PITEML = PITEMLL[gru]; List nodeswei = NODW[gru]; Rcpp::IntegerMatrix Y = Yl[gru]; Rcpp::IntegerMatrix nu1m = NU1[gru]; NumericVector nodes = nodeswei[0]; NumericVector weights = nodeswei[1]; int listlength = PITEML.size(); // number of items int ysi = Y.nrow(); // number of observations per item (including NA's) int lno = nodes.size(); // number of quadrature nodes // create matrix outside the loop Rcpp::NumericMatrix ENDm(lno,ysi); // matrix with proper dimensions for multiplication ENDm.fill(1); // write 1 in each cell for(int l = 0; l < listlength; l++) { // loops all items Rcpp::NumericVector PITEM = PITEML[l]; // take out parameters for the l-th item IntegerVector y = Y(_,l); // response vector of l-th items int lpi = PITEM.size()/2; // number of categories int lpim1 = lpi - 1; //arma::mat x(lno,lpi); Rcpp::NumericMatrix x(lno,lpi); // das hier ist zeile 40 bis 44 des nrm Estep for(int o = 0; o < lno; o++) { double gessum = 0; double z2plv = 0; double tplf = 0; for(int q = 0; q < lpi; q++) { int lpi2 = q+lpi; if(q == 0) { // hier muss jetzt das 2pl Modell rein // exp(Km %*% abpar) / (1 + exp(Km %*% abpar)) // x(o,q) = exp(PITEM(q) + nodes(o)*PITEM(lpi2)) / ( 1+ exp(PITEM(q) + nodes(o)*PITEM(lpi2))); // 2pl z2plv = exp(PITEM(q) + nodes(o)*PITEM(lpi2)) / ( 1+ exp(PITEM(q) + nodes(o)*PITEM(lpi2))); tplf = 1 - z2plv; // 1-P //std::cout << "Return" << tplf << " \n "; } else { x(o,q) = exp(PITEM(q) + nodes(o)*PITEM(lpi2)) * tplf; // mit 1-P multiplizieren gessum += exp(PITEM(q) + nodes(o)*PITEM(lpi2)); // new } } x(o,_) = x(o,_) / gessum; x(o,0) = z2plv; //std::cout << "z2plv:" << z2plv << " \n "; //std::cout << "inmattrix: " << x(o,0) << " \n "; } Rcpp::NumericMatrix z(lno,ysi); for(int i = 0; i < ysi; i++) { int whichE = y(i); // if there is NOT a missing value, make standard procedure // else (missing value is there) multiply with 1 - that means make a copy of what was there before //if(!NumericVector::is_na(whichE)) if(!IntegerVector::is_na(whichE)) { z(_,i) = x(_,whichE) * ENDm(_,i); // at the end ENDm will be the product again } else { z(_,i) = ENDm(_,i); } } ENDm = z; } NumericVector colmw; for(int col = 0; col < ysi; col++) { colmw = ENDm(_,col) * weights; ENDm(_,col) = colmw / sum(colmw); // normalize } // das muss ja fiq sein /////// arma::mat Anu1m = Rcpp::as<arma::mat>(nu1m); arma::mat AENDm = Rcpp::as<arma::mat>(ENDm); //arma::mat riqv_quer = Anu1m * trans(AENDm); arma::mat riqv_quer = trans(Anu1m) * trans(AENDm); riqv_querG[gru] = riqv_quer; // save in list //NumericVector fiq(lno); // calculate fiq which is the expected number of persons on each node IntegerMatrix fivor(ysi,listlength); // write 0 if missing value, 1 if valid response for(int ww = 0; ww < listlength; ww++) { fivor(_,ww) = ifelse(is_na(Y(_,ww)),0,1); } arma::mat Afivor = Rcpp::as<arma::mat>(fivor); arma::mat fiq = AENDm * Afivor; fiqG[gru] = fiq; // } // end of group loop // ENDm nachher wieder entfernen! es wird nur das letzte rausgeschrieben! return List::create(_["riqv_querG"] = riqv_querG, _["fiqG"] = fiqG); //return riqv_querG; }
arma::vec armaU(int n){ NumericVector x = runif(n,0,1); arma::vec out(x.begin(), x.size(), false); return out; }
//[[Rcpp::export]] IntegerVector cleanNA(NumericVector x) { int n = x.size(); IntegerVector y = seq_len(n);//(x.begin(), x.end()); IntegerVector z = y[is_na(x)]; return z; }
NumericVector RcppSample(NumericVector sample, int n) { return sample[round(runif(n)*(sample.size()-1.0), 0)]; }
// simulate genotypes given observed marker data // [[Rcpp::export(".sim_geno")]] IntegerVector sim_geno(const String& crosstype, const IntegerMatrix& genotypes, // columns are individuals, rows are markers const IntegerMatrix& founder_geno, // columns are markers, rows are founder lines const bool is_X_chr, const LogicalVector& is_female, // length n_ind const IntegerMatrix& cross_info, // columns are individuals const NumericVector& rec_frac, // length nrow(genotypes)-1 const IntegerVector& marker_index, // length nrow(genotypes) const double error_prob, const int n_draws) // number of imputations { const int n_ind = genotypes.cols(); const int n_pos = marker_index.size(); const int n_mar = genotypes.rows(); QTLCross* cross = QTLCross::Create(crosstype); // check inputs if(is_female.size() != n_ind) throw std::range_error("length(is_female) != ncol(genotypes)"); if(cross_info.cols() != n_ind) throw std::range_error("ncols(cross_info) != ncol(genotypes)"); if(rec_frac.size() != n_pos-1) throw std::range_error("length(rec_frac) != length(marker_index)-1"); if(error_prob < 0.0 || error_prob > 1.0) throw std::range_error("error_prob out of range"); for(int i=0; i<rec_frac.size(); i++) { if(rec_frac[i] < 0 || rec_frac[i] > 0.5) throw std::range_error("rec_frac must be >= 0 and <= 0.5"); } if(!cross->check_founder_geno_size(founder_geno, n_mar)) throw std::range_error("founder_geno is not the right size"); // end of checks const int mat_size = n_pos*n_draws; IntegerVector draws(mat_size*n_ind); // output object for(int ind=0; ind<n_ind; ind++) { Rcpp::checkUserInterrupt(); // check for ^C from user // possible genotypes for this individual IntegerVector poss_gen = cross->possible_gen(is_X_chr, is_female[ind], cross_info(_,ind)); const int n_poss_gen = poss_gen.size(); NumericVector probs(n_poss_gen); // backward equations NumericMatrix beta = backwardEquations(cross, genotypes(_,ind), founder_geno, is_X_chr, is_female[ind], cross_info(_,ind), rec_frac, marker_index, error_prob, poss_gen); // simulate genotypes for(int draw=0; draw<n_draws; draw++) { // first draw // calculate first prob (on log scale) probs[0] = cross->init(poss_gen[0], is_X_chr, is_female[ind], cross_info(_,ind)) + beta(0,0); if(marker_index[0] >= 0) probs[0] += cross->emit(genotypes(marker_index[0],ind), poss_gen[0], error_prob, founder_geno(_, marker_index[0]), is_X_chr, is_female[ind], cross_info(_,ind)); double sumprobs = probs[0]; // to contain log(sum(probs)) // calculate rest of probs for(int g=1; g<n_poss_gen; g++) { probs[g] = cross->init(poss_gen[g], is_X_chr, is_female[ind], cross_info(_,ind)) + beta(g,0); if(marker_index[0] >= 0) probs[g] += cross->emit(genotypes(marker_index[0],ind), poss_gen[g], error_prob, founder_geno(_, marker_index[0]), is_X_chr, is_female[ind], cross_info(_,ind)); sumprobs = addlog(sumprobs, probs[g]); } // re-scale probs for(int g=0; g<n_poss_gen; g++) probs[g] = exp(probs[g] - sumprobs); // make draw, returns a value from 1, 2, ..., n_poss_gen int curgeno = random_int(probs); draws[draw*n_pos + ind*mat_size] = poss_gen[curgeno]; // move along chromosome for(int pos=1; pos<n_pos; pos++) { // calculate probs for(int g=0; g<n_poss_gen; g++) { probs[g] = cross->step(poss_gen[curgeno], poss_gen[g], rec_frac[pos-1], is_X_chr, is_female[ind], cross_info(_,ind)) + beta(g,pos) - beta(curgeno, pos-1); if(marker_index[pos] >= 0) probs[g] += cross->emit(genotypes(marker_index[pos],ind), poss_gen[g], error_prob, founder_geno(_, marker_index[pos]), is_X_chr, is_female[ind], cross_info(_,ind)); probs[g] = exp(probs[g]); } // make draw curgeno = random_int(probs); draws[pos + draw*n_pos + ind*mat_size] = poss_gen[curgeno]; } // loop over positions } // loop over draws } // loop over individuals draws.attr("dim") = Dimension(n_pos, n_draws, n_ind); delete cross; return draws; }
/* Function to count number of valid partitions to swap */ int count_valid(List aList, List boundarypart, NumericVector cdvec){ int cd_boundary; arma::vec part; int j; int i; arma::uvec find_cds; int counter = 0; for(i = 0; i < boundarypart.size(); i++){ // Get the partition part = as<arma::vec>(boundarypart(i)); // Get the congressional district of the boundary cd_boundary = cdvec(part(0)); // Find indices within that congressional district find_cds = find(as<arma::vec>(cdvec) == cd_boundary); // Remove elements in the partition from that cd NumericVector cd_less_boundary; for(j = 0; j < find_cds.n_elem; j++){ if(any(part == find_cds(j)) == false){ cd_less_boundary.push_back(find_cds(j)); } } // If cd_less_boundary empty, then continue // Eliminates district so invalid partition if(cd_less_boundary.size() == 0){ continue; } // Create new adjacency list List newadj(cd_less_boundary.size()); for(j = 0; j < newadj.size(); j++){ // Extract vector from adjacency list NumericVector getadjvec = aList(cd_less_boundary(j)); // Subset down to elements in cd_less_boundary NumericVector getadjvec_sub; for(int k = 0; k < getadjvec.size(); k++){ if(any(as<arma::vec>(cd_less_boundary) == getadjvec(k))){ getadjvec_sub.push_back(getadjvec(k)); } } // Change indices NumericVector getadjvec_new; for(int k = 0; k < getadjvec_sub.size(); k++){ arma::uvec ind = find(as<arma::vec>(cd_less_boundary) == getadjvec_sub(k)); getadjvec_new.push_back(ind(0)); } // Add to newadj newadj(j) = getadjvec_new; } // Calculate number of partitions int nparts = countpartitions(newadj); if(nparts == 1){ counter++; } } return counter; }
//' Compute most probable path with extended Viterbi algorithm. //' //' Viterbi algorithm for Hidden Markov Model with duration //' @param aa_sample \code{character} vector representing single aminoacid sequence. //' @param pipar probabilities of initial state in Markov Model. //' @param tpmpar matrix of transition probabilities between states. //' @param od matrix of response probabilities. Eg. od[1,2] is a probability of signal 2 in state 1. //' @param params matrix of probability distribution for duration. Eg. params[10,2] is probability of duration of time 10 in state 2. //' @export //' @return A list of length four: //' \itemize{ //' \item{path}{ a vector of most probable path} //' \item{viterbi}{ values of probability in all intermediate points,} //' \item{psi}{ matrix that gives for every signal and state the previous state in viterbi path,} //' \item{duration}{ matrix that gives for every signal and state gives the duration in that state on viterbi path.} //' } //' @note All computations are on logarithms of probabilities. // [[Rcpp::export]] List duration_viterbi(NumericVector aa_sample, NumericVector pipar, NumericMatrix tpmpar, NumericMatrix od, NumericMatrix params) { int maxDuration = params.nrow(); int nstates = pipar.length(); // for(int i=0; i<nstates; i++){ // Rprintf("%f ", pipar(i)); // } // Rprintf("\n"); // // for(int i=0; i<tpmpar.nrow(); i++){ // for(int j=0; j<tpmpar.ncol(); j++){ // Rprintf("%f ", tpmpar(i, j)); // } // Rprintf("\n"); // } // // for(int i=0; i<params.nrow(); i++){ // for(int j=0; j<params.ncol(); j++){ // Rprintf("%f ", params[i, j]); // } // Rprintf("\n"); // } NumericMatrix viterbi(aa_sample.length(), nstates); //probabiliy values for viterbi path that ends in specific state and signal NumericMatrix psi(aa_sample.length(), nstates); //the previous state for viterbi path that ends in specific state and signal NumericMatrix dura(aa_sample.length(), nstates); //the current duration for viterbi path that ends in specific state and signal //first signal is treated seperately for(unsigned int j=0; j<nstates; j++) { viterbi(0,j) = log(pipar(j)) + log( od(j,aa_sample(0)) ); psi(0,j) = 0; dura(0,j) = 0; } double previous; double transition = 0.0; for(int i=1; i<aa_sample.length(); i++) { //For each state we will compute the probability of the viterbi path that ends in that state for(int j=0; j<nstates; j++) { double max = R_NegInf; int maxInd = 0; //previous state that is maximising probability int maximDura = 0; //duration that is maximising probability for(int k=0; k<nstates; k++) { int dMax=std::min(maxDuration-1, i); for(int d=0; d<=dMax; d++) { // for every possible previous state, and for every possible duration in current state if (i-d==0) { //if duration is as long as number of signal considered if(j == 0) { //only first state is accepted previous = 1.0; transition = 1.0; } else { //other states are discarded with log-probability -Inf previous = R_NegInf; transition = 1.0; } } else { //there is some previous state previous = viterbi(i-d-1, k); //previous probability on this viterbi path transition = log(tpmpar(k, j)); //probability of transition to current state from prevois state } double duration = log(params(d, j)); //probability of duration that lasts time d double responses = 0; //probability of generating d signal in current state for(int l=i-d; l<=i; l++) { responses += log(od(j, aa_sample[l])); } // if(j==1){ // Rprintf("i %d k %d d %d \n", i,k,d); // Rprintf("The value of previous is %f\n", previous); // Rprintf("The value of transition is %f\n", transition ); // Rprintf("The value of duration is %f\n", duration ); // Rprintf("The value of responses is %f\n", responses ); // } if(previous + transition + duration + responses > max) { //if that path is better than the best yet found store it max = previous + transition + duration + responses; maxInd = k; maximDura = d; } } } //assign information about the best path that ends on signal i and state j viterbi(i, j) = max; psi(i, j) = maxInd; dura(i, j) = maximDura; } } //now we extract information about the path. We look for the most probable path IntegerVector path(aa_sample.size()); //the last state int seqLength = aa_sample.length(); NumericVector prob_path = viterbi(seqLength-1,_); // for(int i=0; i<prob_path.length(); i++){ // Rprintf("%f ", prob_path(i)); // } // Rprintf("\n %d \n", which_max(viterbi(seqLength-1,_))); path(seqLength-1) = which_max(viterbi(seqLength-1,_)); int i = seqLength-2; int last = seqLength-1; while(i > 0) { if(last - i <= dura(last, path[last])) { //we are still in the same state path(i) = path(last); } else { //time to change the state for the previous, stored in matrix psi path(i) = psi(last, path(last)); last = i; } i -= 1; } path(0) = 0; return List::create( _["path"] = path, _["viterbi"] = viterbi, _["psi"] = psi, _["duration"] = dura ); }
// [[Rcpp::export]] NumericMatrix calc_bs_scalar(NumericVector x, NumericVector knots, int degree, NumericVector boundary_knots) { int nk = knots.size(); int len_x = x.size(); double x_val, term, saved; int order = degree + 1; NumericMatrix basis(len_x, nk + degree); NumericMatrix basis_j(len_x, order); int kk_size = 2 * order + nk; NumericVector kk(kk_size); NumericVector rdel(degree); NumericVector ldel(degree); for (int k = 0; k < order; k++) { kk[k] = boundary_knots[0]; kk[k + order + nk] = boundary_knots[1]; } for (int k = 0; k < nk; k++) { kk[k + order] = knots[k]; } for (int j = 0; j < len_x; j++) { x_val = x[j]; //calculate cursor point int curs = -1; for (int k = 0; k < kk_size; k++) { if (kk[k] >= x_val) curs = k; if (kk[k] > x_val) break; } if (curs > (kk_size - order)) { int lastLegit = kk_size - order; if (x_val == kk[lastLegit]) { curs = lastLegit; } } //calculate rdel and ldel for (int k = 0; k < degree; k++) { rdel[k] = kk[curs + k] - x_val; ldel[k] = x_val - kk[curs - k - 1]; } basis_j(j, 0) = 1.0; for (int k = 1; k < order; k++) { saved = 0.0; for (int r = 0; r < k; r++) { term = basis_j(j, r) / (rdel[r] + ldel[k - 1 - r]); basis_j(j, r) = saved + rdel[r] * term; saved = ldel[k - 1 - r] * term; } basis_j(j, k) = saved; } //convert basis_j to the correct size matrix int offset = curs - order - 1; for (int k = 0; k < order; k++) { if ((k + offset) >= 0) { basis(j, k + offset) = basis_j(j, k); } } } return(basis); }
// [[Rcpp::export]] List SDP_single(int tmax, NumericVector res_bs, int cons_bs, int xc, NumericVector rep_gain, NumericMatrix f_m, NumericVector mort, List dec_ls, NumericVector rho_vec, NumericMatrix c_learn, NumericVector g_forage, NumericVector c_forage) { //Establish iniital variables required for the SDP int num_res = res_bs.size(); //How many decisions? Count columns on first decision matrix NumericMatrix dec_ex = dec_ls(0); int num_dec = dec_ex.ncol(); int max_enc = f_m.nrow(); //Rows = encounters; Columns = resources double cons_bs_state = (double) cons_bs; //Define xc_state as a double. This variable will be used for energetic calculations double xc_state = (double) xc; //Define xc, which will be used to locate the critical value in a matrix. //Subtract one, because Cpp indices start at zero. xc = xc - 1; //Build Fitness List, Istar List, and terminal fitness values List W_nr(num_res); List istar_nr(num_res); NumericMatrix W_xt(cons_bs,tmax); //NumericMatrix istar_xt(cons_bs,tmax-1); //Initiate terminal fitness values in W_xt matrix //Don't forget that the matrix index BEGINS at 0. for (int i=xc; i<cons_bs; i++) { W_xt(i,tmax-1) = rep_gain(i); //tmax-1 because index starts at zero. So tmax-1 is the terminal time, as t=0 is initial time } //Place fitness matrix into each list element for future updating for (int i=0; i<num_res; i++) { W_nr(i) = W_xt; //istar_nr(i) = istar_xt; } //Begin Backwards Equation for (int r=0; r<num_res; r++) { Rcpp::Rcout << "r = " << r << std::endl; NumericMatrix dec_m = dec_ls(r); NumericMatrix W_r = W_nr(r); IntegerMatrix istar_r(cons_bs,tmax-1); //Begin backwards calculations... start at tmax-1 for (int t=(tmax-1); t --> 0;) { //Rcpp::Rcout << "t = " << t << std::endl; //int t_state = t - 1; for (int x=xc; x<cons_bs; x++) { //Define the energetic state to be used in calculations //Added one because the index starts at zero... but we care about the true energetic state, not the index double x_state = (double) x; x_state = x_state + 1; NumericVector value(num_dec); for (int i=0; i<num_dec; i++) { //Build preference vector for ith decision NumericVector pref_vec(num_res); for (int j=0; j<num_res; j++) { pref_vec(j) = dec_m(j,i); } //Loop over the changes in energetic reserves via consumption of different (t+1) resources NumericMatrix xp(num_res,max_enc); //xp high and low must be integers, because they are used as indices of the fitness matrices IntegerMatrix xp_high(num_res,max_enc); IntegerMatrix xp_low(num_res,max_enc); //But these are not integer matrices NumericMatrix q(num_res,max_enc); NumericMatrix W(num_res,max_enc); NumericVector Wk(num_res); double Fx = 0; //Initialized at zero. Will be added/multiplied as dot product below for (int rr=0; rr<num_res; rr++) { for (int k=0; k<max_enc; k++) { //Change in Energetic state xp(rr,k) = x_state + rho_vec(k)*(g_forage(rr) - (c_forage(rr) + c_learn(r,rr))) - (1-rho_vec(k))*(c_forage(rr) + c_learn(r,rr)); //Establish Boundary conditions en route //Lower boundary condition at x-critical if (xp(rr,k) < xc_state) {xp(rr,k) = xc_state;} //Higher boundary condition at xmax = cons_bs if (xp(rr,k) > cons_bs_state) {xp(rr,k) = cons_bs_state;} //Build xp_high, xp_low, and q matrices en route //Estabish Fitness en route if ((xp(rr,k) < cons_bs_state) && (xp(rr,k) > xc_state)) { xp_low(rr,k) = (int) floor(xp(rr,k)); xp_high(rr,k) = (int) xp_low(rr,k) + 1; //Make sure that we do not have an (integer - double) double xp_h = (double) xp_high(rr,k); q(rr,k) = xp_h - xp(rr,k); //Prep for indexing //Adjust xp_low and xp_high to signify indices rather than energetic values xp_low(rr,k) = xp_low(rr,k) - 1; xp_high(rr,k) = xp_high(rr,k) - 1; W(rr,k) = q(rr,k)*W_r(xp_low(rr,k),t+1) + (1-q(rr,k))*W_r(xp_high(rr,k),t+1); } if (xp(rr,k) == xc_state) { xp_low(rr,k) = (int) xc_state; xp_high(rr,k) = (int) xc_state+1; q(rr,k) = 1; //Prep for indexing //Adjust xp_low and xp_high to signify indices rather than energetic values xp_low(rr,k) = xp_low(rr,k) - 1; xp_high(rr,k) = xp_high(rr,k) - 1; W(rr,k) = q(rr,k)*W_r(xp_low(rr,k),t+1) + (1-q(rr,k))*W_r(xp_high(rr,k),t+1); } if (xp(rr,k) == cons_bs_state) { xp_low(rr,k) = (int) cons_bs_state - 1; xp_high(rr,k) = (int) cons_bs_state; q(rr,k) = 0; //Prep for indexing //Adjust xp_low and xp_high to signify indices rather than energetic values xp_low(rr,k) = xp_low(rr,k) - 1; xp_high(rr,k) = xp_high(rr,k) - 1; W(rr,k) = q(rr,k)*W_r(xp_low(rr,k),t+1) + (1-q(rr,k))*W_r(xp_high(rr,k),t+1); } //Vector multiplication: fitness vector (over k) and probability of finding k resources (over k) //Note that the values for the W and f.m matrices are transposed relative to each other double vec = W(rr,k) * f_m(k,rr); Wk(rr) += vec; // The same as Wk(rr) = Wk(rr) + vec } // end k //Vector multiplication over preference probabilities and Wk ** over rr ** double vec2 = pref_vec(rr) * (rep_gain(x) + (1-mort(rr))*Wk(rr)); Fx += vec2; //Rcpp::Rcout << "Fx = " << Fx << std::endl; } // end rr //Record fitness value for decision i value(i) = Fx; } // end i (decision loop) //Find maximum value int istar = which_max(value); istar_r(x,t) = istar + 1; //The +1 is there because we are going from 'index' to 'decision number' W_r(x,t) = value(istar); } //End x iterations } //End t iterations //Replace updated W_nr //Update istar_nr list W_nr(r) = W_r; istar_nr(r) = istar_r; } //End r iterations List output(2); output(0) = W_nr; output(1) = istar_nr; return (output); } //End cpp function
void v_glogis(NumericVector x) { for(int i = 0; i < x.size(); i++) v_glogis(&x[i]); }
//' Update the parameter F (M-step in the EM-algorithm) //' //' @param vTheta theparameter Theta (converted to a vector) //' @param vG the matrix of mutation feature data //' @param fdim a vector specifying the number of possible values for each mutation signature //' @param signatureNum the number of mutation signatures //' @param sampleNum the number of cancer genomes //' @param patternNum the number of possible combinations of all the mutation features //' @param isBackground the logical value showing whether a background mutaiton features is included or not //' @export // [[Rcpp::export]] NumericVector updateMstepFC(NumericVector vTheta, NumericVector vG,NumericVector fdim, int signatureNum, int sampleNum, int patternNum, bool isBackground) { int variableSigNum; if (isBackground) { variableSigNum = signatureNum - 1; } else { variableSigNum = signatureNum; } NumericVector vF(variableSigNum * fdim.size() * max(fdim)); IntegerVector currentDigits(fdim.size()); NumericVector vG_Theta_sum(signatureNum * patternNum); for (int m = 0; m < patternNum; m++) { for (int n = 0; n < sampleNum; n++) { for (int k = 0; k < signatureNum; k++) { vG_Theta_sum[k + m * signatureNum] = vG_Theta_sum[k + m * signatureNum] + vG[n + m * sampleNum] * vTheta[n + k * sampleNum + m * sampleNum * signatureNum]; } } } for (int l = 0; l < fdim.size(); l++) { currentDigits[l] = 0; } for (int m = 0; m < patternNum; m++) { for (int l = 0; l < fdim.size(); l++) { for (int k = 0; k < variableSigNum; k++) { vF[k + l * variableSigNum + currentDigits[l] * variableSigNum * fdim.size()] = vF[k + l * variableSigNum + currentDigits[l] * variableSigNum * fdim.size()] + vG_Theta_sum[k + m * signatureNum]; } } int tl = 0; while(tl < fdim.size() and currentDigits[tl] + 1 >= fdim[tl]) { currentDigits[tl] = 0; tl = tl + 1; } if (tl < fdim.size()) { currentDigits[tl] = currentDigits[tl] + 1; } } double tempSum; double invTempSum; for (int k = 0; k < variableSigNum; k++) { for (int l = 0; l < fdim.size(); l++) { tempSum = 0; for (int ll = 0; ll < max(fdim); ll++) { tempSum = tempSum + vF[k + l * variableSigNum + ll * variableSigNum * fdim.size()]; } invTempSum = 1 / tempSum; for (int ll = 0; ll < max(fdim); ll++) { vF[k + l * variableSigNum + ll * variableSigNum * fdim.size()] = vF[k + l * variableSigNum + ll * variableSigNum * fdim.size()] * invTempSum; } } } return(vF); }