C++ GET_LENGTH函数代码示例

SEXP rsqlite_query_send(SEXP handle, SEXP statement, SEXP bind_data) {
  SQLiteConnection* con = rsqlite_connection_from_handle(handle);
  sqlite3* db_connection = con->drvConnection;
  sqlite3_stmt* db_statement = NULL;
  int state, bind_count;
  int rows = 0, cols = 0;

  if (con->resultSet) {
    if (con->resultSet->completed != 1)
      warning("Closing result set with pending rows");
    rsqlite_result_free(con);
  }
  rsqlite_result_alloc(con);
  SQLiteResult* res = con->resultSet;

  /* allocate and init a new result set */
  res->completed = 0;
  char* dyn_statement = RS_DBI_copyString(CHAR(asChar(statement)));
  res->statement = dyn_statement;
  res->drvResultSet = db_statement;
  state = sqlite3_prepare_v2(db_connection, dyn_statement, -1,
      &db_statement, NULL);

  if (state != SQLITE_OK) {
    exec_error(con, "error in statement");
  }
  if (db_statement == NULL) {
    exec_error(con, "nothing to execute");
  }
  res->drvResultSet = (void*) db_statement;
  bind_count = sqlite3_bind_parameter_count(db_statement);
  if (bind_count > 0 && bind_data != R_NilValue) {
    rows = GET_LENGTH(GET_ROWNAMES(bind_data));
    cols = GET_LENGTH(bind_data);
  }

  res->isSelect = sqlite3_column_count(db_statement) > 0;
  res->rowCount = 0;      /* fake's cursor's row count */
  res->rowsAffected = -1; /* no rows affected */
  rsqlite_exception_set(con, state, "OK");

  if (res->isSelect) {
    if (bind_count > 0) {
      select_prepared_query(db_statement, bind_data, bind_count, rows, con);
    }
  } else {
    if (bind_count > 0) {
      non_select_prepared_query(db_statement, bind_data, bind_count, rows, con);
    } else {
      state = sqlite3_step(db_statement);
      if (state != SQLITE_DONE) {
        exec_error(con, "rsqlite_query_send: could not execute1");
      }
    }
    res->completed = 1;
    res->rowsAffected = sqlite3_changes(db_connection);
  }

  return handle;
}

SEXP
R_wxSlider_new(SEXP r_parent, SEXP r_id, SEXP r_value, SEXP r_min, SEXP r_max, SEXP r_pos, SEXP r_size, SEXP r_style)
{
  wxWindow *parent;
  wxWindowID id;
  wxSlider *ans;
  SEXP r_ans;
  int value, min, max;
  long style;
  wxPoint pos = wxDefaultPosition;
  wxSize size = wxDefaultSize;

  parent = (wxWindow *) R_get_wxWidget_Ref(r_parent, NULL);
  id = INTEGER(r_id)[0];

  value = INTEGER(r_value)[0];
  min = INTEGER(r_min)[0];
  max = INTEGER(r_max)[0];

  style = (long) REAL(r_style)[0];

  if(GET_LENGTH(r_pos)) pos = R_to_wxPoint(r_pos);
  if(GET_LENGTH(r_size)) size = R_to_wxSize(r_size);

  ans = new wxSlider(parent, id, value, min, max, pos, size, style);

  r_ans = R_make_wxWidget_Ref(ans, "wxSlider");
  
  return(r_ans);
}

void BigSum(BigMatrix *mat, SEXP colIndices, SEXP rowIndices, double *value) {
    BMAccessorType m( *mat );
    
    double *cols = NUMERIC_DATA(colIndices);
    double *rows = NUMERIC_DATA(rowIndices);
    
    index_type i=0;
    index_type j=0;
    index_type xj=0;
    index_type numCols = GET_LENGTH(colIndices);
    index_type numRows = GET_LENGTH(rowIndices);
    CType *pColumn;
    
    double s = 0;
    
    for (i = 0; i < numCols; ++i) {
        pColumn = m[static_cast<index_type>(cols[i])-1];
        for (j = 0; j < numRows; ++j) {
            xj = static_cast<index_type>(rows[j])-1;
            s += (double)pColumn[xj];
        }
    }
    
    value[0] = s;
    
    return;
}

