C++ COPY_TO_USER_STRING函数代码示例

SEXP SP_PREFIX(SpatialPolygons_validate_c)(SEXP obj) {

    int pc=0;
    int i, n;
    SEXP pls, ans;
    char *cls="Polygons";

    PROTECT(pls = GET_SLOT(obj, install("polygons"))); pc++;
    n = length(pls);
    for (i=0; i<n; i++) {
        if (strcmp(CHAR(STRING_ELT(getAttrib(VECTOR_ELT(pls, i),
           R_ClassSymbol), 0)), cls) != 0) {
             PROTECT(ans = NEW_CHARACTER(1)); pc++;
             SET_STRING_ELT(ans, 0,
             COPY_TO_USER_STRING("polygons slot contains non-Polygons object"));
             UNPROTECT(pc);
             return(ans);
        }
    }

    if (n != length(GET_SLOT(obj, install("plotOrder")))) {
        PROTECT(ans = NEW_CHARACTER(1)); pc++;
        SET_STRING_ELT(ans, 0,
           COPY_TO_USER_STRING("plotOrder and polygons differ in length"));
        UNPROTECT(pc);
        return(ans);
    }

    PROTECT(ans = NEW_LOGICAL(1)); pc++;
    LOGICAL_POINTER(ans)[0] = TRUE;
    UNPROTECT(pc);
    return(ans);

}

SEXP ogrAutoIdentifyEPSG(SEXP p4s) {

    OGRSpatialReference hSRS = NULL;
    OGRErr thisOGRErr;
    SEXP ans;

    installErrorHandler();
    if (hSRS.importFromProj4(CHAR(STRING_ELT(p4s, 0))) != OGRERR_NONE) {
        uninstallErrorHandlerAndTriggerError();
	error("Can't parse PROJ.4-style parameter string");
    }
    uninstallErrorHandlerAndTriggerError();
    PROTECT(ans=NEW_CHARACTER(1));

    installErrorHandler();
    thisOGRErr = hSRS.AutoIdentifyEPSG();
    uninstallErrorHandlerAndTriggerError();

    if (thisOGRErr == OGRERR_NONE) {
        installErrorHandler();
        SET_STRING_ELT(ans, 0,
            COPY_TO_USER_STRING(hSRS.GetAuthorityCode(NULL)));
        uninstallErrorHandlerAndTriggerError();
    } else if (thisOGRErr == OGRERR_UNSUPPORTED_SRS) {
        SET_STRING_ELT(ans, 0,
            COPY_TO_USER_STRING("OGRERR_UNSUPPORTED_SRS"));
    }

    UNPROTECT(1);

    return(ans);
}

SEXP checkCRSArgs(SEXP args) {
	SEXP res;
	projPJ pj;
	PROTECT(res = NEW_LIST(2));
	SET_VECTOR_ELT(res, 0, NEW_LOGICAL(1));
	SET_VECTOR_ELT(res, 1, NEW_CHARACTER(1));
	LOGICAL_POINTER(VECTOR_ELT(res, 0))[0] = FALSE;
	
	if (!(pj = pj_init_plus(CHAR(STRING_ELT(args, 0))))) {

		SET_STRING_ELT(VECTOR_ELT(res, 1), 0, 
			COPY_TO_USER_STRING(pj_strerrno(*pj_get_errno_ref())));
		
		UNPROTECT(1);
		return(res);
	}

	SET_STRING_ELT(VECTOR_ELT(res, 1), 0, 
		COPY_TO_USER_STRING(pj_get_def(pj, 0)));
	
	LOGICAL_POINTER(VECTOR_ELT(res, 0))[0] = TRUE;
	
	UNPROTECT(1);
	return(res);
}

/* Autoload default packages and names from autoloads.h
 *
 * This function behaves in almost every way like
 * R's autoload:
 * function (name, package, reset = FALSE, ...)
 * {
 *     if (!reset && exists(name, envir = .GlobalEnv, inherits = FALSE))
 *        stop("an object with that name already exists")
 *     m <- match.call()
 *     m[[1]] <- as.name("list")
 *     newcall <- eval(m, parent.frame())
 *     newcall <- as.call(c(as.name("autoloader"), newcall))
 *     newcall$reset <- NULL
 *     if (is.na(match(package, .Autoloaded)))
 *        assign(".Autoloaded", c(package, .Autoloaded), env = .AutoloadEnv)
 *     do.call("delayedAssign", list(name, newcall, .GlobalEnv,
 *                                                         .AutoloadEnv))
 *     invisible()
 * }
 *
 * What's missing is the updating of the string vector .Autoloaded with the list
 * of packages, which by my code analysis is useless and only for informational
 * purposes.
 *
 */
