void RSim::setTimeSeries(SEXP v, const string &obj_name) {
Ptr<SerializableBase> ts;
if(Rf_isMatrix(v)) {
Rcpp::List tsl;
tsl["values"] = v;
tsl.attr("class") = "TimeSeries";
ts = RProto::convertFromR<SerializableBase>(tsl);
} else {
try {
ts = RProto::convertFromR<SerializableBase>(v);
} catch(...) {
ERR("Expecting matrix with values or TimeSeries list object\n");
}
}
auto slice = Factory::inst().getObjectsSlice(obj_name);
for(auto it=slice.first; it != slice.second; ++it) {
Factory::inst().getObject(it)->setAsInput(
ts
);
}
net->spikesList().info = ts.as<TimeSeries>()->info;
for(auto &n: neurons) {
n.ref().initInternal();
}
}
std::string get_single_class(SEXP x) {
SEXP klass = Rf_getAttrib(x, R_ClassSymbol);
if (!Rf_isNull(klass)) {
CharacterVector classes(klass);
return collapse_utf8(classes);
}
if (Rf_isMatrix(x)) {
return "matrix";
}
switch (TYPEOF(x)) {
case INTSXP:
return "integer";
case REALSXP :
return "numeric";
case LGLSXP:
return "logical";
case STRSXP:
return "character";
case VECSXP:
return "list";
default:
break;
}
// just call R to deal with other cases
// we could call R_data_class directly but we might get a "this is not part of the api"
klass = Rf_eval(Rf_lang2(Rf_install("class"), x), R_GlobalEnv);
return CHAR(STRING_ELT(klass,0));
}
ConstSubMatrix ToBoomMatrixView(SEXP m) {
if (!Rf_isMatrix(m)) {
report_error("ToBoomMatrix called with a non-matrix argument");
}
std::pair<int,int> dims = GetMatrixDimensions(m);
PROTECT(m = Rf_coerceVector(m, REALSXP));
ConstSubMatrix ans(REAL(m), dims.first, dims.second);
UNPROTECT(1);
return ans;
}
RcppDateVector::RcppDateVector(SEXP vec) {
int i;
if (!Rf_isNumeric(vec) || Rf_isMatrix(vec) || Rf_isLogical(vec))
throw std::range_error("RcppDateVector: invalid numeric vector in constructor");
int len = Rf_length(vec);
if (len == 0)
throw std::range_error("RcppDateVector: null vector in constructor");
v.resize(len);
for (i = 0; i < len; i++)
v[i] = RcppDate( (int) REAL(vec)[i]);
}
/***
* used both in stri_sub and stri_sub_replacement
*
* @return number of objects PROTECTEd
*/
R_len_t stri__sub_prepare_from_to_length(SEXP& from, SEXP& to, SEXP& length,
R_len_t& from_len, R_len_t& to_len, R_len_t& length_len,
int*& from_tab, int*& to_tab, int*& length_tab)
{
R_len_t sub_protected = 0;
bool from_ismatrix = Rf_isMatrix(from);
if (from_ismatrix) {
SEXP t;
PROTECT(t = Rf_getAttrib(from, R_DimSymbol));
if (INTEGER(t)[1] == 1)
from_ismatrix = false; /* it's a column vector */
else if (INTEGER(t)[1] > 2) {
/* error() is allowed here */
UNPROTECT(1); // t
Rf_error(MSG__ARG_EXPECTED_MATRIX_WITH_GIVEN_COLUMNS, "from", 2);
}
UNPROTECT(1); // t
}
sub_protected++;
PROTECT(from = stri_prepare_arg_integer(from, "from"));
/* may remove R_DimSymbol */
if (from_ismatrix) {
from_len = LENGTH(from)/2;
to_len = from_len;
from_tab = INTEGER(from);
to_tab = from_tab+from_len;
//PROTECT(to); /* fake - not to provoke stack imbalance */
//PROTECT(length); /* fake - not to provoke stack imbalance */
}
else if (isNull(length)) {
sub_protected++;
PROTECT(to = stri_prepare_arg_integer(to, "to"));
from_len = LENGTH(from);
from_tab = INTEGER(from);
to_len = LENGTH(to);
to_tab = INTEGER(to);
//PROTECT(length); /* fake - not to provoke stack imbalance */
}
else {
sub_protected++;
PROTECT(length= stri_prepare_arg_integer(length, "length"));
from_len = LENGTH(from);
from_tab = INTEGER(from);
length_len = LENGTH(length);
length_tab = INTEGER(length);
//PROTECT(to); /* fake - not to provoke stack imbalance */
}
return sub_protected;
}
std::pair<int,int> GetMatrixDimensions(SEXP matrix){
if(!Rf_isMatrix(matrix)){
report_error("GetMatrixDimensions called on a non-matrix object");
// TODO(stevescott): is there a way to find the name of
// offending argument in R, so that I can provide a better error
// message?
}
SEXP dims = PROTECT(Rf_getAttrib(matrix, R_DimSymbol));
if(Rf_length(dims) != 2){
report_error("Wrong number of dimensions in GetMatrixDimensions");
}
int *rdims = INTEGER(dims);
std::pair<int,int> ans = std::make_pair(rdims[0], rdims[1]);
UNPROTECT(1);
return ans;
}
std::vector<double> shape_extractor::getPoint(size_t i)
{
std::vector<double> xyzm;
ATLASSERT(m_points);
if (!m_points)
return xyzm;
if (i >= m_len)
return xyzm;
if (i < m_len)
{
xyzm.resize(4, std::numeric_limits<double>::quiet_NaN());
double z = std::numeric_limits<double>::quiet_NaN(), m = std::numeric_limits<double>::quiet_NaN();
if (m_as_matrix)
{
ATLASSERT(Rf_isMatrix(m_shape));
size_t r = m_len;//INTEGER(dims)[0];
xyzm[0] = REAL(m_shape)[i];
xyzm[1] = REAL(m_shape)[i + r];
if (m_hasZ || m_hasM)
{
m = z = REAL(m_shape)[i + (r*2)];
if (m_hasZ && m_hasM)
m = REAL(m_shape)[i + (r*3)];
}
}
else
{
xyzm[0] = REAL(m_parts[0])[i];
xyzm[1] = REAL(m_parts[1])[i];
if (m_hasZ || m_hasM)
{
double z, m;
m = z = REAL(m_parts[2])[i];
if (m_hasZ && m_hasM)
m = REAL(m_parts[3])[i];
}
}
if (m_hasZ) xyzm[2] = z;
if (m_hasM) xyzm[3] = m;
}
return xyzm;
}
void ifaGroup::import(SEXP Rlist)
{
SEXP argNames;
Rf_protect(argNames = Rf_getAttrib(Rlist, R_NamesSymbol));
if (Rf_length(Rlist) != Rf_length(argNames)) {
mxThrow("All list elements must be named");
}
std::vector<const char *> dataColNames;
paramRows = -1;
int pmatCols=-1;
int mips = 1;
int dataRows = 0;
SEXP Rmean=0, Rcov=0;
for (int ax=0; ax < Rf_length(Rlist); ++ax) {
const char *key = R_CHAR(STRING_ELT(argNames, ax));
SEXP slotValue = VECTOR_ELT(Rlist, ax);
if (strEQ(key, "spec")) {
importSpec(slotValue);
} else if (strEQ(key, "param")) {
if (!Rf_isReal(slotValue)) mxThrow("'param' must be a numeric matrix of item parameters");
param = REAL(slotValue);
getMatrixDims(slotValue, ¶mRows, &pmatCols);
SEXP dimnames;
Rf_protect(dimnames = Rf_getAttrib(slotValue, R_DimNamesSymbol));
if (!Rf_isNull(dimnames) && Rf_length(dimnames) == 2) {
SEXP names;
Rf_protect(names = VECTOR_ELT(dimnames, 0));
int nlen = Rf_length(names);
factorNames.resize(nlen);
for (int nx=0; nx < nlen; ++nx) {
factorNames[nx] = CHAR(STRING_ELT(names, nx));
}
Rf_protect(names = VECTOR_ELT(dimnames, 1));
nlen = Rf_length(names);
itemNames.resize(nlen);
for (int nx=0; nx < nlen; ++nx) {
itemNames[nx] = CHAR(STRING_ELT(names, nx));
}
}
} else if (strEQ(key, "mean")) {
Rmean = slotValue;
if (!Rf_isReal(slotValue)) mxThrow("'mean' must be a numeric vector or matrix");
mean = REAL(slotValue);
} else if (strEQ(key, "cov")) {
Rcov = slotValue;
if (!Rf_isReal(slotValue)) mxThrow("'cov' must be a numeric matrix");
cov = REAL(slotValue);
} else if (strEQ(key, "data")) {
Rdata = slotValue;
dataRows = Rf_length(VECTOR_ELT(Rdata, 0));
SEXP names;
Rf_protect(names = Rf_getAttrib(Rdata, R_NamesSymbol));
int nlen = Rf_length(names);
dataColNames.reserve(nlen);
for (int nx=0; nx < nlen; ++nx) {
dataColNames.push_back(CHAR(STRING_ELT(names, nx)));
}
Rf_protect(dataRowNames = Rf_getAttrib(Rdata, R_RowNamesSymbol));
} else if (strEQ(key, "weightColumn")) {
if (Rf_length(slotValue) != 1) {
mxThrow("You can only have one %s", key);
}
weightColumnName = CHAR(STRING_ELT(slotValue, 0));
} else if (strEQ(key, "freqColumn")) {
if (Rf_length(slotValue) != 1) {
mxThrow("You can only have one %s", key);
}
freqColumnName = CHAR(STRING_ELT(slotValue, 0));
} else if (strEQ(key, "qwidth")) {
qwidth = Rf_asReal(slotValue);
} else if (strEQ(key, "qpoints")) {
qpoints = Rf_asInteger(slotValue);
} else if (strEQ(key, "minItemsPerScore")) {
mips = Rf_asInteger(slotValue);
} else {
// ignore
}
}
learnMaxAbilities();
if (itemDims < (int) factorNames.size())
factorNames.resize(itemDims);
if (int(factorNames.size()) < itemDims) {
factorNames.reserve(itemDims);
const int SMALLBUF = 24;
char buf[SMALLBUF];
while (int(factorNames.size()) < itemDims) {
snprintf(buf, SMALLBUF, "s%d", int(factorNames.size()) + 1);
factorNames.push_back(CHAR(Rf_mkChar(buf)));
}
}
if (Rmean) {
if (Rf_isMatrix(Rmean)) {
int nrow, ncol;
getMatrixDims(Rmean, &nrow, &ncol);
if (!(nrow * ncol == itemDims && (nrow==1 || ncol==1))) {
mxThrow("mean must be a column or row matrix of length %d", itemDims);
}
} else {
if (Rf_length(Rmean) != itemDims) {
mxThrow("mean must be a vector of length %d", itemDims);
}
}
verifyFactorNames(Rmean, "mean");
}
if (Rcov) {
if (Rf_isMatrix(Rcov)) {
int nrow, ncol;
getMatrixDims(Rcov, &nrow, &ncol);
if (nrow != itemDims || ncol != itemDims) {
mxThrow("cov must be %dx%d matrix", itemDims, itemDims);
}
} else {
if (Rf_length(Rcov) != 1) {
mxThrow("cov must be %dx%d matrix", itemDims, itemDims);
}
}
verifyFactorNames(Rcov, "cov");
}
setLatentDistribution(mean, cov);
setMinItemsPerScore(mips);
if (numItems() != pmatCols) {
mxThrow("item matrix implies %d items but spec is length %d",
pmatCols, numItems());
}
if (Rdata) {
if (itemNames.size() == 0) mxThrow("Item matrix must have colnames");
for (int ix=0; ix < numItems(); ++ix) {
bool found=false;
for (int dc=0; dc < int(dataColNames.size()); ++dc) {
if (strEQ(itemNames[ix], dataColNames[dc])) {
SEXP col = VECTOR_ELT(Rdata, dc);
if (!Rf_isFactor(col)) {
if (TYPEOF(col) == INTSXP) {
mxThrow("Column '%s' is an integer but "
"not an ordered factor",
dataColNames[dc]);
} else {
mxThrow("Column '%s' is of type %s; expecting an "
"ordered factor (integer)",
dataColNames[dc], Rf_type2char(TYPEOF(col)));
}
}
dataColumns.push_back(INTEGER(col));
found=true;
break;
}
}
if (!found) {
mxThrow("Cannot find item '%s' in data", itemNames[ix]);
}
}
if (weightColumnName) {
for (int dc=0; dc < int(dataColNames.size()); ++dc) {
if (strEQ(weightColumnName, dataColNames[dc])) {
SEXP col = VECTOR_ELT(Rdata, dc);
if (TYPEOF(col) != REALSXP) {
mxThrow("Column '%s' is of type %s; expecting type numeric (double)",
dataColNames[dc], Rf_type2char(TYPEOF(col)));
}
rowWeight = REAL(col);
break;
}
}
if (!rowWeight) {
mxThrow("Cannot find weight column '%s'", weightColumnName);
}
}
if (freqColumnName) {
for (int dc=0; dc < int(dataColNames.size()); ++dc) {
if (strEQ(freqColumnName, dataColNames[dc])) {
SEXP col = VECTOR_ELT(Rdata, dc);
if (TYPEOF(col) != INTSXP) {
mxThrow("Column '%s' is of type %s; expecting type integer",
dataColNames[dc], Rf_type2char(TYPEOF(col)));
}
rowFreq = INTEGER(col);
break;
}
}
if (!rowFreq) {
mxThrow("Cannot find frequency column '%s'", freqColumnName);
}
}
rowMap.reserve(dataRows);
for (int rx=0; rx < dataRows; ++rx) rowMap.push_back(rx);
}
Eigen::Map< Eigen::ArrayXXd > Eparam(param, paramRows, numItems());
Eigen::Map< Eigen::VectorXd > meanVec(mean, itemDims);
Eigen::Map< Eigen::MatrixXd > covMat(cov, itemDims, itemDims);
quad.setStructure(qwidth, qpoints, Eparam, meanVec, covMat);
if (paramRows < impliedParamRows) {
mxThrow("At least %d rows are required in the item parameter matrix, only %d found",
impliedParamRows, paramRows);
}
quad.refresh(meanVec, covMat);
}
long shape_extractor::at(size_t i, IGeometry **ppNewGeom)
{
if (m_gt == esriGeometryNull)
return S_FALSE;
CComQIPtr<IGeometry> ipNewShape;
if (m_gt == esriGeometryPoint)
{
HRESULT hr = newShape(m_gt, m_ipSR, m_hasZ, m_hasM, &ipNewShape);
if (hr != S_OK)
return showError<true>(L"create new geometry failed"), hr;
CComQIPtr<IPoint> ipPoint(ipNewShape);
double x, y, z, m;
if (m_as_matrix)
{
ATLASSERT(Rf_isMatrix(m_shape));
size_t r = m_len;//INTEGER(dims)[0];
x = REAL(m_shape)[i];
y = REAL(m_shape)[i + r];
if (m_hasZ || m_hasM)
{
m = z = REAL(m_shape)[i + (r*2)];
if (m_hasZ && m_hasM)
m = REAL(m_shape)[i + (r*3)];
}
}
else
{
x = REAL(m_parts[0])[i];
y = REAL(m_parts[1])[i];
if (m_hasZ || m_hasM)
{
double z, m;
m = z = REAL(m_parts[2])[i];
if (m_hasZ && m_hasM)
m = REAL(m_parts[3])[i];
}
}
ipPoint->PutCoords(x, y);
if (m_hasZ) ipPoint->put_Z(z);
if (m_hasM) ipPoint->put_M(m);
return ipNewShape.CopyTo(ppNewGeom);
}
SEXP it = 0;
tools::vectorGeneric geometry(m_shape);
HRESULT hr = newShape(m_gt, m_ipSR, false, false, &ipNewShape);
if (hr != S_OK)
return showError<true>(L"create new geometry failed"), hr;
it = geometry.at(i);
if (Rf_isNull(it))
{
ipNewShape->SetEmpty();
}
else
{
HRESULT hr = S_FALSE;
if (TYPEOF(it) == NILSXP || Rf_isNumeric(it))
hr = ipNewShape->SetEmpty();
else
{
std::vector<BYTE> buff;
if (!tools::copy_to(it, buff))
return showError<false>(L"unknown structure"), E_FAIL;
CComQIPtr<IESRIShape2> ipShape(ipNewShape);
long buffSize = (long)buff.size();
hr = ipShape->ImportFromESRIShapeEx(esriShapeImportNoSwap | esriShapeImportNonTrusted, &buffSize, &buff[0]);
}
if (hr != S_OK)
return showError<true>(L"create new geometry"), hr;
}
return ipNewShape.CopyTo(ppNewGeom);
}
long shape_extractor::init(SEXP sh, SEXP sinfo)
{
if (sh == NULL || Rf_isNull(sh))
return S_FALSE;
//SEXP sinfo = Rf_getAttrib(sh, Rf_install(SHAPE_INFO));
if (Rf_isNull(sinfo))
return S_FALSE;
m_shape = sh;
tools::vectorGeneric shape_info(sinfo);
std::string gt_type;
tools::copy_to(shape_info.at("type"), gt_type);
m_gt = str2geometryType(gt_type.c_str());
if (m_gt == esriGeometryNull)
return S_FALSE;
tools::copy_to(shape_info.at("hasZ"), m_hasZ);
tools::copy_to(shape_info.at("hasM"), m_hasM);
//m_len = tools::size(m_shape);
if (m_gt == esriGeometryPoint)
{
if (Rf_isMatrix(m_shape))
{
if (TYPEOF(m_shape) != REALSXP)
return showError<false>(L"expected type of double for shape list"), E_FAIL;E_FAIL;
m_as_matrix = true;
//return showError<false>(L"for Point geometry 'shape' shoud be matrix"), E_FAIL;E_FAIL;
SEXP dims = Rf_getAttrib(sh, R_DimSymbol);
size_t ndim = tools::size(dims);
if (ndim != 2)
return showError<false>(L"dimention != 2"), E_FAIL;
m_len = (size_t)INTEGER(dims)[0];
int c = INTEGER(dims)[1];
if (m_hasZ && m_hasM && c != 4)
return showError<false>(L"incorrect structue. matrix with 4 columns expected"), E_FAIL;
if ((m_hasZ ^ m_hasM) && c != 3)
return showError<false>(L"incorrect structue. matrix with 3 columns expected"), E_FAIL;
if (!m_hasZ && !m_hasM && c != 2)
return showError<false>(L"incorrect structue. matrix with 2 columns expected"), E_FAIL;
}
else if (Rf_isVectorList(m_shape))
{
m_as_matrix = false;
size_t nn = 2;
nn += m_hasZ ? 1 : 0;
nn += m_hasM ? 1 : 0;
size_t n = (R_len_t)tools::size(m_shape);
if (n < nn)
return showError<false>(L"incorrect list size for Point geometry"), E_FAIL;
n = std::min(n, nn);
//check all arrays must be same len
for (size_t i = 0; i < n; i++)
{
m_parts[i] = VECTOR_ELT(sh, (R_len_t)i);
if (TYPEOF(m_parts[i]) != REALSXP)
return showError<false>(L"expected type of double for shape list"), E_FAIL;E_FAIL;
size_t n = tools::size(m_parts[i]);
if (i == 0)
m_len = n;
else
{
if (m_len != n)
return showError<false>(L"lists are not same sizes"), E_FAIL;
}
}
}
else return showError<false>(L"for Point geometry 'shape' shoud be matrix or list"), E_FAIL;E_FAIL;
}
else
m_len = tools::size(sh);
//CComPtr<ISpatialReferenceFactory3> ipSpatialRefFactory; ipSpatialRefFactory.CoCreateInstance(CLSID_SpatialReferenceEnvironment);
int srid = 0;
std::wstring wkt;
m_ipSR.Release();
if (!tools::copy_to(shape_info.at("WKID"), srid))
tools::copy_to(shape_info.at("WKT"), wkt);
create_sr(srid, wkt, &m_ipSR);
return S_OK;
}
long shape_extractor::init(SEXP sh, SEXP sinfo)
{
if (sh == NULL || Rf_isNull(sh))
return S_FALSE;
if (Rf_isNull(sinfo))
return S_FALSE;
m_shape = sh;
tools::vectorGeneric shape_info(sinfo);
tools::copy_to(shape_info.at("type"), m_geometry_info.first);
m_geometry_info.second.second = 0;
if (m_geometry_info.first.empty())
return S_FALSE;
tools::copy_to(shape_info.at("hasZ"), m_hasZ);
tools::copy_to(shape_info.at("hasM"), m_hasM);
if (m_geometry_info.first == "Point")//esriGeometryPoint)
{
m_points = true;
if (Rf_isMatrix(m_shape))
{
if (TYPEOF(m_shape) != REALSXP)
return showError<false>("expected type of double for shape list"), E_FAIL;E_FAIL;
m_as_matrix = true;
//return showError<false>("for Point geometry 'shape' shoud be matrix"), E_FAIL;E_FAIL;
SEXP dims = Rf_getAttrib(sh, R_DimSymbol);
size_t ndim = tools::size(dims);
if (ndim != 2)
return showError<false>("dimention != 2"), E_FAIL;
m_len = (size_t)INTEGER(dims)[0];
int c = INTEGER(dims)[1];
if (m_hasZ && m_hasM && c != 4)
return showError<false>("incorrect structue. matrix with 4 columns expected"), E_FAIL;
if ((m_hasZ ^ m_hasM) && c != 3)
return showError<false>("incorrect structue. matrix with 3 columns expected"), E_FAIL;
if (!m_hasZ && !m_hasM && c != 2)
return showError<false>("incorrect structue. matrix with 2 columns expected"), E_FAIL;
}
else if (Rf_isVectorList(m_shape))
{
m_as_matrix = false;
size_t nn = 2;
nn += m_hasZ ? 1 : 0;
nn += m_hasM ? 1 : 0;
size_t n = (R_len_t)tools::size(m_shape);
if (n < nn)
return showError<false>("incorrect list size for Point geometry"), E_FAIL;
n = std::min(n, nn);
//check all arrays must be same len
for (size_t i = 0; i < n; i++)
{
m_parts[i] = VECTOR_ELT(sh, (R_len_t)i);
if (TYPEOF(m_parts[i]) != REALSXP)
return showError<false>("expected type of double for shape list"), E_FAIL;
size_t n = tools::size(m_parts[i]);
if (i == 0)
m_len = n;
else
{
if (m_len != n)
return showError<false>("lists are not same sizes"), E_FAIL;
}
}
}
else
return showError<false>("for Point geometry 'shape' shoud be matrix or list"), E_FAIL;
if (m_hasZ)
m_geometry_info.first += ":Z";
if (m_hasM)
m_geometry_info.first += ":M";
}
else
m_len = tools::size(sh);
if (!tools::copy_to(shape_info.at("WKID"), m_geometry_info.second.second))
{
std::wstring wkt;
if (tools::copy_to(shape_info.at("WKT"), wkt))
{
struct eq
{
static bool op(const wchar_t &c) { return c == L'\''; }
};
std::replace_if(wkt.begin(), wkt.end(), eq::op, L'\"');
m_geometry_info.second.first = wkt;
}
}
return S_OK;
}