SEXP geoddist_alongpath(SEXP lat, SEXP lon, SEXP a, SEXP f)
{
  if (!isReal(lat))
    error("latitude must be a numeric (floating-point) vector");
  if (!isReal(lon))
    error("longitude must be a numeric (floating-point) vector");
  SEXP res;
  //int n = INTEGER(GET_LENGTH(lat));
  //int nlon = INTEGER(GET_LENGTH(lon));
  int n = GET_LENGTH(lat);
  int nlon = GET_LENGTH(lon);
  if (n != nlon)
    error("lengths of latitude and longitude vectors must match, but they are %d and %d, respectively", n, nlon);
  double *latp = REAL(lat);
  double *lonp = REAL(lon);
  double *ap = REAL(a);
  double *fp = REAL(f);
  PROTECT(res = allocVector(REALSXP, n));
  double *resp = REAL(res);
  double last = 0.0;
  resp[0] = ISNA(lonp[0]) ? NA_REAL : 0.0;
  for (int i = 0; i < n-1; i++) {
    double faz, baz, s;
    if (ISNA(latp[i]) || ISNA(lonp[i]) || ISNA(latp[i+1]) || ISNA(lonp[i+1])) {
      resp[i+1] = NA_REAL;
      last = 0.0; // reset
    } else {
      geoddist_core(latp+i, lonp+i, latp+i+1, lonp+i+1, ap, fp, &faz, &baz, &s);
      resp[i+1] = last + s;
      last = resp[i+1];
    }
  }
  UNPROTECT(1);
  return(res);
}

SEXP geoddist(SEXP lat1, SEXP lon1, SEXP lat2, SEXP lon2, SEXP a, SEXP f)
{
  if (!isReal(lat1)) error("lat1 must be a numeric (floating-point) vector");
  if (!isReal(lon1)) error("lon1 must be a numeric (floating-point) vector");
  if (!isReal(lat2)) error("lat2 must be a numeric (floating-point) vector");
  if (!isReal(lon2)) error("lon2 must be a numeric (floating-point) vector");
  int n = GET_LENGTH(lat1);
  if (n != GET_LENGTH(lon1))
    error("lengths of lat1 and lon1 must match, but they are %d and %d respectively.", n, GET_LENGTH(lon1));
  if (n != GET_LENGTH(lat2))
    error("lengths of lat1 and lat2 must match, but they are %d and %d respectively.", n, GET_LENGTH(lat2));
  if (n != GET_LENGTH(lon2))
    error("lengths of lon1 and lon2 must match, but they are %d and %d respectively.", n, GET_LENGTH(lon2));
  double *lat1p = REAL(lat1);
  double *lon1p = REAL(lon1);
  double *lat2p = REAL(lat2);
  double *lon2p = REAL(lon2);
  double *ap = REAL(a);
  double *fp = REAL(f);
  SEXP res;
  PROTECT(res = allocVector(REALSXP, n));
  double *resp = REAL(res);
  for (int i = 0; i < n; i++) {
    double faz, baz, s;
    geoddist_core(lat1p+i, lon1p+i, lat2p+i, lon2p+i, ap, fp, &faz, &baz, &s);
    resp[i] = s;
  }
  UNPROTECT(1);
  return(res);
}

////////////////////////////////////////////////////////////
// C'tor
RootChainManager::RootChainManager(SEXP treeName, SEXP fileList, bool verbose, bool trace) :
  m_chain(0),
  m_verbose(verbose),
  m_trace(trace)
{
  // Check arguments
  if ( ! IS_CHARACTER(treeName) ) error("treeName must be a string");
  if ( GET_LENGTH(treeName) != 1) error("treeName must have length 1");
  if ( ! IS_CHARACTER(fileList) ) error("fileList must be a list of strings");
	 
  // Get the tree name
	std::string treeNameC = CHAR(STRING_ELT(treeName, 0));
	 
  if (m_verbose) REprintf("Will read tree %s\n", treeNameC.c_str());
	 
  // Get the list of files to chain
  if (m_verbose) 
    REprintf("There are %d files to add to the chain\n", GET_LENGTH(fileList) );
	 
  // Form the chain from the file lists
  m_chain = new TChain(treeNameC.c_str());
	 
  // Add files
  for ( unsigned int i = 0; i < GET_LENGTH(fileList); ++i ) {    
		std::string fileNameC = CHAR(STRING_ELT(fileList, i) );
    if (m_verbose) REprintf("Adding file %s to chain\n", fileNameC.c_str());
    m_chain->Add( fileNameC.c_str(), 0 );
  }
}