void autoloads(void){
    SEXP da, dacall, al, alcall, AutoloadEnv, name, package;
    int i,j, idx=0, errorOccurred, ptct;
    
    /* delayedAssign call*/
    PROTECT(da = Rf_findFun(Rf_install("delayedAssign"), R_GlobalEnv));
    PROTECT(AutoloadEnv = Rf_findVar(Rf_install(".AutoloadEnv"), R_GlobalEnv));
    if (AutoloadEnv == R_NilValue){
        fprintf(stderr,"%s: Cannot find .AutoloadEnv!\n", programName);
        exit(1);
    }
    PROTECT(dacall = allocVector(LANGSXP,5));
    SETCAR(dacall,da);
    /* SETCAR(CDR(dacall),name); */          /* arg1: assigned in loop */
    /* SETCAR(CDR(CDR(dacall)),alcall); */  /* arg2: assigned in loop */
    SETCAR(CDR(CDR(CDR(dacall))),R_GlobalEnv); /* arg3 */
    SETCAR(CDR(CDR(CDR(CDR(dacall)))),AutoloadEnv); /* arg3 */


    /* autoloader call */
    PROTECT(al = Rf_findFun(Rf_install("autoloader"), R_GlobalEnv));
    PROTECT(alcall = allocVector(LANGSXP,3));
    SET_TAG(alcall, R_NilValue); /* just like do_ascall() does */
    SETCAR(alcall,al);
    /* SETCAR(CDR(alcall),name); */          /* arg1: assigned in loop */
    /* SETCAR(CDR(CDR(alcall)),package); */  /* arg2: assigned in loop */

    ptct = 5;
    for(i = 0; i < packc; i++){
        idx += (i != 0)? packobjc[i-1] : 0;
        for (j = 0; j < packobjc[i]; j++){
            /*printf("autload(%s,%s)\n",packobj[idx+j],pack[i]);*/
            
            PROTECT(name = NEW_CHARACTER(1));
            PROTECT(package = NEW_CHARACTER(1));
            SET_STRING_ELT(name, 0, COPY_TO_USER_STRING(packobj[idx+j]));
            SET_STRING_ELT(package, 0, COPY_TO_USER_STRING(pack[i]));
            
            /* Set up autoloader call */
            PROTECT(alcall = allocVector(LANGSXP,3));
            SET_TAG(alcall, R_NilValue); /* just like do_ascall() does */
            SETCAR(alcall,al);
            SETCAR(CDR(alcall),name);
            SETCAR(CDR(CDR(alcall)),package);

            /* Setup delayedAssign call */
            SETCAR(CDR(dacall),name);
            SETCAR(CDR(CDR(dacall)),alcall);
            
            R_tryEval(dacall,R_GlobalEnv,&errorOccurred);
            if (errorOccurred){
                fprintf(stderr,"%s: Error calling delayedAssign!\n", programName);
                exit(1);
            }
            
            ptct += 3;
        }
    }
    UNPROTECT(ptct);
}

USER_OBJECT_
asREnum(int value, GType etype)
{
    USER_OBJECT_ ans, names;
    GEnumValue *evalue;
    PROTECT(ans = NEW_INTEGER(1));
    INTEGER_DATA(ans)[0] = value;

    if (!(evalue = g_enum_get_value(g_type_class_ref(etype), value))) {
        PROBLEM "Unknown enum value %d", value
        ERROR;
    }

    PROTECT(names = NEW_CHARACTER(1));
    SET_STRING_ELT(names, 0, COPY_TO_USER_STRING(evalue->value_name));
    SET_NAMES(ans, names);

    PROTECT(names = NEW_CHARACTER(2));
    SET_STRING_ELT(names, 0, COPY_TO_USER_STRING(g_type_name(etype)));
    SET_STRING_ELT(names, 1, COPY_TO_USER_STRING("enum"));
    SET_CLASS(ans, names);

    UNPROTECT(3);

    return(ans);
}

