guint
asCFlag(USER_OBJECT_ s_flag, GType ftype)
{
GFlagsClass* fclass = g_type_class_ref(ftype);
guint flags = 0;
if (IS_INTEGER(s_flag) || IS_NUMERIC(s_flag)) {
if (asCNumeric(s_flag) > fclass->mask) {
PROBLEM "The flags value %f is too high", asCNumeric(s_flag)
ERROR;
}
flags = asCNumeric(s_flag);
} else {
int i;
for (i = 0; i < GET_LENGTH(s_flag); i++) {
const gchar *fname = CHAR_DEREF(STRING_ELT(s_flag, i));
/*Rprintf("Searching for flag value %s\n", fname);*/
GFlagsValue *fvalue = g_flags_get_value_by_name(fclass, fname);
if (!fvalue)
fvalue = g_flags_get_value_by_nick(fclass, fname);
if (!fvalue && atoi(fname) <= fclass->mask) {
flags |= atoi(fname);
continue;
}
if (!fvalue) {
PROBLEM "Could not find flag by name %s", fname
ERROR;
}
/*Rprintf("Found: %d\n", fvalue->value);*/
flags |= fvalue->value;
}
}
return(flags);
}
/* -------------------------------------------------------------------------- */
SEXP
fillHull(SEXP x) {
SEXP res;
int nprotect = 0;
int nz;
// check image validity
validImage(x,0);
nz = getNumberOfFrames(x, 0);
int *dim=INTEGER(GET_DIM(x));
XYPoint size(dim[0], dim[1]);
// return itself if nothing to do
if (size.x <= 0 || size.y <= 0 || nz < 1) return x;
// do fillHull
PROTECT(res = Rf_duplicate(x));
nprotect++;
if (IS_INTEGER(res)) {
for (int i=0; i < nz; i++) _fillHullT<int>(&(INTEGER(res)[i*size.x*size.y]), size);
}
else if (IS_NUMERIC(res)) {
for (int i=0; i < nz; i++) _fillHullT<double>(&(REAL(res)[i*size.x*size.y]), size);
}
UNPROTECT (nprotect);
return res;
}
gint
asCEnum(USER_OBJECT_ s_enum, GType etype)
{
GEnumClass *eclass = g_type_class_ref(etype);
GEnumValue *evalue = NULL;
gint eval = 0;
if (IS_INTEGER(s_enum) || IS_NUMERIC(s_enum)) {
evalue = g_enum_get_value(eclass, asCInteger(s_enum));
} else if (IS_CHARACTER(s_enum)) {
const gchar* ename = asCString(s_enum);
evalue = g_enum_get_value_by_name(eclass, ename);
if (!evalue)
evalue = g_enum_get_value_by_nick(eclass, ename);
if (!evalue)
evalue = g_enum_get_value(eclass, atoi(ename));
}
if (!evalue) {
PROBLEM "Could not parse enum value %s", asCString(s_enum)
ERROR;
} else eval = evalue->value;
return(eval);
}
TNETS_VALUE
tnets_render_number(char* payload, size_t len) {
size_t i;
int number = 0; // TODO: use a type that can handle
// larger numbers without wrapping.
unsigned short int negative = 0;
if (payload[0] == '-') {
negative = 1;
payload++;
len--;
}
for(i = 0; i < len; i++) {
if (IS_NUMERIC(payload[i])) {
number *= 10;
number += CTOI(payload[i]);
}
else {
TNETS_PARSER_ERROR("Non-numeric character in a tnets number");
}
}
if (negative) {
number *= -1;
}
return TNETS_WRAP_NUMBER(number);
}
/* -------------------------------------------------------------------------- */
SEXP
floodFill(SEXP x, SEXP point, SEXP col, SEXP tol) {
int i, nz, *dim;
int nprotect=0;
XYPoint pt;
SEXP res;
// check image validity
validImage(x,0);
nz = getNumberOfFrames(x, 0);
dim = INTEGER(GET_DIM(x));
XYPoint size(dim[0], dim[1]);
if (size.x <= 0 || size.y <= 0) error("image must have positive dimensions");
if (LENGTH(point) != 2*nz) error("point must have a size of two times the number of frames");
if (LENGTH(col) != nz) error("color must have the same size as the number of frames");
// initialize result
PROTECT(res = Rf_duplicate(x));
nprotect++;
// do the job over images
for (i=0; i<nz; i++) {
pt.x = INTEGER(point)[i]-1;
pt.y = INTEGER(point)[nz+i]-1;
if (IS_NUMERIC(res)) _floodFill<double>(&(REAL(res)[i*size.x*size.y]), size, pt, REAL(col)[i], REAL(tol)[0]);
if (IS_INTEGER(res)) _floodFill<int>(&(INTEGER(res)[i*size.x*size.y]), size, pt, INTEGER(col)[i], REAL(tol)[0]);
}
UNPROTECT (nprotect);
return res;
}
size_t
tnets_size_spec(char *data, size_t len, char **payload) {
size_t i;
size_t size = 0;
// only scan 11 characters (10 for length spec + 1 for colon)
size_t scan_limit = (len < 11) ? len : 11;
for (i = 0; i < scan_limit; i++) {
if (IS_NUMERIC(data[i])) {
size *= 10;
size += CTOI(data[i]);
}
else if (data[i] == ':') {
if (i + size > len + 1) {
TNETS_PARSER_ERROR("length spec longer than given string");
}
if (payload != NULL) {
*payload = data + i + 1; // add one to skip over the colon
}
return size;
}
else {
TNETS_PARSER_ERROR("non-numeric character in length spec");
}
}
TNETS_PARSER_ERROR("length spec more than 10 characters");
return 0;
}
void
TVisitor::castTosAndPrevToSameNumType()
{
VarType tos = tosType();
VarType prev = m_stack.at(m_stack.size()-2);
if (!IS_NUMERIC(tos) || !IS_NUMERIC(prev))
throw std::runtime_error(MSG_NAN_ON_TOS_OR_PREV);
if (tos == prev) {
return;
} else if (prev == VT_DOUBLE) {
castTos(VT_DOUBLE);
} else {
swapTos();
castTos(VT_DOUBLE);
swapTos();
}
}
int GetInt(SEXP p, int default_val, int* err_code){
if(p == R_NilValue){
if(err_code) *err_code = 1;
return default_val;
}else if(IS_INTEGER(p)){
return INTEGER(p)[0];
}else if(IS_LOGICAL(p)){
if(LOGICAL(p)[0]) return 1;
else return 0;
}else if(IS_NUMERIC(p)){
return (int)(REAL(p)[0]);
}else{
if(err_code) *err_code = 2;
return default_val;
}
}
double GetNumeric(SEXP p, double default_val, int* err_code){
if(p == R_NilValue){
if(err_code) *err_code = 1;
return default_val;
}else if(IS_INTEGER(p)){
return INTEGER(p)[0];
}else if(IS_LOGICAL(p)){
if(LOGICAL(p)[0]) return 1.0;
else return 0.0;
}else if(IS_NUMERIC(p)){
return REAL(p)[0];
}else{
if(err_code) *err_code = 2;
return default_val;
}
}
/*************************************************************
** FUNCTION NAME : csb_frm_validate_screen_name
**
** PURPOSE : Validates the entered Screen ID
**
** INPUT PARAMETERS : nil
**
** OUTPUT PARAMETERS : void
**
** RETURNS : void
**
** REMARKS :
***************************************************************/
void csb_frm_validate_screen_name(void)
{
/*----------------------------------------------------------------*/
/* Local Variables */
/*----------------------------------------------------------------*/
U16 index = 0;
U16 scrID = 0;
U8 cat_scr_name_ascii[MAX_CSB_SCREEN_NAME_LENGTH];
U8 local_buffer[MAX_CSB_SCREEN_NAME_LENGTH * ENCODING_LENGTH];
/*----------------------------------------------------------------*/
/* Code Body */
/*----------------------------------------------------------------*/
/* Set the screen counter as 0 */
g_CSB_struct.screen_counter = 0;
/* ASSERT if buffer is NULL */
ASSERT(csb_buffer != NULL);
/* Convert the Unicode string to Ansii as atoi does not work on Unicode */
mmi_ucs2_to_asc((PS8) local_buffer, (PS8) csb_buffer);
/* If nothing was written on the editor */
if(CSB_NULL == *local_buffer)
{
csb_frm_show_error_message();
return;
}
else if(IS_NUMERIC(*local_buffer))
{
scrID = (U16) atoi((S8*)local_buffer);
while(index < TOTAL_CATEGORY_SCREENS)
{
/* If the entered screen ID is the current screen ID, set the global screen counter
and break the loop */
if(g_CSB_struct.pscreen_info[index].cat_ID == scrID)
{
g_CSB_struct.screen_counter = index;
break;
}
index++;
}
/* This will happen only when entered screen ID is not in the list */
if(g_CSB_struct.screen_counter != index)
{
csb_frm_show_error_message();
return;
}
}
else if(IS_ALPHABET(*local_buffer))
{
while(index < TOTAL_CATEGORY_SCREENS)
{
/* All category without ID will be on the top of the database having ID = 0,
it is the limitation of the design */
if(g_CSB_struct.pscreen_info[index].cat_ID != 0)
break;
/* Convert the name of Category screen from Unicode to Ansii */
mmi_ucs2_to_asc((PS8)cat_scr_name_ascii, (PS8)g_CSB_struct.pscreen_info[index].cat_scr_name);
/* Check, if the database have the matched the screen name */
if(!(strcmp((S8*)cat_scr_name_ascii, (S8*)local_buffer)))
{
/* If yes, then store the current index and break */
g_CSB_struct.screen_counter = index;
break;
}
index++;
}
/* This will happen only when entered screen name is not in the list */
if(g_CSB_struct.screen_counter != index)
{
csb_frm_show_error_message();
return;
}
}
else
{
csb_frm_show_error_message();
return;
}
/* Clear the buffer after use */
memset(csb_buffer, CSB_NULL, MAX_CSB_SCREEN_NAME_LENGTH);
ASSERT(TOTAL_CATEGORY_SCREENS > g_CSB_struct.screen_counter);
EntryCSBStartView();
}
/**
* position must be a list
* If the list consists of two numbers (x y) the surface will be rendered at location x,y
* the same is true for (plain x y)
* (x y)
* (plain x y) x,y = numbers, rendered with top left corner at x,y with scale=1
* (full) fullscreen
* (centered)
* (scaled)
* (sized)
* (rotated)
* (windowed)
*/
Bool graphics_render_at_position(Renderable *renderable, Value position, Environment *environment) {
if (environment -> fast_run) {return false;}
profiler_start(profile_render);
Double width = renderable -> width;
Double height = renderable -> height;
Double screen_width = environment -> width;
Double screen_height = environment -> height;
cairo_save(environment -> cairo);
if (position.type == NIL) {
cairo_scale(environment -> cairo, screen_width/width, screen_height/height);
goto RENDER;
}
if (!IS_LIST(position)) {
log_error_in;
goto ERROR;
}
if (position.type != CONS) {
log_error_in;
goto ERROR;
}
Value length_val = list_length(position);
if (length_val.type != INTEGER) {
log_error_in;
goto ERROR;
}
Unt length = NUM_VAL(length_val);
Value first = NEXT(position);
if (first.type == SYMBOL) {
if (equal(first, symbols_plain)) {
/**** plain ****/
/* Render at coords, unscaled */
if (length == 3) {
Value x = NEXT(position);
Value y = NEXT(position);
if (IS_NUMERIC(x) && IS_NUMERIC(y)) {
cairo_translate(environment -> cairo, NUM_VAL(x), NUM_VAL(y));
goto RENDER;
} /* Return a specific error? */
}
} else if (equal(first, symbols_full)) {
/**** full ****/
/* Stretch image to fill entire screen */
if (length == 1) {
cairo_scale(environment -> cairo, screen_width/width, screen_height/height);
goto RENDER;
}
} else if (equal(first, symbols_centered)) {
/**** centered ****/
if (length == 3) {
Value x = NEXT(position);
Value y = NEXT(position);
if (x.type == INTEGER && y.type == INTEGER) {
/* Render offset from center */
Double dx = (screen_width - width) / 2 + NUM_VAL(x);
Double dy = (screen_height - height) / 2 + NUM_VAL(y);
cairo_translate(environment -> cairo, dx, dy);
goto RENDER;
}
if (x.type == FLOAT && y.type == FLOAT) {
/* As in sized */
Double dx = (screen_width - width) / 2 + ((screen_width - width)/2 * NUM_VAL(x));
Double dy = (screen_height - height) / 2 + ((screen_height - height)/2 * NUM_VAL(y));
cairo_translate(environment -> cairo, dx, dy);
goto RENDER;
}
} else if (length == 1) {
Double dx = (screen_width - width) / 2;
Double dy = (screen_height - height) / 2;
cairo_translate(environment -> cairo, dx, dy);
}
} else if (equal(first, symbols_scaled)) {
/**** scaled ****/
/* ('scaled x y scale) */
/* ('scaled x y scalex scaley) */
/* TODO: make it work with relative float positions */
if (length < 4 || length > 5) {
log_error_in;
goto ERROR;
}
Value x_val = NEXT(position);
Value y_val = NEXT(position);
Value scale_x = NEXT(position);
Value scale_y = scale_x;
if (length == 5) {
scale_y = NEXT(position);
}
Double new_width;
Double new_height;
if (scale_x.type == INTEGER) {
new_width = NUM_VAL(scale_x);
} else if (scale_x.type == FLOAT) {
new_width = width * NUM_VAL(scale_x);
} else {
log_error_in;
goto ERROR;
}
if (scale_y.type == INTEGER) {
new_height = NUM_VAL(scale_y);
} else if (scale_y.type == FLOAT) {
new_height = height * NUM_VAL(scale_y);
} else {
log_error_in;
goto ERROR;
}
Double x = 0;
Double y = 0;
if (x_val.type == INTEGER) {
x = NUM_VAL(x_val);
} else if (x_val.type == FLOAT) {
x = (screen_width - new_width) / 2 + ((screen_width - new_width)/2 * NUM_VAL(x_val));
} else {
log_error_in;
goto ERROR;
}
if (y_val.type == INTEGER) {
y = NUM_VAL(y_val);
} else if (y_val.type == FLOAT) {
y = (screen_height - new_height) / 2 + ((screen_height - new_height)/2 * NUM_VAL(y_val));
} else {
log_error_in;
goto ERROR;
}
cairo_translate(environment -> cairo, x, y);
cairo_scale(environment -> cairo, new_width/width, new_height/height);
goto RENDER;
} else if (equal(first, symbols_sized)) {
/**** sized ****/
/* ('sized x y sizex/boundx sizey/boundy) */
/* Render scaled but keep aspect ratio */
if (length < 4 || length > 5) {
log_error_in;
goto ERROR;
}
Value x_val = NEXT(position);
Value y_val = NEXT(position);
Value size_x = NEXT(position);
Value size_y = size_x;
if (length == 5) {
size_y = NEXT(position);
}
Double desired_width;
Double desired_height;
if (size_x.type == INTEGER) {
desired_width = NUM_VAL(size_x);
} else if (size_x.type == FLOAT) {
desired_width = screen_width * NUM_VAL(size_x);
} else {
log_error_in;
goto ERROR;
}
if (size_y.type == INTEGER) {
desired_height = NUM_VAL(size_y);
} else if (size_y.type == FLOAT) {
desired_height = screen_height * NUM_VAL(size_y);
} else {
log_error_in;
goto ERROR;
}
Double new_width;
Double new_height;
Double ratio_w = desired_width / width;
Double ratio_h = desired_height / height;
if (ratio_w <= ratio_h) {
new_height = desired_width * ((Double) height / (Double) width);
new_width = desired_width;
} else {
new_width = desired_height * ((Double) width / (Double) height);
new_height = desired_height;
}
Double x = 0;
Double y = 0;
if (x_val.type == INTEGER) {
x = NUM_VAL(x_val);
} else if (x_val.type == FLOAT) {
x = (screen_width - new_width) / 2 + ((screen_width - new_width)/2 * NUM_VAL(x_val));
} else {
log_error_in;
goto ERROR;
}
if (y_val.type == INTEGER) {
y = NUM_VAL(y_val);
} else if (y_val.type == FLOAT) {
y = (screen_height - new_height) / 2 + ((screen_height - new_height)/2 * NUM_VAL(y_val));
} else {
log_error_in;
goto ERROR;
}
cairo_translate(environment -> cairo, x, y);
cairo_scale(environment -> cairo, new_width/width, new_height/height);
goto RENDER;
} else if (equal(first, symbols_rotated)) {
/**** Rotated ****/
if (length < 4) {
log_error_in;
goto ERROR;
}
Value angle_v = NEXT(position);
if (!IS_NUMERIC(angle_v)) {
log_error_in;
goto ERROR;
}
Double angle = NUM_VAL(angle_v);
Value x = NEXT(position);
Value y = NEXT(position);
if (!IS_NUMERIC(x) || !IS_NUMERIC(y)) {
log_error_in;
goto ERROR;
}
Double dx = NUM_VAL(x);
Double dy = NUM_VAL(y);
Value scale_x;
Value scale_y;
if (length == 5) {
scale_x = NEXT(position);
scale_y = scale_x;
} else if (length == 6) {
scale_x = NEXT(position);
scale_y = NEXT(position);
} else {
log_error_in;
goto ERROR;
}
Double sx;
Double sy;
if (scale_x.type == INTEGER && scale_y.type == INTEGER) {
sx = NUM_VAL(scale_x)/width;
sy = NUM_VAL(scale_y)/height;
} else if (scale_x.type == FLOAT && scale_y.type == FLOAT) {
sx = NUM_VAL(scale_x);
sy = NUM_VAL(scale_y);
} else {
log_error_in;
goto ERROR;
}
if (sx == 0.0 || sy == 0.0) {
/* Scaled to 0, thus is not shown. Cairo freezes if given scales of 0 */
return true;
}
cairo_translate(environment -> cairo, dx, dy);
cairo_translate(environment -> cairo, sx*width/2, sx*height/2);
cairo_rotate(environment -> cairo, angle);
cairo_scale(environment -> cairo, sx, sy);
cairo_translate(environment -> cairo, -width/2, -height/2);
goto RENDER;
}
} else if (IS_NUMERIC(first) && length == 2) {/* (x y) */
Value second = NEXT(position);
if (IS_NUMERIC(second)) {
Double x = NUM_VAL(first);
Double y = NUM_VAL(second);
cairo_translate(environment -> cairo, x, y);
goto RENDER;
}
}
ERROR:
cairo_restore(environment -> cairo);
profiler_end(profile_render);
return false;
RENDER:
renderable -> render(renderable -> data, environment);
/* cairo_set_source_surface(environment -> cairo, surface, 0, 0); */
/* cairo_paint(environment -> cairo); */
cairo_restore(environment -> cairo);
profiler_end(profile_render);
return true;
}
SEXP fastcluster_vector(SEXP const method_,
SEXP const metric_,
SEXP X_,
SEXP members_,
SEXP p_) {
SEXP r = NULL; // return value
try{
/*
Input checks
*/
// Parameter method: dissimilarity index update method
PROTECT(method_);
if (!IS_INTEGER(method_) || LENGTH(method_)!=1)
Rf_error("'method' must be a single integer.");
int method = *INTEGER_POINTER(method_) - 1; // index-0 based;
if (method<METHOD_VECTOR_SINGLE || method>METHOD_VECTOR_MEDIAN) {
Rf_error("Invalid method index.");
}
UNPROTECT(1); // method_
// Parameter metric
PROTECT(metric_);
if (!IS_INTEGER(metric_) || LENGTH(metric_)!=1)
Rf_error("'metric' must be a single integer.");
int metric = *INTEGER_POINTER(metric_) - 1; // index-0 based;
if (metric<0 || metric>5 ||
(method!=METHOD_VECTOR_SINGLE && metric!=0) ) {
Rf_error("Invalid metric index.");
}
UNPROTECT(1); // metric_
// data array
PROTECT(X_ = AS_NUMERIC(X_));
SEXP dims_ = PROTECT( Rf_getAttrib( X_, R_DimSymbol ) ) ;
if( dims_ == R_NilValue || LENGTH(dims_) != 2 ) {
Rf_error( "Argument is not a matrix.");
}
const int * const dims = INTEGER(dims_);
const int N = dims[0];
const int dim = dims[1];
if (N<2)
Rf_error("There must be at least two data points.");
// Make a working copy of the dissimilarity array
// for all methods except "single".
double * X__ = NUMERIC_POINTER(X_);
// Copy the input array and change it from Fortran-contiguous style
// to C-contiguous style
// (Waste of memory for 'single'; the other methods need a copy
auto_array_ptr<double> X(LENGTH(X_));
for (std::ptrdiff_t i=0; i<N; ++i)
for (std::ptrdiff_t j=0; j<dim; ++j)
X[i*dim+j] = X__[i+j*N];
UNPROTECT(2); // dims_, X_
// Parameter members: number of members in each node
auto_array_ptr<t_float> members;
if (method==METHOD_VECTOR_WARD ||
method==METHOD_VECTOR_CENTROID) {
members.init(N);
if (Rf_isNull(members_)) {
for (t_index i=0; i<N; ++i) members[i] = 1;
}
else {
PROTECT(members_ = AS_NUMERIC(members_));
if (LENGTH(members_)!=N)
Rf_error("The length of 'members' must be the same as the number of data points.");
const t_float * const m = NUMERIC_POINTER(members_);
for (t_index i=0; i<N; ++i) members[i] = m[i];
UNPROTECT(1); // members
}
}
// Parameter p
PROTECT(p_);
double p = 0;
if (metric==METRIC_R_MINKOWSKI) {
if (!IS_NUMERIC(p_) || LENGTH(p_)!=1)
Rf_error("'p' must be a single floating point number.");
p = *NUMERIC_POINTER(p_);
}
else {
if (p_ != R_NilValue) {
Rf_error("No metric except 'minkowski' allows a 'p' parameter.");
}
}
UNPROTECT(1); // p_
/* The generic_linkage_vector_alternative algorithm uses labels
N,N+1,... for the new nodes, so we need a table which node is
stored in which row.
Instructions: Set this variable to true for all methods which
use the generic_linkage_vector_alternative algorithm below.
*/
bool make_row_repr =
(method==METHOD_VECTOR_CENTROID || method==METHOD_VECTOR_MEDIAN);
R_dissimilarity dist(X, N, dim, members,
static_cast<unsigned char>(method),
static_cast<unsigned char>(metric),
p,
make_row_repr);
cluster_result Z2(N-1);
/*
Clustering step
*/
switch (method) {
case METHOD_VECTOR_SINGLE:
MST_linkage_core_vector(N, dist, Z2);
break;
case METHOD_VECTOR_WARD:
generic_linkage_vector<METHOD_METR_WARD>(N, dist, Z2);
break;
case METHOD_VECTOR_CENTROID:
generic_linkage_vector_alternative<METHOD_METR_CENTROID>(N, dist, Z2);
break;
case METHOD_VECTOR_MEDIAN:
generic_linkage_vector_alternative<METHOD_METR_MEDIAN>(N, dist, Z2);
break;
default:
throw std::runtime_error(std::string("Invalid method."));
}
X.free(); // Free the memory now
members.free(); // (not strictly necessary).
dist.postprocess(Z2);
SEXP m; // return field "merge"
PROTECT(m = NEW_INTEGER(2*(N-1)));
int * const merge = INTEGER_POINTER(m);
SEXP dim_m; // Specify that m is an (N-1)×2 matrix
PROTECT(dim_m = NEW_INTEGER(2));
INTEGER(dim_m)[0] = N-1;
INTEGER(dim_m)[1] = 2;
SET_DIM(m, dim_m);
SEXP h; // return field "height"
PROTECT(h = NEW_NUMERIC(N-1));
double * const height = NUMERIC_POINTER(h);
SEXP o; // return fiels "order'
PROTECT(o = NEW_INTEGER(N));
int * const order = INTEGER_POINTER(o);
if (method==METHOD_VECTOR_SINGLE)
generate_R_dendrogram<false>(merge, height, order, Z2, N);
else
generate_R_dendrogram<true>(merge, height, order, Z2, N);
SEXP n; // names
PROTECT(n = NEW_CHARACTER(3));
SET_STRING_ELT(n, 0, COPY_TO_USER_STRING("merge"));
SET_STRING_ELT(n, 1, COPY_TO_USER_STRING("height"));
SET_STRING_ELT(n, 2, COPY_TO_USER_STRING("order"));
PROTECT(r = NEW_LIST(3)); // field names in the output list
SET_ELEMENT(r, 0, m);
SET_ELEMENT(r, 1, h);
SET_ELEMENT(r, 2, o);
SET_NAMES(r, n);
UNPROTECT(6); // m, dim_m, h, o, r, n
} // try
catch (const std::bad_alloc&) {
Rf_error( "Memory overflow.");
}
catch(const std::exception& e){
Rf_error( e.what() );
}
catch(const nan_error&){
Rf_error("NaN dissimilarity value.");
}
catch(...){
Rf_error( "C++ exception (unknown reason)." );
}
return r;
}
bool CsvChunkLoader::loadChunk(boost::shared_ptr<Query>& query, size_t chunkIndex)
{
// Must do EOF check *before* nextImplicitChunkPosition() call, or
// we risk stepping out of bounds.
if (_csvParser.empty()) {
int ch = ::getc(fp());
if (ch == EOF) {
return false;
}
::ungetc(ch, fp());
}
// Reposition and make sure all is cool.
nextImplicitChunkPosition(MY_CHUNK);
enforceChunkOrder("csv loader");
// Initialize a chunk and chunk iterator for each attribute.
Attributes const& attrs = schema().getAttributes();
size_t nAttrs = attrs.size();
vector< boost::shared_ptr<ChunkIterator> > chunkIterators(nAttrs);
for (size_t i = 0; i < nAttrs; i++) {
Address addr(i, _chunkPos);
MemChunk& chunk = getLookaheadChunk(i, chunkIndex);
chunk.initialize(array(), &schema(), addr, attrs[i].getDefaultCompressionMethod());
chunkIterators[i] = chunk.getIterator(query,
ChunkIterator::NO_EMPTY_CHECK |
ConstChunkIterator::SEQUENTIAL_WRITE);
}
char const *field = 0;
int rc = 0;
bool sawData = false;
bool sawEof = false;
while (!chunkIterators[0]->end()) {
_column = 0;
array()->countCell();
// Parse and write out a line's worth of fields. NB if you
// have to 'continue;' after a writeItem() call, make sure the
// iterator (and possibly the _column) gets incremented.
//
for (size_t i = 0; i < nAttrs; ++i) {
try {
// Handle empty tag...
if (i == emptyTagAttrId()) {
attrVal(i).setBool(true);
chunkIterators[i]->writeItem(attrVal(i));
++(*chunkIterators[i]); // ...but don't increment _column.
continue;
}
// Parse out next input field.
rc = _csvParser.getField(field);
if (rc == CsvParser::END_OF_FILE) {
sawEof = true;
break;
}
if (rc == CsvParser::END_OF_RECORD) {
// Got record terminator, but we have more attributes!
throw USER_EXCEPTION(SCIDB_SE_IMPORT_ERROR, SCIDB_LE_OP_INPUT_TOO_FEW_FIELDS)
<< _csvParser.getFileOffset() << _csvParser.getRecordNumber() << _column;
}
if (rc > 0) {
// So long as we never call _csvParser.setStrict(true), we should never see this.
throw USER_EXCEPTION(SCIDB_SE_IMPORT_ERROR, SCIDB_LE_CSV_PARSE_ERROR)
<< _csvParser.getFileOffset() << _csvParser.getRecordNumber()
<< _column << csv_strerror(rc);
}
SCIDB_ASSERT(rc == CsvParser::OK);
SCIDB_ASSERT(field);
sawData = true;
// Process input field.
if (mightBeNull(field) && attrs[i].isNullable()) {
int8_t missingReason = parseNullField(field);
if (missingReason >= 0) {
attrVal(i).setNull(missingReason);
chunkIterators[i]->writeItem(attrVal(i));
++(*chunkIterators[i]);
_column += 1;
continue;
}
}
if (converter(i)) {
Value v;
v.setString(field);
const Value* vp = &v;
(*converter(i))(&vp, &attrVal(i), NULL);
chunkIterators[i]->writeItem(attrVal(i));
}
else {
TypeId const &tid = typeIdOfAttr(i);
if (attrs[i].isNullable() &&
(*field == '\0' || (iswhitespace(field) && IS_NUMERIC(tid))))
{
// [csv2scidb compat] With csv2scidb, empty strings (or for numeric
// fields, whitespace) became nulls if the target attribute was
// nullable. We keep the same behavior. (We should *not* do this for
// TSV, that format requires explicit nulls!)
attrVal(i).setNull();
} else {
StringToValue(tid, field, attrVal(i));
}
chunkIterators[i]->writeItem(attrVal(i));
}
}
catch (Exception& ex) {
_badField = field;
_fileOffset = _csvParser.getFileOffset();
array()->handleError(ex, chunkIterators[i], i);
}
_column += 1;
++(*chunkIterators[i]);
}
if (sawEof) {
break;
}
// We should be at EOL now, otherwise there are too many fields on this line. Post a
// warning: it seems useful not to complain too loudly about this or to abort the load, but
// we do want to mention it.
//
rc = _csvParser.getField(field);
if (!_tooManyWarning && (rc != CsvParser::END_OF_RECORD)) {
_tooManyWarning = true;
query->postWarning(SCIDB_WARNING(SCIDB_LE_OP_INPUT_TOO_MANY_FIELDS)
<< _csvParser.getFileOffset() << _csvParser.getRecordNumber() << _column);
}
array()->completeShadowArrayRow(); // done with cell/record
}
for (size_t i = 0; i < nAttrs; i++) {
if (chunkIterators[i]) {
chunkIterators[i]->flush();
}
}
return sawData;
}
SEXP do_init_state (SEXP object, SEXP params, SEXP t0, SEXP nsim, SEXP gnsi)
{
int nprotect = 0;
SEXP Pnames, Snames;
SEXP x = R_NilValue;
int *dim;
int npar, nrep, nvar, ns;
int definit;
int xdim[2];
const char *dimnms[2] = {"variable","rep"};
ns = *(INTEGER(AS_INTEGER(nsim)));
PROTECT(params = as_matrix(params)); nprotect++;
PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++;
dim = INTEGER(GET_DIM(params));
npar = dim[0]; nrep = dim[1];
if (ns % nrep != 0)
errorcall(R_NilValue,"in 'init.state': number of desired state-vectors 'nsim' is not a multiple of ncol('params')");
definit = *(INTEGER(GET_SLOT(object,install("default.init"))));
if (definit) { // default initializer
SEXP fcall, pat, repl, val, ivpnames, statenames;
int *pidx, j, k;
double *xp, *pp;
PROTECT(pat = NEW_CHARACTER(1)); nprotect++;
SET_STRING_ELT(pat,0,mkChar("\\.0$"));
PROTECT(repl = NEW_CHARACTER(1)); nprotect++;
SET_STRING_ELT(repl,0,mkChar(""));
PROTECT(val = NEW_LOGICAL(1)); nprotect++;
*(INTEGER(val)) = 1;
// extract names of IVPs
PROTECT(fcall = LCONS(val,R_NilValue)); nprotect++;
SET_TAG(fcall,install("value"));
PROTECT(fcall = LCONS(Pnames,fcall)); nprotect++;
SET_TAG(fcall,install("x"));
PROTECT(fcall = LCONS(pat,fcall)); nprotect++;
SET_TAG(fcall,install("pattern"));
PROTECT(fcall = LCONS(install("grep"),fcall)); nprotect++;
PROTECT(ivpnames = eval(fcall,R_BaseEnv)); nprotect++;
nvar = LENGTH(ivpnames);
if (nvar < 1) {
errorcall(R_NilValue,"in default 'initializer': there are no parameters with suffix '.0'. See '?pomp'.");
}
pidx = INTEGER(PROTECT(match(Pnames,ivpnames,0))); nprotect++;
for (k = 0; k < nvar; k++) pidx[k]--;
// construct names of state variables
PROTECT(fcall = LCONS(ivpnames,R_NilValue)); nprotect++;
SET_TAG(fcall,install("x"));
PROTECT(fcall = LCONS(repl,fcall)); nprotect++;
SET_TAG(fcall,install("replacement"));
PROTECT(fcall = LCONS(pat,fcall)); nprotect++;
SET_TAG(fcall,install("pattern"));
PROTECT(fcall = LCONS(install("sub"),fcall)); nprotect++;
PROTECT(statenames = eval(fcall,R_BaseEnv)); nprotect++;
xdim[0] = nvar; xdim[1] = ns;
PROTECT(x = makearray(2,xdim)); nprotect++;
setrownames(x,statenames,2);
fixdimnames(x,dimnms,2);
for (j = 0, xp = REAL(x); j < ns; j++) {
pp = REAL(params) + npar*(j%nrep);
for (k = 0; k < nvar; k++, xp++)
*xp = pp[pidx[k]];
}
} else { // user-supplied initializer
SEXP pompfun, fcall, fn, tcovar, covar, covars = R_NilValue;
pompfunmode mode = undef;
double *cp = NULL;
// extract the initializer function and its environment
PROTECT(pompfun = GET_SLOT(object,install("initializer"))); nprotect++;
PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode)); nprotect++;
// extract covariates and interpolate
PROTECT(tcovar = GET_SLOT(object,install("tcovar"))); nprotect++;
if (LENGTH(tcovar) > 0) { // do table lookup
PROTECT(covar = GET_SLOT(object,install("covar"))); nprotect++;
PROTECT(covars = lookup_in_table(tcovar,covar,t0)); nprotect++;
cp = REAL(covars);
}
// extract userdata
PROTECT(fcall = VectorToPairList(GET_SLOT(object,install("userdata")))); nprotect++;
switch (mode) {
case Rfun: // use R function
{
SEXP par, rho, x1, x2;
double *p, *pp, *xp, *xt;
int j, *midx;
// extract covariates and interpolate
if (LENGTH(tcovar) > 0) { // add covars to call
PROTECT(fcall = LCONS(covars,fcall)); nprotect++;
SET_TAG(fcall,install("covars"));
}
// parameter vector
PROTECT(par = NEW_NUMERIC(npar)); nprotect++;
SET_NAMES(par,Pnames);
pp = REAL(par);
// finish constructing the call
PROTECT(fcall = LCONS(t0,fcall)); nprotect++;
SET_TAG(fcall,install("t0"));
PROTECT(fcall = LCONS(par,fcall)); nprotect++;
SET_TAG(fcall,install("params"));
PROTECT(fcall = LCONS(fn,fcall)); nprotect++;
// evaluation environment
PROTECT(rho = (CLOENV(fn))); nprotect++;
p = REAL(params);
memcpy(pp,p,npar*sizeof(double)); // copy the parameters
PROTECT(x1 = eval(fcall,rho)); nprotect++; // do the call
PROTECT(Snames = GET_NAMES(x1)); nprotect++;
if (!IS_NUMERIC(x1) || isNull(Snames)) {
UNPROTECT(nprotect);
errorcall(R_NilValue,"in 'init.state': user 'initializer' must return a named numeric vector");
}
nvar = LENGTH(x1);
xp = REAL(x1);
midx = INTEGER(PROTECT(match(Pnames,Snames,0))); nprotect++;
for (j = 0; j < nvar; j++) {
if (midx[j]!=0) {
UNPROTECT(nprotect);
errorcall(R_NilValue,"in 'init.state': a state variable and a parameter share a single name: '%s'",CHARACTER_DATA(STRING_ELT(Snames,j)));
}
}
xdim[0] = nvar; xdim[1] = ns;
PROTECT(x = makearray(2,xdim)); nprotect++;
setrownames(x,Snames,2);
fixdimnames(x,dimnms,2);
xt = REAL(x);
memcpy(xt,xp,nvar*sizeof(double));
for (j = 1, xt += nvar; j < ns; j++, xt += nvar) {
memcpy(pp,p+npar*(j%nrep),npar*sizeof(double));
PROTECT(x2 = eval(fcall,rho));
xp = REAL(x2);
if (LENGTH(x2)!=nvar)
errorcall(R_NilValue,"in 'init.state': user initializer returns vectors of non-uniform length");
memcpy(xt,xp,nvar*sizeof(double));
UNPROTECT(1);
}
}
break;
case native: // use native routine
{
SEXP Cnames;
int *sidx, *pidx, *cidx;
double *xt, *ps, time;
pomp_initializer *ff = NULL;
int j;
PROTECT(Snames = GET_SLOT(pompfun,install("statenames"))); nprotect++;
PROTECT(Cnames = GET_COLNAMES(GET_DIMNAMES(GET_SLOT(object,install("covar"))))); nprotect++;
// construct state, parameter, covariate, observable indices
sidx = INTEGER(PROTECT(name_index(Snames,pompfun,"statenames","state variables"))); nprotect++;
pidx = INTEGER(PROTECT(name_index(Pnames,pompfun,"paramnames","parameters"))); nprotect++;
cidx = INTEGER(PROTECT(name_index(Cnames,pompfun,"covarnames","covariates"))); nprotect++;
// address of native routine
*((void **) (&ff)) = R_ExternalPtrAddr(fn);
nvar = LENGTH(Snames);
xdim[0] = nvar; xdim[1] = ns;
PROTECT(x = makearray(2,xdim)); nprotect++;
setrownames(x,Snames,2);
fixdimnames(x,dimnms,2);
set_pomp_userdata(fcall);
GetRNGstate();
time = *(REAL(t0));
// loop over replicates
for (j = 0, xt = REAL(x), ps = REAL(params); j < ns; j++, xt += nvar)
(*ff)(xt,ps+npar*(j%nrep),time,sidx,pidx,cidx,cp);
PutRNGstate();
unset_pomp_userdata();
}
break;
default:
errorcall(R_NilValue,"in 'init.state': unrecognized 'mode'"); // # nocov
break;
}
}
UNPROTECT(nprotect);
return x;
}
int main(int argc, char *argv[])
{
if(argc <= 1)
{
return usage();
}
/* printf setup and main code setup */
printf("extern printf\n"\
"segment .data\n"\
"\toutputfmt:\tdb \"= %%d\", 10, 0\n\n"\
"segment .text\n"\
"\tglobal main\n"
"main:\n");
int len = strlen(argv[1]);
int i;
for(i=0; i<len; i++)
{
char c = argv[1][i];
if(IS_NUMERIC(c))
{
printf("\tpush\tdword %c\n", c);
}
else
{
char op[4];
switch(c)
{
case '+':
strcpy(op, "add");
break;
case '-':
strcpy(op, "sub");
break;
case '*':
strcpy(op, "mul");
break;
case '/':
strcpy(op, "div");
break;
default:
op[0] = '\0';
break;
}
if(!STR_IS_EMPTY(op))
{
/* `pop` expression operand 1 to eax and operand 2 to ebx. */
printf("\tpop\tebx\n"\
"\tpop\teax\n"\
"\t%s\teax, ebx\n"\
"\tpush\teax\n", op);
}
}
}
printf("\tpush\tdword outputfmt\n"\
"\tcall\tprintf\n");
#ifdef __GNUC__
printf("\tmov\teax, 1\n"\
"\tmov\tebx, 0\n"\
"\tint\t80h\n");
#elif defined(_WIN32)
printf("\tmov\teax, 0xf\n"\
"\tmov\tedx, 0\n"\
"\tint\t21h\n");
#endif
return 0;
}
static int get_history(SEXP time, SEXP sender, SEXP receiver, struct history *h)
{
size_t nsend, nrecv;
double *xtime;
int *xsender, *xr;
SEXP r;
int i, n, j, m;
struct message msg;
size_t nto_max;
size_t ito;
/* extract dimensions */
nsend = history_send_count(h);
nrecv = history_recv_count(h);
n = LENGTH(time);
/* setup message buffer */
nto_max = nrecv;
msg.to = (size_t *)R_alloc(nto_max, sizeof(size_t));
msg.attr = 0;
/* validate and extract 'time' */
if (!IS_NUMERIC(time))
DOMAIN_ERROR("'time' should be a numeric vector");
xtime = NUMERIC_POINTER(time);
/* validate and extract 'sender' */
if (!IS_INTEGER(sender))
DOMAIN_ERROR("'sender' should be an integer vector");
if (LENGTH(sender) != n)
DOMAIN_ERROR("'time' and 'receiver' lengths differ");
xsender = INTEGER_POINTER(sender);
/* validate and extract 'receiver' */
if (!IS_VECTOR(receiver))
DOMAIN_ERROR("'receiver' should be a list");
if (LENGTH(receiver) != n)
DOMAIN_ERROR("'time' and 'receiver' lengths differ");
/* add all messages */
for (i = 0; i < n; i++) {
msg.time = xtime[i];
msg.from = (size_t)(xsender[i] - 1);
msg.attr = 0;
/* validate and extract receiver[[i]] */
r = VECTOR_ELT(receiver, i);
if (!IS_INTEGER(r))
DOMAIN_ERROR("each element of 'receiver' should be an integer vector");
m = LENGTH(r);
xr = INTEGER_POINTER(r);
for (j = 0; j < MIN(m, nto_max); j++) {
msg.to[j] = (size_t)(xr[j] - 1);
}
msg.nto = (size_t)m;
/* validate message */
if (!R_FINITE(msg.time))
DOMAIN_ERROR("'time' value is missing or infinite");
if (msg.from >= nsend)
DOMAIN_ERROR("'sender' value is out of range");
if (msg.nto == 0)
DOMAIN_ERROR("'receiver' value is empty");
if (msg.nto > nrecv)
DOMAIN_ERROR("'receiver' value contains duplicate elements");
for (ito = 0; ito < msg.nto; ito++) {
if (msg.to[ito] >= nrecv)
DOMAIN_ERROR("'receiver' value is out of range");
}
/* add the message */
history_set_time(h, msg.time);
history_add(h, msg.from, msg.to, msg.nto, msg.attr);
}
return 0;
}
SV *
toPerl(USER_OBJECT_ val, Rboolean perlOwned)
{
int n = GET_LENGTH(val);
dTHX;
SV *sv = &sv_undef;
if(val == NULL_USER_OBJECT)
return(sv);
if(isRSReferenceObject(val)){
return(getForeignPerlReference(val));
}
if(GET_LENGTH(GET_CLASS(val))) {
SV *o = userLevelConversionToPerl(val);
if(!o)
return(o);
}
if(n == 1) {
if(IS_CHARACTER(val))
sv = newSVpv(CHAR_DEREF(STRING_ELT(val, 0)), 0);
else if(IS_LOGICAL(val))
sv = newSViv(LOGICAL_DATA(val)[0]);
else if(IS_INTEGER(val))
sv = newSViv(INTEGER_DATA(val)[0]);
else if(IS_NUMERIC(val))
sv = newSVnv(NUMERIC_DATA(val)[0]);
else if(IS_FUNCTION(val))
sv = RPerl_createRProxy(val);
} else {
AV *arr;
int i;
arr = newAV();
SvREFCNT_inc(arr);
if(n > 0)
av_extend(arr, n);
/* Did try using av_make() and storing the SVs in an array first, but didn't fix the problem
of bizarre array.
*/
for(i = 0; i < n ; i++) {
if(IS_CHARACTER(val))
sv = newSVpv(CHAR_DEREF(STRING_ELT(val, i)), 0);
else if(IS_LOGICAL(val))
sv = newSViv(LOGICAL_DATA(val)[i]);
else if(IS_INTEGER(val))
sv = newSViv(INTEGER_DATA(val)[i]);
else if(IS_NUMERIC(val))
sv = newSVnv(NUMERIC_DATA(val)[i]);
SvREFCNT_inc(sv);
av_push(arr, sv);
}
sv = (SV *) arr;
SvREFCNT_dec(arr);
#if 0
{SV *rv = newSVrv(arr, NULL);
sv = rv;
}
#endif
}
if(perlOwned)
#if 0 /*XXX Just experimenting */
sv = sv_2mortal(sv);
#else
sv = SvREFCNT_inc(sv);
#endif
return(sv);
}