void DeepCopy(BigMatrix *pInMat, BigMatrix *pOutMat, SEXP rowInds, SEXP colInds)
{
    in_BMAccessorType inMat( *pInMat );
    out_BMAccessorType outMat( *pOutMat );

    double *pRows = NUMERIC_DATA(rowInds);
    double *pCols = NUMERIC_DATA(colInds);
    index_type nRows = GET_LENGTH(rowInds);
    index_type nCols = GET_LENGTH(colInds);

    if (nRows != pOutMat->nrow())
        Rf_error("length of row indices does not equal # of rows in new matrix");
    if (nCols != pOutMat->ncol())
        Rf_error("length of col indices does not equal # of cols in new matrix");

    index_type i = 0;
    index_type j = 0;
    in_CType *pInColumn;
    out_CType *pOutColumn;

    for (i = 0; i < nCols; ++i) {
        pInColumn = inMat[static_cast<index_type>(pCols[i])-1];
        pOutColumn = outMat[i];
        for (j = 0; j < nRows; ++j) {
            pOutColumn[j] = static_cast<out_CType>(
                                pInColumn[static_cast<index_type>(pRows[j])-1]);
        }
    }

    return;
}

USER_OBJECT_
RGnumeric_setCellComment(USER_OBJECT_ scell, USER_OBJECT_ stext, USER_OBJECT_ sauthor)
{
  char *text = NULL, *author = NULL;
  CellComment *comment;
  Cell *cell;
  USER_OBJECT_ ans = NULL_USER_OBJECT;

  cell = RGnumeric_resolveCellReference(scell);
  if(!cell)
    PROBLEM "invalid cell reference object"
    ERROR;

  if(GET_LENGTH(stext))
    text = CHAR_DEREF(STRING_ELT(stext, 0));
  if(GET_LENGTH(sauthor))
    author = CHAR_DEREF(STRING_ELT(sauthor, 0));

  comment = cell_has_comment(cell); 
  if(!comment) {
      Sheet *sheet;
        sheet = RGnumeric_resolveSheetReference(VECTOR_ELT(scell, 1));
        cell_set_comment(sheet, &(cell->pos), (const char*) author, (const char *)text);
  } else {
      if(text)
        cell_comment_text_set(comment, text);
      if(author)
        cell_comment_author_set(comment, author);
  }


  return(ans);
}

static int php_is_r_primitive(SEXP val, SEXPTYPE *type) /* {{{ */
{
	int is = 0;

	if (GET_LENGTH(GET_DIM(val))) {
		return 0;
	}

	if (GET_LENGTH(GET_CLASS(val))) {
		return 0;
	}

	*type = TYPEOF(val);
	switch (*type) {
		case REALSXP:
		case LGLSXP:
		case STRSXP:
		case INTSXP:
			is = 1;
		default:
			break;
	}

	return is;
}

USER_OBJECT_
toRPointerWithFinalizer(gconstpointer val, const gchar *typeName, RPointerFinalizer finalizer)
{
    USER_OBJECT_ ans;
    USER_OBJECT_ r_finalizer = NULL_USER_OBJECT;
    USER_OBJECT_ klass = NULL, rgtk_class;
    int i = 0;
    GType type = 0;

    if(!val)
       return(NULL_USER_OBJECT);

    if (finalizer) {
        PROTECT(r_finalizer = R_MakeExternalPtr(finalizer, NULL_USER_OBJECT, NULL_USER_OBJECT));
    }
    PROTECT(ans = R_MakeExternalPtr((gpointer)val, r_finalizer, NULL_USER_OBJECT));
    if (finalizer) {
        R_RegisterCFinalizer(ans, RGtk_finalizer);
    }
    if (typeName)
        type = g_type_from_name(typeName);
    if(type) {
        if (G_TYPE_IS_INSTANTIATABLE(type) || G_TYPE_IS_INTERFACE(type))
            type = G_TYPE_FROM_INSTANCE(val);
        if (G_TYPE_IS_DERIVED(type)) {
            setAttrib(ans, install("interfaces"), R_internal_getInterfaces(type));
            PROTECT(klass = R_internal_getGTypeAncestors(type));
        }
    }
    if (!klass && typeName) {
        PROTECT(klass = asRString(typeName));
    }

    if (klass) { /* so much trouble just to add "RGtkObject" onto the end */
        PROTECT(rgtk_class = NEW_CHARACTER(GET_LENGTH(klass)+1));
        for (i = 0; i < GET_LENGTH(klass); i++)
            SET_STRING_ELT(rgtk_class, i, STRING_ELT(klass, i));
    } else {
        PROTECT(rgtk_class = NEW_CHARACTER(1));
    }

    SET_STRING_ELT(rgtk_class, i, COPY_TO_USER_STRING("RGtkObject"));
    SET_CLASS(ans, rgtk_class);

    if (g_type_is_a(type, S_TYPE_G_OBJECT)) {
      USER_OBJECT_ public_sym = install(".public");
      setAttrib(ans, public_sym, findVar(public_sym, S_GOBJECT_GET_ENV(val)));
    }
        
    if (klass)
        UNPROTECT(1);
    if (finalizer)
        UNPROTECT(1);
    UNPROTECT(2);

    return(ans);
}