void
RXSLT_callNamedFunction(const char *name, xmlXPathParserContextPtr ctxt, int nargs, int leaveAsRObject)
{
  USER_OBJECT_ e, ans;
//  xmlXPathObjectPtr obj;
  int errorOccurred;
  int i, j;

#if 0
  PROTECT(e = allocVector(LANGSXP, 2));
  SETCAR(e, Rf_install((char *) name));
  SETCAR(CDR(e), tmp = NEW_CHARACTER(1));
  obj = valuePop(ctxt); 
  SET_STRING_ELT(tmp, 0, COPY_TO_USER_STRING(xmlXPathCastToString(obj)));
#else
  PROTECT(e = allocVector(LANGSXP, nargs+1));
  SETCAR(e, Rf_install((char *) name));

#if 0
  for(i = 0; i < nargs; i++) {
    ans = CDR(e);
    for(j = nargs-1; j > i ; j--) {
      ans = CDR(ans);
    }
    SETCAR(ans, tmp = NEW_CHARACTER(1));
    obj = valuePop(ctxt); 
    SET_STRING_ELT(tmp, 0, COPY_TO_USER_STRING(xmlXPathCastToString(obj)));
  }
#else
  for(i = 0; i < nargs; i++) {
    ans = CDR(e);
    for(j = nargs-1; j > i ; j--) {
      ans = CDR(ans);
    }
   SETCAR(ans, convertFromXPath(ctxt, valuePop(ctxt)));
  }

#endif
#endif  
  ans = R_tryEval(e, R_GlobalEnv, &errorOccurred);
  if(errorOccurred) {
      RXSLT_Error(ctxt, "error in call to R function"); 
  } else {
     PROTECT(ans);
     valuePush(ctxt, convertToXPath(ctxt, ans));
     UNPROTECT(1);
  }

  UNPROTECT(1);
  return;
}

USER_OBJECT_
RS_GGOBI(getDisplayOptions)(USER_OBJECT_ which)
{
  USER_OBJECT_ ans, names;
  gint NumOptions = 8;
  DisplayOptions *options;
  
  if (GET_LENGTH(which) == 0)
    options = GGOBI(getDefaultDisplayOptions)();
  else {
    displayd *display = toDisplay(which);
    g_return_val_if_fail(GGOBI_IS_DISPLAY(display), NULL_USER_OBJECT);
    options = &(display->options);
  }
  
  g_return_val_if_fail(options != NULL, NULL_USER_OBJECT);

  PROTECT(ans = NEW_LOGICAL(NumOptions));
  PROTECT(names = NEW_CHARACTER(NumOptions));

  LOGICAL_DATA(ans)[DOPT_POINTS] = options->points_show_p;
  SET_STRING_ELT(names, DOPT_POINTS, COPY_TO_USER_STRING("Show points"));
  LOGICAL_DATA(ans)[DOPT_AXES] = options->axes_show_p;
  SET_STRING_ELT(names, DOPT_AXES,  COPY_TO_USER_STRING("Show axes"));

  LOGICAL_DATA(ans)[DOPT_AXESLAB] = options->axes_label_p;
  SET_STRING_ELT(names, DOPT_AXESLAB,
    COPY_TO_USER_STRING("Show tour axes"));
  LOGICAL_DATA(ans)[DOPT_AXESVALS] = options->axes_values_p;
  SET_STRING_ELT(names, DOPT_AXESVALS,
    COPY_TO_USER_STRING("Show axes labels"));

  LOGICAL_DATA(ans)[DOPT_EDGES_U] = options->edges_undirected_show_p;
  SET_STRING_ELT(names, DOPT_EDGES_U, COPY_TO_USER_STRING("Undirected edges"));
  LOGICAL_DATA(ans)[DOPT_EDGES_A] = options->edges_arrowheads_show_p;
  SET_STRING_ELT(names, DOPT_EDGES_A, COPY_TO_USER_STRING("Arrowheads"));
  LOGICAL_DATA(ans)[DOPT_EDGES_D] = options->edges_directed_show_p;
  SET_STRING_ELT(names, DOPT_EDGES_D, COPY_TO_USER_STRING("Directed edges"));

  LOGICAL_DATA(ans)[DOPT_WHISKERS] = options->whiskers_show_p;
  SET_STRING_ELT(names, DOPT_WHISKERS,
    COPY_TO_USER_STRING("Show whiskers"));

/* unused
  LOGICAL_DATA(ans)[5] = options->missings_show_p;
  SET_STRING_ELT(names, 5, COPY_TO_USER_STRING("Missing Values"));
  LOGICAL_DATA(ans)[8] = options->axes_center_p;
  SET_STRING_ELT(names, 8,  COPY_TO_USER_STRING("Center axes"));
  LOGICAL_DATA(ans)[9] = options->double_buffer_p;
  SET_STRING_ELT(names, 9,  COPY_TO_USER_STRING("Double buffer"));
  LOGICAL_DATA(ans)[10] = options->link_p;
  SET_STRING_ELT(names, 10,  COPY_TO_USER_STRING("Link"));
*/

  SET_NAMES(ans, names);

  UNPROTECT(2);

  return(ans);
}

