// [[Rcpp::export]] Rcpp::IntegerMatrix quantileNorm(Rcpp::IntegerMatrix mat, Rcpp::IntegerVector ref, int nthreads=1, int seed=13){ if (mat.nrow() != ref.length()) Rcpp::stop("incompatible arrays..."); if (!std::is_sorted(ref.begin(), ref.end())) Rcpp::stop("ref must be sorted"); int ncol = mat.ncol(); int nrow = mat.nrow(); //allocate new matrix Rcpp::IntegerMatrix res(nrow, ncol); Mat<int> oldmat = asMat(mat); Mat<int> newmat = asMat(res); Vec<int> ref2 = asVec(ref); //allocate a seed for each column std::seed_seq sseq{seed}; std::vector<std::uint32_t> seeds(ncol); sseq.generate(seeds.begin(), seeds.end()); #pragma omp parallel num_threads(nthreads) { std::vector<std::pair<int, int> > storage(nrow);//pairs <value, index> #pragma omp for for (int col = 0; col < ncol; ++col){ std::mt19937 gen(seeds[col]); qtlnorm(oldmat.getCol(col), ref2, newmat.getCol(col), storage, gen); } } res.attr("dimnames") = mat.attr("dimnames"); return res; }
SEXP exact(SEXP matrix_sexp, SEXP progress_sexp) { BEGIN_RCPP mpz_class sum = 0; mpz_class rowsumprod, rowsum; Rcpp::IntegerMatrix matrix = Rcpp::as<Rcpp::IntegerMatrix>(matrix_sexp); if(matrix.ncol() != matrix.nrow()) { throw std::runtime_error("Matrix must be square"); } bool progress = Rcpp::as<bool>(progress_sexp); Rcpp::Function txtProgressBar("txtProgressBar"), setTxtProgressBar("setTxtProgressBar"), close("close"); Rcpp::RObject barHandle; if(progress) { barHandle = txtProgressBar(Rcpp::Named("style") = 1, Rcpp::Named("min") = 0, Rcpp::Named("max") = 1000, Rcpp::Named("initial") = 0); } int dimension = matrix.nrow(); unsigned long long C = (1ULL << dimension); for (unsigned long long k = 1ULL; k < C; k++) { rowsumprod = 1; int setBits = 0; for (int m = 0; m < dimension; m++) { if((k & (1ULL << m)) != 0ULL) setBits++; } // loop columns of submatrix #k for (int m = 0; m < dimension; m++) { rowsum = 0; // loop rows and compute rowsum for (int p = 0; p < dimension; p++) { if((k & (1ULL << p)) != 0ULL) { rowsum += matrix(m, p); } } // update product of rowsums rowsumprod *= rowsum; if (rowsumprod == 0) break; } if(setBits % 2 == 0) sum += rowsumprod; else sum -= rowsumprod; if(progress && k % 1000ULL == 0) { setTxtProgressBar.topLevelExec(barHandle, (int)((double)k*1000.0 / (double)C)); } } if(progress) { close(barHandle); } if(dimension % 2 != 0) sum *= -1; return Rcpp::wrap(sum.str()); END_RCPP }
SEXP removeHets(SEXP founders_sexp, SEXP finals_sexp, SEXP hetData_sexp) { BEGIN_RCPP Rcpp::IntegerMatrix founders = Rcpp::as<Rcpp::IntegerMatrix>(founders_sexp); Rcpp::IntegerMatrix finals = Rcpp::as<Rcpp::IntegerMatrix>(finals_sexp); Rcpp::S4 hetData = Rcpp::as<Rcpp::S4>(hetData_sexp); Rcpp::List hetDataList = Rcpp::as<Rcpp::List>(hetData_sexp); int nMarkers = founders.ncol(), nFounders = founders.nrow(), nFinals = finals.nrow(); recodeDataStruct args; Rcpp::List recodedHetData(nMarkers); Rcpp::IntegerMatrix recodedFounders(founders.nrow(), founders.ncol()), recodedFinals(finals.nrow(), finals.ncol()); args.founders = founders; args.finals = finals; args.hetData = hetData; args.recodedHetData = recodedHetData; args.recodedFounders = recodedFounders; args.recodedFinals = recodedFinals; recodeFoundersFinalsHets(args); for(int i = 0; i < nMarkers; i++) { int maxAllele = 0; for(int j = 0; j < nFounders; j++) maxAllele = std::max(maxAllele, recodedFounders(j, i)); //Overwrite the recoded finals data for(int j = 0; j < nFinals; j++) { if(recodedFinals(j, i) > maxAllele) recodedFinals(j, i) = NA_INTEGER; else recodedFinals(j, i) = finals(j, i); } //overwrite the recoded het data Rcpp::IntegerMatrix newHetEntry(maxAllele+1, 3); Rcpp::IntegerMatrix oldHetEntry = Rcpp::as<Rcpp::IntegerMatrix>(hetDataList(i)); int counter = 0; for(int j = 0; j < oldHetEntry.nrow(); j++) { if(oldHetEntry(j, 0) == oldHetEntry(j, 1)) { newHetEntry(counter, 0) = newHetEntry(counter, 1) = newHetEntry(counter, 2) = oldHetEntry(j, 1); counter++; } } recodedHetData(i) = newHetEntry; } Rcpp::rownames(recodedFinals) = Rcpp::rownames(finals); Rcpp::colnames(recodedFinals) = Rcpp::colnames(finals); return Rcpp::List::create(Rcpp::Named("finals") = recodedFinals, Rcpp::Named("hetData") = recodedHetData); END_RCPP }
static Rcpp::NumericMatrix next_beta(Rcpp::IntegerVector nk, Rcpp::IntegerMatrix groups, Rcpp::NumericMatrix alpha_new, Rcpp::NumericVector d_new, Rcpp::NumericMatrix eta_new) { int K = nk.size(); int p = groups.nrow(); int L = groups.ncol(); Rcpp::NumericMatrix result(p, K); for (int k = 0; k < K; k++) { for (int j = 0; j < p; j++) { double sum = 0.0; for (int l = 0; l < L; l++) { if (elem(groups, j, l)) { sum += d_new[l] * elem(eta_new, l, k); } } elem(result, j, k) = elem(alpha_new, j, k) * sum; } } return result; }
SEXP rawSymmetricMatrixSubsetByMatrix(SEXP object_, SEXP index_) { BEGIN_RCPP Rcpp::S4 object; try { object = object_; } catch(...) { throw std::runtime_error("Input object must be an S4 object"); } Rcpp::RawVector data; try { data = Rcpp::as<Rcpp::RawVector>(object.slot("data")); } catch(...) { throw std::runtime_error("Slot object@data must be a raw vector"); } Rcpp::NumericVector levels; try { levels = Rcpp::as<Rcpp::NumericVector>(object.slot("levels")); } catch(...) { throw std::runtime_error("Slot object@levels must be a numeric vector"); } Rcpp::IntegerMatrix index; try { index = index_; } catch(...) { throw std::runtime_error("Input index must be an integer matrix"); } int nIndices = index.nrow(); Rcpp::NumericVector output(nIndices); for(int row = 0; row < nIndices; row++) { R_xlen_t i = index(row, 0); R_xlen_t j = index(row, 1); if(i > j) std::swap(i, j); output(row) = levels[data[(j*(j-(R_xlen_t)1))/(R_xlen_t)2 + i-(R_xlen_t)1]]; } return output; END_RCPP }
void CEnv::SetData(Rcpp::IntegerMatrix x_, Rcpp::IntegerMatrix mcz_) { int J = x_.nrow(); int n = x_.ncol(); int nZeroMC = mcz_.ncol(); if (mcz_.nrow() != J) { // no mcz nZeroMC = 0; } intvec x = Rcpp::as<intvec>(x_); intvec mcz = Rcpp::as<intvec>(mcz_); Rcpp::List something(x_.attr("levels")); intvec levels(something.size()); for (unsigned int i = 0; i < levels.size(); i++) { SEXP exp = something[i]; Rcpp::CharacterVector v(exp); levels[i] = v.size(); //Rprintf( "%d\n", levels[i]) ; } SetData(x, J, n, mcz, nZeroMC, levels); }
unsigned int GetTag(const Rcpp::IntegerMatrix& board, const int i, const int j) { // static constants const int nrow = board.nrow(); const int ncol = board.ncol(); // offset (assumes odd) -- integer divide intentional static const int offset = (sub_board_width/2); // data structure to hold the subboard's bits std::bitset<sub_board_width*sub_board_width> bits; unsigned int bit_index = (sub_board_width*sub_board_width)-1; const int k_start = i - offset; const int k_end = i + offset; const int l_start = j - offset; const int l_end = j + offset; // fill the bitset for (int k = k_start; k <= k_end; k++) { //std::cout << "k = " << k << std::endl; for (int l = l_start; l <= l_end; l++) { // check row boundaries if (k < 0 or k > (nrow-1)) { bits.set(bit_index, false); } // check col boundaries else if (l < 0 or l > (ncol-1)) { bits.set(bit_index, false); } else { bits.set(bit_index, static_cast<bool>(board(k,l))); } //std::cout << "\nbits(" << bit_index << ") = " << bits[bit_index] << std::endl; bit_index--; } } return static_cast<unsigned int>(bits.to_ulong()); }
// [[Rcpp::export]] Rcpp::IntegerVector getRef(Rcpp::IntegerMatrix mat, std::string type, int nthreads=1){ //allocate another matrix with transpose dimensions as mat int ncol = mat.ncol(); int nrow = mat.nrow(); if (ncol*nrow == 0) Rcpp::stop("empty input is invalid"); Rcpp::IntegerMatrix mem_smat(ncol, nrow); Mat<int> smat = asMat(mem_smat); Mat<int> omat = asMat(mat); //sort every column #pragma omp parallel for num_threads(nthreads) for (int col = 0; col < ncol; ++col){ Vec<int> ovec = omat.getCol(col); MatRow<int> svec = smat.getRow(col); sortCounts(ovec, svec); } return colSummary(mem_smat, type, nthreads); }
/* This function specifically checks whether the observed data is consistent with the *pedigree*. It assumes that every observed value in the finals is already valid - That is, every observed value contained in the finals is also listed as a possibility in the hetData object */ void estimateRFCheckFunnels(Rcpp::IntegerMatrix finals, Rcpp::IntegerMatrix founders, Rcpp::List hetData, Rcpp::S4 pedigree, std::vector<int>& intercrossingGenerations, std::vector<std::string>& warnings, std::vector<std::string>& errors, std::vector<funnelType>& allFunnels, std::vector<funnelType>& lineFunnels) { Rcpp::CharacterVector pedigreeLineNames = Rcpp::as<Rcpp::CharacterVector>(pedigree.slot("lineNames")); //We make a copy of the pedigree line names and sort it (otherwise the std::find relating to pedigreeLineNames is prohibitive) std::vector<pedigreeLineStruct> sortedLineNames; sortPedigreeLineNames(pedigreeLineNames, sortedLineNames); Rcpp::IntegerVector mother = Rcpp::as<Rcpp::IntegerVector>(pedigree.slot("mother")); Rcpp::IntegerVector father = Rcpp::as<Rcpp::IntegerVector>(pedigree.slot("father")); bool warnImproperFunnels = Rcpp::as<bool>(pedigree.slot("warnImproperFunnels")); Rcpp::CharacterVector finalNames = Rcpp::as<Rcpp::CharacterVector>(Rcpp::as<Rcpp::List>(finals.attr("dimnames"))[0]); Rcpp::CharacterVector markerNames = Rcpp::as<Rcpp::CharacterVector>(Rcpp::as<Rcpp::List>(finals.attr("dimnames"))[1]); int nFinals = finals.nrow(), nFounders = founders.nrow(), nMarkers = finals.ncol(); if(nFounders != 2 && nFounders != 4 && nFounders != 8 && nFounders != 16) { throw std::runtime_error("Number of founders must be 2, 4, 8, or 16"); } xMajorMatrix<int> foundersToMarkerAlleles(nFounders, nFounders, nMarkers, -1); for(int markerCounter = 0; markerCounter < nMarkers; markerCounter++) { Rcpp::IntegerMatrix currentMarkerHetData = hetData(markerCounter); for(int founderCounter1 = 0; founderCounter1 < nFounders; founderCounter1++) { for(int founderCounter2 = 0; founderCounter2 < nFounders; founderCounter2++) { int markerAllele1 = founders(founderCounter1, markerCounter); int markerAllele2 = founders(founderCounter2, markerCounter); for(int hetDataRowCounter = 0; hetDataRowCounter < currentMarkerHetData.nrow(); hetDataRowCounter++) { if(markerAllele1 == currentMarkerHetData(hetDataRowCounter, 0) && markerAllele2 == currentMarkerHetData(hetDataRowCounter, 1)) { foundersToMarkerAlleles(founderCounter1, founderCounter2, markerCounter) = currentMarkerHetData(hetDataRowCounter, 2); } } } } } std::vector<long> individualsToCheckFunnels; for(long finalCounter = 0; finalCounter < nFinals; finalCounter++) { individualsToCheckFunnels.clear(); std::string currentLineName = Rcpp::as<std::string>(finalNames(finalCounter)); std::vector<pedigreeLineStruct>::iterator findLineName = std::lower_bound(sortedLineNames.begin(), sortedLineNames.end(), pedigreeLineStruct(currentLineName, -1)); if(findLineName == sortedLineNames.end() || findLineName->lineName != currentLineName) { std::stringstream ss; ss << "Unable to find line number " << finalCounter << " named " << finalNames(finalCounter) << " in pedigree"; throw std::runtime_error(ss.str().c_str()); } int pedigreeRow = findLineName->index; //This vector lists all the founders that are ancestors of the current line. This may comprise any number - E.g. if we have an AIC line descended from funnels 1,2,1,2 and 2,3,2,3 then this vector is going it contain 1,2,3 std::vector<int> representedFounders; if(intercrossingGenerations[finalCounter] == 0) { individualsToCheckFunnels.push_back(pedigreeRow); } else { try { getAICParentLines(mother, father, pedigreeRow, intercrossingGenerations[finalCounter], individualsToCheckFunnels); } catch(...) { std::stringstream ss; ss << "Error while attempting to trace intercrossing lines for line " << finalNames(finalCounter); errors.push_back(ss.str()); goto nextLine; } } //Now we know the lines for which we need to check the funnels from the pedigree (note: We don't necessarily have genotype data for all of these, it's purely a pedigree check) //Fixed length arrays to store funnels. If we have less than 16 founders then part of this is garbage and we don't use that bit.... funnelType funnel, copiedFunnel; for(std::vector<long>::iterator i = individualsToCheckFunnels.begin(); i != individualsToCheckFunnels.end(); i++) { try { getFunnel(*i, mother, father, &(funnel.val[0]), nFounders); } catch(...) { std::stringstream ss; ss << "Attempting to trace pedigree for line " << finalNames(finalCounter) << ": Unable to get funnel for line " << pedigreeLineNames(*i); errors.push_back(ss.str()); goto nextLine; } //insert these founders into the vector containing all the represented founders representedFounders.insert(representedFounders.end(), &(funnel.val[0]), &(funnel.val[0]) + nFounders); //Copy the funnel memcpy(&copiedFunnel, &funnel, sizeof(funnelType)); std::sort(&(copiedFunnel.val[0]), &(copiedFunnel.val[0]) + nFounders); if(std::unique(&(copiedFunnel.val[0]), &(copiedFunnel.val[0]) + nFounders) != &(copiedFunnel.val[0]) + nFounders) { //If we have intercrossing generations then having repeated founders is an error. Otherwise if warnImproperFunnels is true it's still a warning. if(intercrossingGenerations[finalCounter] != 0 || warnImproperFunnels) { std::stringstream ss; ss << "Funnel for line " << pedigreeLineNames(*i) << " contained founders {" << funnel.val[0]; if(nFounders == 2) { ss << ", " << funnel.val[1] << "}"; } else if(nFounders == 4) { ss << ", " << funnel.val[1] << ", " << funnel.val[2] << ", " << funnel.val[3] << "}"; } else if(nFounders == 8) { ss << ", " << funnel.val[1] << ", " << funnel.val[2] << ", " << funnel.val[3] << ", " << funnel.val[4] << ", " << funnel.val[5] << ", " << funnel.val[6] << ", " << funnel.val[7]<< "}"; } else if (nFounders == 16) { ss << ", " << funnel.val[1] << ", " << funnel.val[2] << ", " << funnel.val[3] << ", " << funnel.val[4] << ", " << funnel.val[5] << ", " << funnel.val[6] << ", " << funnel.val[7] << ", " << funnel.val[8] << ", " << funnel.val[9] << ", " << funnel.val[10] << ", " << funnel.val[11] << ", " << funnel.val[12] << ", " << funnel.val[13] << ", " << funnel.val[14] << ", " << funnel.val[15] << "}"; } //In this case it's an error if(intercrossingGenerations[finalCounter] != 0) { ss << ". Repeated founders are only allowed with zero generations of intercrossing"; errors.push_back(ss.str()); } //But if we have zero intercrossing generations then it's only a warning else { ss << ". Did you intend to use all " << nFounders << " founders?"; warnings.push_back(ss.str()); } } } allFunnels.push_back(funnel); } //remove duplicates in representedFounders std::sort(representedFounders.begin(), representedFounders.end()); representedFounders.erase(std::unique(representedFounders.begin(), representedFounders.end()), representedFounders.end()); //Try and check for inconsistent generations of selfing for(std::vector<int>::iterator i = representedFounders.begin(); i != representedFounders.end(); i++) { if(*i > nFounders) { std::stringstream ss; ss << "Error in pedigree for line number " << finalCounter << " named " << finalNames(finalCounter) << ". Inconsistent number of generations of intercrossing"; errors.push_back(ss.str()); goto nextLine; } } //Not having all the founders in the input funnels is more serious if it causes the observed marker data to be impossible. So check for this. for(int markerCounter = 0; markerCounter < nMarkers; markerCounter++) { bool okMarker = false; //If observed value is an NA then than's ok, continue int value = finals(finalCounter, markerCounter); if(value == NA_INTEGER) continue; for(std::vector<int>::iterator founderIterator1 = representedFounders.begin(); founderIterator1 != representedFounders.end(); founderIterator1++) { for(std::vector<int>::iterator founderIterator2 = representedFounders.begin(); founderIterator2 != representedFounders.end(); founderIterator2++) { //Note that founderIterator comes from representedFounders, which comes from getFunnel - Which returns values starting at 1, not 0. So we have to subtract one. if(finals(finalCounter, markerCounter) == foundersToMarkerAlleles((*founderIterator1)-1, (*founderIterator2)-1, markerCounter)) { okMarker = true; break; } } } if(!okMarker) { std::stringstream ss; ss << "Data for marker " << markerNames(markerCounter) << " is impossible for individual " << finalNames(finalCounter) << " with given pedigree"; errors.push_back(ss.str()); if(errors.size() > 1000) return; goto nextLine; } } //In this case individualsToCheckFunnels contains one element => getFunnel was only called once => we can reuse the funnel variable if(intercrossingGenerations[finalCounter] == 0) { orderFunnel(&(funnel.val[0]), nFounders); lineFunnels.push_back(funnel); } else { //Add a dummy value in lineFunnel for(int i = 0; i < 16; i++) funnel.val[i] = 0; lineFunnels.push_back(funnel); } nextLine: ; } }
// Returns an n by 1 column that represents the likelihoods of // an estimated univariate MS-AR model for each k where 1 \leq k \leq n where // beta is switching. // Note that even if beta is non-switching, setting beta as a s by M matrix with // repeated column of the original beta will give you the likelihood for // MS-AR model with non-switching beta. // TODO: Implement the version where z_dependent/z_independent exist(lagged variables should be implemented for MSM models) // [[Rcpp::export]] SEXP LikelihoodsMSMAR (Rcpp::NumericVector y_rcpp, Rcpp::NumericMatrix y_lagged_rcpp, Rcpp::NumericMatrix z_dependent_rcpp, Rcpp::NumericMatrix z_independent_rcpp, Rcpp::NumericMatrix z_dependent_lagged_rcpp, Rcpp::NumericMatrix z_independent_lagged_rcpp, Rcpp::NumericMatrix transition_probs_rcpp, Rcpp::NumericVector initial_dist_extended_rcpp, Rcpp::NumericMatrix beta_rcpp, Rcpp::NumericVector mu_rcpp, Rcpp::NumericVector sigma_rcpp, Rcpp::NumericMatrix gamma_dependent_rcpp, Rcpp::NumericVector gamma_independent_rcpp, Rcpp::IntegerMatrix state_conversion_mat_rcpp ) { int n = y_rcpp.size(); arma::colvec y(y_rcpp.begin(), y_rcpp.size(), false); arma::mat y_lagged(y_lagged_rcpp.begin(), y_lagged_rcpp.nrow(), y_lagged_rcpp.ncol(), false); arma::mat z_dependent(z_dependent_rcpp.begin(), z_dependent_rcpp.nrow(), z_dependent_rcpp.ncol(), false); arma::mat z_dependent_lagged(z_dependent_lagged_rcpp.begin(), z_dependent_lagged_rcpp.nrow(), z_dependent_lagged_rcpp.ncol(), false); arma::mat z_independent(z_independent_rcpp.begin(), z_independent_rcpp.nrow(), z_independent_rcpp.ncol(), false); arma::mat z_independent_lagged(z_independent_lagged_rcpp.begin(), z_independent_lagged_rcpp.nrow(), z_independent_lagged_rcpp.ncol(), false); arma::mat transition_probs(transition_probs_rcpp.begin(), transition_probs_rcpp.nrow(), transition_probs_rcpp.ncol(), false); arma::colvec initial_dist_extended(initial_dist_extended_rcpp.begin(), initial_dist_extended_rcpp.size(), false); arma::mat beta(beta_rcpp.begin(), beta_rcpp.nrow(), beta_rcpp.ncol(), false); arma::colvec mu(mu_rcpp.begin(), mu_rcpp.size(), false); arma::colvec sigma(sigma_rcpp.begin(), sigma_rcpp.size(), false); arma::mat gamma_dependent(gamma_dependent_rcpp.begin(), gamma_dependent_rcpp.nrow(), gamma_dependent_rcpp.ncol(), false); arma::colvec gamma_independent(gamma_independent_rcpp.begin(), gamma_independent_rcpp.size(), false); arma::imat state_conversion_mat(state_conversion_mat_rcpp.begin(), state_conversion_mat_rcpp.nrow(), state_conversion_mat_rcpp.ncol(), false); arma::mat transition_probs_extended = GetExtendedTransitionProbs( transition_probs, state_conversion_mat); arma::mat transition_probs_extended_t = transition_probs_extended.t(); arma::colvec likelihoods(n, arma::fill::zeros); int M_extended = transition_probs_extended_t.n_rows; int M = gamma_dependent.n_cols; int s = beta.n_rows; int M_extended_block = IntPower(M, s); arma::mat* xi_k_t = new arma::mat(M_extended, n, arma::fill::zeros); // make a transpose first for col operations. // partition blocks int p = gamma_dependent.n_rows; int q = gamma_independent.size(); arma::mat* z_dependent_lagged_blocks = new arma::mat[s]; arma::mat* z_independent_lagged_blocks = new arma::mat[s]; for (int i = 0; i < s; i++) { int z_dependent_block_first = i * p; int z_independent_block_first = i * q; z_dependent_lagged_blocks[i] = z_dependent_lagged.cols(z_dependent_block_first, z_dependent_block_first + p - 1); z_independent_lagged_blocks[i] = z_independent_lagged.cols(z_independent_block_first, z_independent_block_first + q - 1); } for (int k = 0; k < n; k++) { // initial setting; keep track of minimum value and its index // to divide everything by the min. value in order to prevent // possible numerical errors when computing posterior probs. int min_index = -1; double min_value = std::numeric_limits<double>::infinity(); double* ratios = new double[M_extended]; double row_sum = 0; arma::colvec xi_past; if (k > 0) xi_past = transition_probs_extended_t * exp(xi_k_t->col(k-1)); else xi_past = initial_dist_extended; xi_past /= arma::sum(xi_past); for (int j_M = 0; j_M < M; j_M++) { for (int j_extra = 0; j_extra < M_extended_block; j_extra++) { int j = j_M * M_extended_block + j_extra; arma::colvec xi_k_t_jk = y.row(k); // arma::colvec xi_k_t_jk = y.row(k) - // z_dependent.row(k) * gamma_dependent.col(j_M) - // z_independent.row(k) * gamma_independent - mu(j_M); for (int lag = 0; lag < s; lag++) { int lagged_index = state_conversion_mat.at((lag + 1), j); xi_k_t_jk -= beta.at(lag, j_M) * (y_lagged.at(k, lag) - mu(lagged_index)); xi_k_t_jk -= beta.at(lag, j_M) * (y_lagged.at(k, lag) - z_dependent_lagged_blocks[lag].row(k) * gamma_dependent.col(lagged_index) - z_independent_lagged_blocks[lag].row(k) * gamma_independent - mu(lagged_index)); } xi_k_t->at(j,k) = xi_k_t_jk(0); // explicit gluing xi_k_t->at(j,k) *= xi_k_t->at(j,k); xi_k_t->at(j,k) = xi_k_t->at(j,k) / (2 * (sigma(j_M) * sigma(j_M))); if (min_value > xi_k_t->at(j,k)) { min_value = xi_k_t->at(j,k); min_index = j; } // SQRT2PI only matters in calculation of eta; // you can remove it in the final log-likelihood. ratios[j] = xi_past(j) / sigma(j_M); } } for (int j = 0; j < M_extended; j++) { if (j == min_index) row_sum += 1.0; else row_sum += (ratios[j] / ratios[min_index]) * exp(min_value - xi_k_t->at(j,k)); xi_k_t->at(j,k) += log(ratios[j]); } likelihoods(k) = log(row_sum) - min_value + log(ratios[min_index]) - LOG2PI_OVERTWO; delete[] ratios; // clear memory } arma::exp(xi_k_t->cols(1,4)).t().print(); // clear memory for blocks delete[] z_dependent_lagged_blocks; delete[] z_independent_lagged_blocks; delete xi_k_t; return (wrap(likelihoods)); }
//[[Rcpp::export]] Rcpp::List checkTreeCpp(Rcpp::S4 obj, Rcpp::List opts) { std::string err, wrn; Rcpp::IntegerMatrix ed = obj.slot("edge"); int nrow = ed.nrow(); Rcpp::IntegerVector ances = getAnces(ed); //Rcpp::IntegerVector desc = getDesc(ed); int nroots = nRoots(ances); bool rooted = nroots > 0; Rcpp::NumericVector edLength = obj.slot("edge.length"); Rcpp::CharacterVector edLengthNm = edLength.names(); Rcpp::CharacterVector label = obj.slot("label"); Rcpp::CharacterVector labelNm = label.names(); Rcpp::CharacterVector edLabel = obj.slot("edge.label"); Rcpp::CharacterVector edLabelNm = edLabel.names(); Rcpp::IntegerVector allnodesSafe = getAllNodesSafe(ed); Rcpp::IntegerVector allnodesFast = getAllNodesFast(ed, rooted); int nEdLength = edLength.size(); int nLabel = label.size(); int nEdLabel = edLabel.size(); int nEdges = nrow; bool hasEdgeLength = !all_naC(edLength); // check tips int ntipsSafe = nTipsSafe(ances); int ntipsFast = nTipsFastCpp(ances); bool testnTips = ntipsFast == ntipsSafe; if (! testnTips) { err.append("Tips incorrectly labeled. "); } //check internal nodes bool testNodes = Rcpp::all(allnodesSafe == allnodesFast).is_true() && // is both ways comparison needed? Rcpp::all(allnodesFast == allnodesSafe).is_true(); if (! testNodes) { err.append("Nodes incorrectly labeled. "); } // check edge lengths if (hasEdgeLength) { if (nEdLength != nEdges) { err.append("Number of edge lengths do not match number of edges. "); } // if (nb_naC(edLength) > nroots) { // not enough! -- best done in R // err.append("Only the root should have NA as an edge length. "); // } if (getRange(edLength, TRUE)[0] < 0) { err.append("Edge lengths must be non-negative. "); } Rcpp::CharacterVector edgeLblSupp = edgeIdCpp(ed, "all"); Rcpp::CharacterVector edgeLblDiff = Rcpp::setdiff(edLengthNm, edgeLblSupp); if ( edgeLblDiff.size() != 0 ) { err.append("Edge lengths incorrectly labeled. "); } } // check label names Rcpp::CharacterVector chrLabelNm = Rcpp::as<Rcpp::CharacterVector>(allnodesFast); int j = 0; while (j < nroots) { //remove root(s) chrLabelNm.erase(0); j++; } bool testLabelNm = isLabelName(labelNm, chrLabelNm); if (!testLabelNm) { err.append("Tip and node labels must be a named vector, the names must match the node IDs. "); err.append("Use tipLabels<- and/or nodeLabels<- to update them. "); } // check that tips have labels Rcpp::CharacterVector tiplabel(ntipsFast); std::copy (label.begin(), label.begin()+ntipsFast, tiplabel.begin()); bool emptyTipLabel = is_true(any(Rcpp::is_na(tiplabel))); if ( emptyTipLabel ) { err.append("All tips must have a label."); } // check edgeLabels Rcpp::CharacterVector chrEdgeLblNm = edgeIdCpp(ed, "all"); bool testEdgeLblNm = isLabelName(edLabelNm, chrEdgeLblNm); if (!testEdgeLblNm) { err.append("Edge labels are not labelled correctly. Use the function edgeLabels<- to update them. "); } // make sure that tips and node labels are unique if (hasDuplicatedLabelsCpp(label)) { std::string labOpt = opts["allow.duplicated.labels"]; if (labOpt == "fail") { err.append("Labels are not unique. "); } if (labOpt == "warn") { wrn.append("Labels are not unique. "); } } // check for polytomies if (hasPolytomy(ances)) { std::string msgPoly = "Tree includes polytomies. "; std::string polyOpt = opts["poly"]; if (polyOpt == "fail") { err.append(msgPoly); } if (polyOpt == "warn") { wrn.append(msgPoly); } } // check number of roots if (nroots > 1) { std::string msgRoot = "Tree has more than one root. "; std::string rootOpt = opts["multiroot"]; if (rootOpt == "fail") { err.append(msgRoot); } if (rootOpt == "warn") { wrn.append(msgRoot); } } // check for singletons if (hasSingleton(ances)) { std::string msgSing = "Tree contains singleton nodes. "; std::string singOpt = opts["singleton"]; if (singOpt == "fail") { err.append(msgSing); } if (singOpt == "warn") { wrn.append(msgSing); } } return Rcpp::List::create(err, wrn); }
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; }