SEXP Expect_matrix(SEXP S1, SEXP S, SEXP lambda, SEXP time, SEXP theta0, SEXP theta1, SEXP matdiag){
    
    int nvar, npoints, nprotect=0;
    
    nvar = GET_LENGTH(lambda);
    npoints = GET_LENGTH(time);
    
    PROTECT(time = coerceVector(time,REALSXP)); nprotect++;
    PROTECT(theta0 = coerceVector(theta0,REALSXP)); nprotect++;
    PROTECT(theta1 = coerceVector(theta1,REALSXP)); nprotect++;
    // results
    SEXP expectation = PROTECT(allocVector(REALSXP,nvar*npoints)); nprotect++;
    
    if(!isComplex(lambda)){
    // eigenvectors
    PROTECT(S1 = coerceVector(S1,REALSXP)); nprotect++;
    PROTECT(S = coerceVector(S,REALSXP)); nprotect++;
    // matrix exponential
    SEXP matexp = PROTECT(allocVector(REALSXP,nvar*nvar*npoints)); nprotect++;

    // Compute the exponential matrix
    multi_exp_matrix (&nvar, &npoints, REAL(time), REAL(lambda), REAL(S), REAL(S1), REAL(matexp));
    
    // Compute the expectations
    optimum (&nvar, &npoints, REAL(time), REAL(theta0), REAL(theta1), REAL(expectation), REAL(matexp), REAL(matdiag));
    // Done.
        
    }else{
    
    double complex *matexp;
    // complex eigenvalues & eigenvectors
    PROTECT(S1 = coerceVector(S1,CPLXSXP)); nprotect++;
    PROTECT(S = coerceVector(S,CPLXSXP)); nprotect++;
        
    // alloc a complex vector in C rather than R structure...
    matexp = Calloc(nvar*nvar*npoints,double complex);
        
    // Compute the exponential matrix
    multi_exp_matrix_complex (&nvar, &npoints, REAL(time), COMPLEX(lambda), COMPLEX(S), COMPLEX(S1), matexp);
        
    // Compute the expectations
    optimum_complex(&nvar, &npoints, REAL(time), REAL(theta0), REAL(theta1), REAL(expectation), matexp, REAL(matdiag));
    // Done.
    // Free the memory
    Free(matexp);
    }


    UNPROTECT(nprotect);
    return expectation;
    
}

// Weight matrix
SEXP Weight_matrix(SEXP S1, SEXP S, SEXP lambda, SEXP time, SEXP matdiag){
    
    int nvar, npoints, vdim[2], nprotect = 0;
    nvar = GET_LENGTH(lambda);
    npoints = GET_LENGTH(time);

    SEXP expectation;
    vdim[0] = npoints*nvar; vdim[1] = nvar*2;
    PROTECT(expectation = makearray(2,vdim)); nprotect++;
    
    if(!isComplex(lambda)){
        // eigenvectors
        PROTECT(S1 = coerceVector(S1,REALSXP)); nprotect++;
        PROTECT(S = coerceVector(S,REALSXP)); nprotect++;
        // matrix exponential
        SEXP matexp = PROTECT(allocVector(REALSXP,nvar*nvar*npoints)); nprotect++;
    
        // Compute the exponential matrix
        multi_exp_matrix (&nvar, &npoints, REAL(time), REAL(lambda), REAL(S), REAL(S1), REAL(matexp));
    
        // Compute the expectations
        build_w (&nvar, &npoints, REAL(time), REAL(expectation), REAL(matexp), REAL(matdiag));
        // Done.

    }else{
        
        double complex *matexp;
        // complex eigenvalues & eigenvectors
        PROTECT(S1 = coerceVector(S1,CPLXSXP)); nprotect++;
        PROTECT(S = coerceVector(S,CPLXSXP)); nprotect++;
        
        // alloc a complex vector in C rather than R structure...
        matexp = Calloc(nvar*nvar*npoints,double complex);
        
        // Compute the exponential matrix
        multi_exp_matrix_complex (&nvar, &npoints, REAL(time), COMPLEX(lambda), COMPLEX(S), COMPLEX(S1), matexp);
        
        // Compute the expectations
        build_w_complex (&nvar, &npoints, REAL(time), REAL(expectation), matexp, REAL(matdiag));
        
        // Done.
        // Free the memory
        Free(matexp);
    }


    UNPROTECT(nprotect);
    return expectation;
    
}

