Esempio n. 1
0
// [[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;
}
Esempio n. 2
0
	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
	}
Esempio n. 3
0
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
}
Esempio n. 4
0
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;
}
Esempio n. 5
0
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
}
Esempio n. 6
0
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);	
}
Esempio n. 7
0
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());
}
Esempio n. 8
0
// [[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);
}
Esempio n. 9
0
/* 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:
		;
	}
}
Esempio n. 10
0
// 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));
}
Esempio n. 11
0
//[[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);
}
Esempio n. 12
0
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;
}