void InsetMathMatrix::maple(MapleStream & os) const
{
os << "matrix(" << int(nrows()) << ',' << int(ncols()) << ",[";
for (idx_type idx = 0; idx < nargs(); ++idx) {
if (idx)
os << ',';
os << cell(idx);
}
os << "])";
}
inline size_t Matrix<T>::index(const size_t row, const size_t col) const
{
if(row > nrows())
throw std::runtime_error("row index out of bounds: " + std::to_string(row));
else if(col > ncols())
throw std::runtime_error("column index out of bounds: " + std::to_string(col));
const size_t idx = ncols() * row + col;
assert(idx < size());
return idx;
}
/// Change the dimensions of the matrix. Reallocate if necessary.
/// Existing data in the matrix is invalidated.
///
/// \param num_rows [in] New number of rows in the matrix
/// \param num_cols [in] New number of columns in the matrix
///
/// \warning This does <it>not</it> do the same thing as the
/// Matlab function of the same name. In particular, it does
/// not reinterpret the existing matrix data using different
/// dimensions.
void
reshape (const Ordinal num_rows, const Ordinal num_cols)
{
if (num_rows == nrows() && num_cols == ncols())
return; // no need to reallocate or do anything else
const size_t alloc_size = verified_alloc_size (num_rows, num_cols);
nrows_ = num_rows;
ncols_ = num_cols;
A_.resize (alloc_size);
}
IplImage* host_image2d<V>::getIplImage() const
{
assert(begin_);
//allocate the structure
IplImage* frameIPL = cvCreateImageHeader(cvSize(ncols(),nrows()),
sizeof(typename V::vtype)*8,
V::size);
//init the data structure
cvSetData(frameIPL, (void*)begin(), pitch());
return frameIPL;
}
SparseMatrix& SparseMatrix::operator+=(const SparseMatrix& other)
{
for (int i = 0; i < nrows(); ++i)
for (int j = 0; j < ncols(); ++j)
if (allowed(i, j))
{
assert(other.allowed(i, j));
MatrixScaleAdd(1., other.operator_element(i, j), operator_element(i, j));
}
return *this;
}
double vector::distance(vector v)
{ int i,n = nrows();
double sum = 0.0;
if (n == v.nrows())
for (i = 0; i < n; i++) sum += (el(i) - v.el(i)) * (el(i) - v.el(i));
else
std::cout << "\nIncompatible types of vectors in distance";
return(sqrt(sum));
}
SEXP predictTree(SEXP sp, SEXP x){
if(R_ExternalPtrTag(sp) != install("covatreePointer"))
Rf_error("The pointer must be to a covatree object");
covatree<double>* ptr=(covatree<double>*)R_ExternalPtrAddr(sp);
int dim = ptr->getDim();
if(isMatrix(x)){
MatrixXd res(nrows(x),1 + dim);
MatrixXd x0 = asMatrix(x);
for(int i = 0; i < nrows(x); ++i)
res.row(i) = ptr->operator()((vector)x0.row(i));
return asSEXP(res);
}else if(isNumeric(x)){
return asSEXP(ptr->operator()(asVector(x)));
}else{
Rf_error("Element must be a matrix or numeric vector");
}
return R_NilValue;
}
double vector::inner(vector a)
{ double sum = 0.0;
int i,n = nrows();
if (n == a.nrows())
{ for (i = 0; i < n; i++) sum += el(i) * a.el(i);
} else
{ std::cout << "\nIncompatible types of vectors in inner";
}
return(sum);
}
void corrobj::read_secondary()
{
FILE *fptr;
if (! (fptr = fopen(par.secondary_file, "r")) )
{
cout << "Cannot open secondary file " << par.secondary_file << endl;
exit(45);
}
/* Read the number of rows */
par.nsecondary = nrows(fptr);
cout << endl
<< "Reading " << par.nsecondary << " from secondary file "
<< par.secondary_file << endl;
int nlines = 0;
char c;
while (nlines < SECONDARY_HEADER_LINES)
{
c = getc(fptr);
if (c == '\n') nlines++;
}
secondary.resize(par.nsecondary);
for (int row=0; row< par.nsecondary; row++)
{
fread( &secondary[row].ra, sizeof(double), 1, fptr);
fread( &secondary[row].dec, sizeof(double), 1, fptr);
fread( &secondary[row].gflux, sizeof(float), 1, fptr);
fread( &secondary[row].rflux, sizeof(float), 1, fptr);
fread( &secondary[row].iflux, sizeof(float), 1, fptr);
fread( &secondary[row].htm_index, sizeof(int), 1, fptr);
}
int n = par.nsecondary-1;
cout << "Testing " << endl;
printf(" %lf %lf %f %f %f %d\n",
secondary[0].ra, secondary[0].dec,
secondary[0].gflux, secondary[0].rflux, secondary[0].iflux,
secondary[0].htm_index);
printf(" %lf %lf %f %f %f %d\n",
secondary[n].ra, secondary[n].dec,
secondary[n].gflux, secondary[n].rflux, secondary[n].iflux,
secondary[n].htm_index);
}
SEXP _plot_overlap(SEXP e, SEXP c, SEXP full) {
// Load data and sort
int n = nrows(e);
bool full_bool = *LOGICAL(full);
Endpoints ep ( REAL(e), LOGICAL(c), n, false, full_bool );
// Set sorting order, then sort
Endpoint::set_state_array( reduce_order );
sort( ep.begin(), ep.end() );
// Process
int i;
int active_count = 0;
std::set<int> free_interior;
std::vector<int> y (n);
Endpoints::const_iterator it;
// Initialize to NA
for ( i = 0; i < n; i++ ) y[i] = R_NaInt;
for ( it = ep.begin(); it < ep.end(); it++ ) {
if ( it->left ) {
// Opening an interval
if ( free_interior.size() > 0 ) {
y[ it->index ] = *free_interior.begin();
free_interior.erase( free_interior.begin() );
}
else y[ it->index ] = active_count;
active_count++;
}
else{
// Closing an interval
active_count--;
if ( y[ it->index ] < active_count + free_interior.size() )
free_interior.insert( y[ it->index ] );
}
}
// Prepare and return result.
SEXP result;
PROTECT( result = allocVector( INTSXP, n ) );
copy(
y.begin(), y.end(),
std::vector<int>::iterator ( INTEGER( result ) )
);
UNPROTECT(1);
return( result );
}
void SpinAdapted::Wavefunction::FlattenInto (Matrix& C)
{
int flatIndex = 0;
for (int lQ = 0; lQ < nrows (); ++lQ)
for (int rQ = 0; rQ < ncols (); ++rQ)
if (allowed(lQ, rQ))
flatIndex += operator_element(lQ,rQ).Nrows()*operator_element(lQ,rQ).Ncols();
C.ReSize(flatIndex,1);
flatIndex = 0;
for (int lQ = 0; lQ < nrows (); ++lQ)
for (int rQ = 0; rQ < ncols (); ++rQ)
if (allowed(lQ, rQ))
for (int lQState = 0; lQState < operator_element(lQ, rQ).Nrows (); ++lQState)
for (int rQState = 0; rQState < operator_element(lQ, rQ).Ncols (); ++rQState)
{
C.element (flatIndex,0) = operator_element(lQ, rQ).element (lQState, rQState);
++flatIndex;
}
}
/* function to test svdfirst & eigenfirst from R */
SEXP test_ev(SEXP x, SEXP svd)
{
int KIND = asInteger(svd);
int nr = nrows(x), nc = ncols(x);
SEXP ans = PROTECT(allocVector(REALSXP, 1));
if (KIND)
REAL(ans)[0] = svdfirst(REAL(x), nr, nc);
else
REAL(ans)[0] = eigenfirst(REAL(x), nr);
UNPROTECT(1);
return ans;
}
SEXP d_setMatrix(SEXP m)
{
int
rows = nrows(m), cols = ncols(m);
double * d_m;
cublasAlloc(rows * cols, sizeof(double), (void **)&d_m);
cublasSetMatrix(rows, cols, sizeof(double), REAL(m), rows, d_m, rows);
checkCublasError("d_setMatrix");
return packMatrix(rows, cols, d_m);
}
SEXP predictFillSE(SEXP sp, SEXP x){
if(R_ExternalPtrTag(sp) != install("covafillPointer"))
Rf_error("The pointer must be to a covafill object");
covafill<double>* ptr=(covafill<double>*)R_ExternalPtrAddr(sp);
if(isMatrix(x)){
MatrixXd x0 = asMatrix(x);
int lsdim = 1 + ptr->getDim();
if(ptr->p >= 2)
lsdim += 0.5 * ptr->getDim() * (ptr->getDim() + 1);
if(ptr->p >= 3)
lsdim += (ptr->p - 2) * ptr->getDim();
MatrixXd res(nrows(x),lsdim);
MatrixXd resSE(nrows(x),lsdim);
Array<Array<double,Dynamic,1>, Dynamic,1> tmp(2);
for(int i = 0; i < nrows(x); ++i){
tmp = ptr->operator()((vector)x0.row(i),0, true);
res.row(i) = tmp(0);
resSE.row(i) = tmp(1);
}
SEXP vecOut = PROTECT(allocVector(VECSXP, 2));
SEXP sr1 = PROTECT(asSEXP(res));
SEXP sr2 = PROTECT(asSEXP(resSE));
SET_VECTOR_ELT(vecOut,0,sr1);
SET_VECTOR_ELT(vecOut,1,sr2);
UNPROTECT(3);
return vecOut;
}else{
error("Element must be a matrix or numeric vector");
}
return R_NilValue;
}
// Read the primaries
void corrobj::read_primary()
{
FILE *fptr;
if (! (fptr = fopen(par.primary_file, "r")) )
{
cout << "Cannot open primary file " << par.primary_file << endl;
exit(45);
}
// Read the number of rows
par.nprimary = nrows(fptr);
cout << endl
<< "Reading " << par.nprimary << " from primary file "
<< par.primary_file << endl;
int nlines = 0;
char c;
while (nlines < PRIMARY_HEADER_LINES)
{
c = getc(fptr);
if (c == '\n') nlines++;
}
primary.resize(par.nprimary);
float H0 = 100*par.h;
for (int row=0; row< par.nprimary; row++)
{
fread( &primary[row].index, sizeof(int), 1, fptr);
fread( &primary[row].ra, sizeof(double), 1, fptr);
fread( &primary[row].dec, sizeof(double), 1, fptr);
fread( &primary[row].z, sizeof(float), 1, fptr);
primary[row].DA = angDist(H0, par.omega_m, primary[row].z);
}
int n = par.nprimary-1;
cout << "Testing " << endl;
printf(" %d %f %lf %lf %f\n",
primary[0].index, primary[0].ra, primary[0].dec,
primary[0].z, primary[0].DA);
printf(" %d %f %lf %lf %f\n",
primary[n].index, primary[n].ra, primary[n].dec,
primary[n].z, primary[n].DA);
}
void InsetMathMatrix::octave(OctaveStream & os) const
{
os << '[';
for (row_type row = 0; row < nrows(); ++row) {
if (row)
os << ';';
os << '[';
for (col_type col = 0; col < ncols(); ++col)
os << cell(index(row, col)) << ' ';
os << ']';
}
os << ']';
}
SEXP Dtrmm(SEXP ENV, SEXP A, SEXP B, SEXP ALPHA, SEXP SIDE, SEXP TRANSA, SEXP UPLO, SEXP DIAG)
{
cl_env *env = get_env(ENV);
MATRIXCHECK(A, REALSXP);
MATRIXCHECK(B, REALSXP);
SCALARCHECK(ALPHA, REALSXP);
clblasSide side = getSide(SIDE);
clblasTranspose transA = getTrans(TRANSA);
clblasUplo uplo = getUplo(UPLO);
clblasDiag diag = getDiag(DIAG);
double alpha = SCALARREAL(ALPHA);
int ar = nrows(A), ac = ncols(A), br = nrows(B), bc = ncols(B);
int size_a = LENGTH(A) * sizeof(double);
int size_b = LENGTH(B) * sizeof(double);
double *ap = REAL(A), *bp = REAL(B);
cl_int err = Dtrmm_internal(
env, ap, bp, alpha, side, transA, uplo, diag, ar, ac, br, bc, size_a, size_b);
CHECK(err);
return B;
}
SEXP r_descendants(SEXP node, SEXP edge, SEXP ntip) {
int nedge = nrows(edge), *desc = (int *)R_alloc(nedge, sizeof(int));
int n, *ret_c, node_c = INTEGER(node)[0];
SEXP ret;
n = descendants(node_c, INTEGER(edge), nedge,
INTEGER(ntip)[0], desc);
PROTECT(ret = allocVector(INTSXP, n+1));
ret_c = INTEGER(ret);
ret_c[0] = node_c;
memcpy(ret_c + 1, desc, n*sizeof(int));
UNPROTECT(1);
return ret;
}
SEXP do_wcentre(SEXP x, SEXP w)
{
int nr = nrows(x), nc = ncols(x);
if (TYPEOF(x) != REALSXP)
x = coerceVector(x, REALSXP);
SEXP rx = PROTECT(duplicate(x));
if (TYPEOF(x) != REALSXP)
w = coerceVector(w, REALSXP);
PROTECT(w);
wcentre(REAL(rx), REAL(w), &nr, &nc);
UNPROTECT(2);
return rx;
}
void SpinAdapted::Wavefunction::CollectFrom (const RowVector& C)
{
int flatIndex = 0;
for (int lQ = 0; lQ < nrows (); ++lQ)
for (int rQ = 0; rQ < ncols (); ++rQ)
if (allowedQuantaMatrix (lQ, rQ))
for (int lQState = 0; lQState < operator_element(lQ, rQ).Nrows (); ++lQState)
for (int rQState = 0; rQState < operator_element(lQ, rQ).Ncols (); ++rQState)
{
operator_element(lQ, rQ).element (lQState, rQState) = C.element (flatIndex);
++flatIndex;
}
}
SEXP R_p_matpow_by_squaring(SEXP A, SEXP desca, SEXP b)
{
R_INIT;
const int m = nrows(A), n = ncols(A);
double *cpA;
SEXP P;
newRmat(P, nrows(A), ncols(A), "dbl");
// Why did I make a copy ... ? // Oh now I remember
//FIXME check returns...
cpA = malloc(m*n * sizeof(double));
memcpy(cpA, REAL(A), m*n*sizeof(double));
p_matpow_by_squaring(cpA, INTEGER(desca), INT(b, 0), REAL(P));
free(cpA);
R_END;
return(P);
}
/* Solving systems of linear equations */
SEXP R_PDGESV(SEXP N, SEXP NRHS, SEXP MXLDIMS, SEXP A, SEXP DESCA, SEXP B, SEXP DESCB)
{
R_INIT;
int IJ = 1;
int * ipiv;
double *A_cp;
SEXP RET, RET_NAMES, INFO, B_OUT;
newRvec(INFO, 1, "int");
newRmat(B_OUT, nrows(B), ncols(B), "dbl");
// Copy A and B since pdgesv writes in place
A_cp = (double *) R_alloc(nrows(A)*ncols(A), sizeof(double));
//FIXME check returns...
memcpy(A_cp, DBLP(A), nrows(A)*ncols(A)*sizeof(double));
memcpy(DBLP(B_OUT), DBLP(B), nrows(B)*ncols(B)*sizeof(double));
// Call pdgesv
ipiv = (int *) R_alloc(INT(MXLDIMS, 0) + INT(DESCA, 5), sizeof(int));
/* ipiv = (int *) R_alloc(nrows(B) + INT(DESCA, 5), sizeof(int));*/
INT(INFO, 0) = 0;
pdgesv_(INTP(N), INTP(NRHS),
A_cp, &IJ, &IJ, INTP(DESCA), ipiv,
DBLP(B_OUT), &IJ, &IJ, INTP(DESCB), INTP(INFO));
// Manage return
RET_NAMES = make_list_names(2, "info", "B");
RET = make_list(RET_NAMES, 2, INFO, B_OUT);
R_END;
return RET;
}
void SparseMat::tile(unsigned int i, unsigned int j,
const SparseMat &other)
{
// Add other to this, offset by i rows and j columns.
assert(i + other.nrows() <= nrows());
assert(j + other.ncols() <= ncols());
for(SparseMat::const_iterator kl = other.begin(); kl<other.end(); ++kl) {
unsigned int ii = kl.row() + i;
unsigned int jj = kl.col() + j;
assert(0 <= ii && ii < nrows_);
assert(0 <= jj && jj < ncols_);
insert(ii, jj, *kl);
}
}
SEXP predictFill(SEXP sp, SEXP x){
if(R_ExternalPtrTag(sp) != install("covafillPointer"))
Rf_error("The pointer must be to a covafill object");
covafill<double>* ptr=(covafill<double>*)R_ExternalPtrAddr(sp);
if(isMatrix(x)){
int lsdim = 1 + ptr->getDim();
if(ptr->p >= 2)
lsdim += 0.5 * ptr->getDim() * (ptr->getDim() + 1);
if(ptr->p >= 3)
lsdim += (ptr->p - 2) * ptr->getDim();
MatrixXd res(nrows(x),lsdim);
MatrixXd x0 = asMatrix(x);
for(int i = 0; i < nrows(x); ++i)
res.row(i) = ptr->operator()((vector)x0.row(i), true);
return asSEXP(res);
}else if(isNumeric(x)){
return asSEXP(ptr->operator()(asVector(x), true));
}else{
error("Element must be a matrix or numeric vector");
}
return R_NilValue;
}
SEXP acf(SEXP x, SEXP lmax, SEXP sCor)
{
int nx = nrows(x), ns = ncols(x), lagmax = asInteger(lmax),
cor = asLogical(sCor);
x = PROTECT(coerceVector(x, REALSXP));
SEXP ans = PROTECT(allocVector(REALSXP, (lagmax + 1)*ns*ns));
acf0(REAL(x), nx, ns, lagmax, cor, REAL(ans));
SEXP d = PROTECT(allocVector(INTSXP, 3));
INTEGER(d)[0] = lagmax + 1;
INTEGER(d)[1] = INTEGER(d)[2] = ns;
setAttrib(ans, R_DimSymbol, d);
UNPROTECT(3);
return ans;
}
/* Cholesky */
SEXP R_PDPOTRF(SEXP N, SEXP A, SEXP DESCA, SEXP UPLO)
{
R_INIT;
int IJ = 1;
SEXP RET, RET_NAMES, INFO, C;
newRvec(INFO, 1, "int");
newRmat(C, nrows(A), ncols(A), "dbl");
// Compute chol
memcpy(DBLP(C), DBLP(A), nrows(A)*ncols(A)*sizeof(double));
INT(INFO, 0) = 0;
pdpotrf_(STR(UPLO, 0), INTP(N), DBLP(C), &IJ, &IJ, INTP(DESCA), INTP(INFO));
// Manage return
RET_NAMES = make_list_names(2, "info", "A");
RET = make_list(RET_NAMES, 2, INFO, C);
R_END;
return(RET);
}
void
BvertGrid::cache()
{
assert(is_good());
_RowsCache = nrows() - 1;
_ColsCache = ncols() - 1;
_mesh = bottom().mesh();
assert(_RowsCache > 0 && _ColsCache > 0 && _mesh != nullptr);
_du = 1.0/_ColsCache;
_dv = 1.0/_RowsCache;
}
attribute_hidden
SEXP tspgets(SEXP vec, SEXP val)
{
double start, end, frequency;
int n;
if (vec == R_NilValue)
error(_("attempt to set an attribute on NULL"));
if(IS_S4_OBJECT(vec)) { /* leave validity checking to validObject */
if (!isNumeric(val)) /* but should have been checked */
error(_("'tsp' attribute must be numeric"));
installAttrib(vec, R_TspSymbol, val);
return vec;
}
if (!isNumeric(val) || length(val) != 3)
error(_("'tsp' attribute must be numeric of length three"));
if (isReal(val)) {
start = REAL(val)[0];
end = REAL(val)[1];
frequency = REAL(val)[2];
}
else {
start = (INTEGER(val)[0] == NA_INTEGER) ?
NA_REAL : INTEGER(val)[0];
end = (INTEGER(val)[1] == NA_INTEGER) ?
NA_REAL : INTEGER(val)[1];
frequency = (INTEGER(val)[2] == NA_INTEGER) ?
NA_REAL : INTEGER(val)[2];
}
if (frequency <= 0) badtsp();
n = nrows(vec);
if (n == 0) error(_("cannot assign 'tsp' to zero-length vector"));
/* FIXME: 1.e-5 should rather be == option('ts.eps') !! */
if (fabs(end - start - (n - 1)/frequency) > 1.e-5)
badtsp();
PROTECT(vec);
val = allocVector(REALSXP, 3);
PROTECT(val);
REAL(val)[0] = start;
REAL(val)[1] = end;
REAL(val)[2] = frequency;
installAttrib(vec, R_TspSymbol, val);
UNPROTECT(2);
return vec;
}
template <typename T, typename X> unsigned core_solver_pretty_printer<T, X>:: get_column_width(unsigned column) {
unsigned w = std::max(m_costs[column].size(), T_to_string(m_core_solver.m_x[column]).size());
adjust_width_with_bounds(column, w);
adjust_width_with_basis_heading(column, w);
for (unsigned i = 0; i < nrows(); i++) {
unsigned cellw = m_A[i][column].size();
if (cellw > w) {
w = cellw;
}
}
w = std::max(w, (unsigned)T_to_string(m_exact_column_norms[column]).size());
w = std::max(w, (unsigned)T_to_string(m_core_solver.m_column_norms[column]).size());
return w;
}
template <typename T, typename X> void core_solver_pretty_printer<T, X>::print() {
for (unsigned i = 0; i < nrows(); i++) {
print_row(i);
}
print_bottom_line();
print_cost();
print_x();
print_basis_heading();
print_lows();
print_upps();
print_exact_norms();
print_approx_norms();
m_out << std::endl;
}