USER_OBJECT_
RS_PerlUndef(USER_OBJECT_ ids, USER_OBJECT_ types, USER_OBJECT_ interpreter)
{
 int n, nt;
 int i,j;
 const char *id;
 int count;
 USER_OBJECT_ ans;

 n = GET_LENGTH(ids);
 nt = GET_LENGTH(types);

 PROTECT(ans = NEW_LIST(n));

  for(i = 0; i < n; i++) {
    id = CHAR_DEREF(STRING_ELT(ids, i));
    count = 0;

    for(j = 0; i < nt; i++) {
	   if(LOGICAL_DATA(types)[i] == TRUE) {
	     count++;
	     switch(i) {
		     case PERL_SCALAR:
				     
			break;
		     case PERL_ARRAY:
				     
			break;
		     case PERL_HASH:
				     
			break;
		     case PERL_SUB:
				     
			break;
		     default:
                       break;
	     } /* switch() */
	   } /* end of if LOGICAL_DATA() */
    } /* type loop */

    if(count == 0) {
      /* Was a composite identifier such as $x{'y'} so have to handle it specially. */
    }
  } /* ids loop */


  UNPROTECT(1);
  return(ans); 
}

static xmlEntityPtr
do_getEntityHandler(void *userData, const xmlChar *name, const char * r_funName)
{
    SEXP opArgs, r_ans;
    xmlEntityPtr ans = NULL;
    RS_XMLParserData *parserData = (RS_XMLParserData*) userData;
    DECL_ENCODING_FROM_EVENT_PARSER(parserData)

    PROTECT(opArgs = NEW_LIST(1)) ;
    SET_VECTOR_ELT(opArgs, 0, ScalarString(ENC_COPY_TO_USER_STRING(name))); /*XXX should we encode this? Done now! */
    r_ans = RS_XML(callUserFunction)(r_funName, NULL, (RS_XMLParserData *) userData, opArgs);
    
    PROTECT(r_ans) ;
    if(r_ans != NULL_USER_OBJECT && GET_LENGTH(r_ans) > 0) {
	if(TYPEOF(r_ans) == STRSXP) {
	    const char *value;
	    value = CHAR_DEREF(STRING_ELT(r_ans, 0));
	    ans = (xmlEntityPtr) malloc(sizeof(xmlEntity));
	    memset(ans, 0, sizeof(xmlEntity));
	    ans->type = XML_ENTITY_DECL;
	    ans->etype = XML_INTERNAL_GENERAL_ENTITY;
	    ans->name = xmlStrdup(name);
	    ans->orig = NULL; // xmlStrdup(CHAR_TO_XMLCHAR(value));
	    ans->content = xmlStrdup(CHAR_TO_XMLCHAR(value));	    
	    ans->length = strlen(value);
#ifndef NO_CHECKED_ENTITY_FIELD
	    ans->checked = 1;
#endif
	}
    }
    UNPROTECT(2);

    return(ans);
}

/////////////////////////
// Return a logical vector if entries are in the event list
SEXP isInEventList(SEXP eventList, SEXP entryNums)
{
  
  TEventList* el = checkForEventListWrapper(eventList);
  
  SEXP l;
  PROTECT(l = NEW_LOGICAL( GET_LENGTH(entryNums) ) );
  
  for ( unsigned int i = 0; i < GET_LENGTH(entryNums); ++i ) {
    LOGICAL(l)[i] = el->Contains( INTEGER(entryNums)[i] ) == 1;
  }
  
  UNPROTECT(1);
  
  return l;
}