USER_OBJECT_
asRFlag(guint value, GType ftype)
{
    USER_OBJECT_ ans, names;
    PROTECT(ans = NEW_INTEGER(1));
    INTEGER_DATA(ans)[0] = value;

    PROTECT(names = NEW_CHARACTER(2));
    SET_STRING_ELT(names, 0, COPY_TO_USER_STRING(g_type_name(ftype)));
    SET_STRING_ELT(names, 1, COPY_TO_USER_STRING("flag"));
    SET_CLASS(ans, names);

    UNPROTECT(2);
    return(ans);
}

SEXP 
GetRScalar(SV *val)
{
  dTHX;
  SEXP ans = NULL_USER_OBJECT;

  if(SvIOKp(val)) {
    PROTECT(ans = NEW_INTEGER(1));
    INTEGER_DATA(ans)[0] = SvIV(val);
    UNPROTECT(1);
  } else if(SvNOKp(val)) {
    PROTECT(ans = NEW_NUMERIC(1));
    NUMERIC_DATA(ans)[0] = SvNV(val);
    UNPROTECT(1);
  } else if(SvPOK(val)) {
    PROTECT(ans = NEW_CHARACTER(1));
    SET_STRING_ELT(ans, 0, COPY_TO_USER_STRING(SvPV(val, PL_na)));
    UNPROTECT(1);
  } else if(SvROK(val)) {
    fprintf(stderr, "Not handling nested references in conversion from Perl to R at present. Suggestions for semantics welcome!\n");fflush(stderr);
  } else if(SvTYPE(val) == SVt_PVMG) {
    /*XXX get more info about the type of the magic object. 
    struct magic *mg = SvMAGIC(val);
    */
    PROTECT(ans = createPerlReference(val));

    UNPROTECT(1);
  } else {
    fprintf(stderr, "Cannot deal currently with Perl types %d\n", SvTYPE(val));fflush(stderr);
  }

  return(ans);
}

SEXP wkt_to_p4s(SEXP wkt, SEXP esri) {

    OGRSpatialReference hSRS = NULL;
    char *pszSRS_P4 = NULL;
    char **ppszInput = NULL;
    SEXP ans;
    ppszInput = CSLAddString(ppszInput, CHAR(STRING_ELT(wkt, 0)));

    installErrorHandler();
    if (hSRS.importFromWkt(ppszInput) != OGRERR_NONE) {
        uninstallErrorHandlerAndTriggerError();
	error("Can't parse WKT-style parameter string");
    }
    uninstallErrorHandlerAndTriggerError();
    installErrorHandler();
    if (INTEGER_POINTER(esri)[0] == 1) hSRS.morphFromESRI();
    hSRS.exportToProj4(&pszSRS_P4);
    uninstallErrorHandlerAndTriggerError();

    PROTECT(ans=NEW_CHARACTER(1));
    SET_STRING_ELT(ans, 0, COPY_TO_USER_STRING(pszSRS_P4));

    UNPROTECT(1);

    return(ans);
}

USER_OBJECT_
R_internal_getGTypeHierarchy(GType type)
{
  USER_OBJECT_ ans;
  int n = 0;
  GType orig = type;

  while(type != 0 && type != G_TYPE_INVALID) {
     type = g_type_parent(type);
     n++;
  }

  PROTECT(ans = NEW_CHARACTER(n));
  n = 0;
  type = orig;
  while(type != G_TYPE_INVALID) {
     const char *val;
     val = g_type_name(type);
     SET_STRING_ELT(ans, n, COPY_TO_USER_STRING(val));
     n++;
     type =  g_type_parent(type);
  }
  UNPROTECT(1);

  return(ans);
}

void
R_getKeyNames(void *el, void *data, xmlChar *name)
{
    RXMLHashScannerInfo *info = ( RXMLHashScannerInfo *) data;
    SET_STRING_ELT(info->els, info->i, COPY_TO_USER_STRING(name));
    info->i++;
}

int
loadXSLPackage(void)
{
  USER_OBJECT_ e, fun, tmp;
  int isError;

  PROTECT(fun = Rf_findFun(Rf_install("library"), R_GlobalEnv));
  PROTECT(e = allocVector(LANGSXP, 2));

  SETCAR(e, fun);
  SETCAR(CDR(e), tmp = NEW_CHARACTER(1));
  SET_VECTOR_ELT(tmp, 0, COPY_TO_USER_STRING("Sxslt"));
  R_tryEval(e, R_GlobalEnv, &isError);
  if(isError) {
      Rf_error("Couldn't load Sxslt package. Check the setting of R_LIBS");
/*
      fprintf(stderr, "Couldn't load Sxslt package. Check the setting of R_LIBS\n");
      fflush(stderr);
*/
  }

   
  UNPROTECT(2);
  return(TRUE);
}

int source(char *file){
    SEXP expr, s, f, p;
    int errorOccurred;

    /* Find source function */
    s = Rf_findFun(Rf_install("source"), R_GlobalEnv);
    PROTECT(s);

    /* Make file argument */
    PROTECT(f = NEW_CHARACTER(1));
    SET_STRING_ELT(f, 0, COPY_TO_USER_STRING(file));

    /* Make print.eval argument */
    PROTECT(p = NEW_LOGICAL(1));
    LOGICAL_DATA(p)[0] = (verbose)? TRUE : FALSE;

    /* expression source(f,print.eval=p) */
    PROTECT(expr = allocVector(LANGSXP,3));
    SETCAR(expr,s); 
    SETCAR(CDR(expr),f);
    SETCAR(CDR(CDR(expr)), p);
    SET_TAG(CDR(CDR(expr)), Rf_install("print.eval"));
    
    errorOccurred=0;
    R_tryEval(expr,NULL,&errorOccurred);
    UNPROTECT(4);

    return errorOccurred;
}

SEXP rgeos_node(SEXP env, SEXP obj) {

    SEXP ans, id;
    int pc=0;
    
    GEOSContextHandle_t GEOShandle = getContextHandle(env);
    SEXP p4s = GET_SLOT(obj, install("proj4string"));
    GEOSGeom geom = rgeos_convert_R2geos(env, obj);
//    int type = GEOSGeomTypeId_r(GEOShandle, geom);
//Rprintf("type: %d, %s\n", type, GEOSGeomType_r(GEOShandle, geom));
    
    GEOSGeom res = GEOSNode_r(GEOShandle, geom);
    
//    type = GEOSGeomTypeId_r(GEOShandle, res);

    int ng = GEOSGetNumGeometries_r(GEOShandle, res);

//Rprintf("ng: %d, type: %d, %s\n", ng, type, GEOSGeomType_r(GEOShandle, res));

    char buf[BUFSIZ];

    PROTECT(id = NEW_CHARACTER(ng)); pc++;
    for (int i=0; i<ng; i++) {
        sprintf(buf, "%d", i);
        SET_STRING_ELT(id, i, COPY_TO_USER_STRING(buf));
    }

    GEOSGeom_destroy_r(GEOShandle, geom);

    ans = rgeos_convert_geos2R(env, res, p4s, id); 

    UNPROTECT(pc);
    return(ans);

}