C++ Rf_warning函数代码示例

SEXP audio_use_driver(SEXP sName) {
	if (sName == R_NilValue) { /* equivalent to saying 'load default driver' */
		if (!current_driver) load_default_audio_driver(1);
		current_driver = audio_drivers.driver;
		if (!current_driver || !current_driver->name) {
			Rf_warning("no audio drivers are available");
			return R_NilValue;
		}
		return Rf_mkString(current_driver->name);
	}
	if (TYPEOF(sName) != STRSXP || LENGTH(sName) < 1)
		Rf_error("invalid audio driver name");
	else {
		const char *drv_name = CHAR(STRING_ELT(sName, 0));
		audio_driver_list_t *l = &audio_drivers;
		if (!current_driver)
			load_default_audio_driver(1);
		while (l && l->driver) {
			if (l->driver->name && !strcmp(l->driver->name, drv_name)) {
				current_driver = l->driver;
				return sName;
			}
			l = l->next;
		}			
		Rf_warning("driver '%s' not found", drv_name);
	}
	return R_NilValue;
}

// this is a non-throwing version returning an error code
int RInside::parseEval(const std::string & line, SEXP & ans) {
    ParseStatus status;
    SEXP cmdSexp, cmdexpr = R_NilValue;
    int i, errorOccurred;

    mb_m.add((char*)line.c_str());

    PROTECT(cmdSexp = Rf_allocVector(STRSXP, 1));
    SET_STRING_ELT(cmdSexp, 0, Rf_mkChar(mb_m.getBufPtr()));

    cmdexpr = PROTECT(R_ParseVector(cmdSexp, -1, &status, R_NilValue));

    switch (status){
    case PARSE_OK:
        // Loop is needed here as EXPSEXP might be of length > 1
        for(i = 0; i < Rf_length(cmdexpr); i++){
            ans = R_tryEval(VECTOR_ELT(cmdexpr, i), *global_env_m, &errorOccurred);
            if (errorOccurred) {
                if (verbose_m) Rf_warning("%s: Error in evaluating R code (%d)\n", programName, status);
                UNPROTECT(2);
                mb_m.rewind();
                return 1;
            }
            if (verbose_m) {
                Rf_PrintValue(ans);
            }
        }
        mb_m.rewind();
        break;
    case PARSE_INCOMPLETE:
        // need to read another line
        break;
    case PARSE_NULL:
        if (verbose_m) Rf_warning("%s: ParseStatus is null (%d)\n", programName, status);
        UNPROTECT(2);
        mb_m.rewind();
        return 1;
        break;
    case PARSE_ERROR:
        if (verbose_m) Rf_warning("Parse Error: \"%s\"\n", line.c_str());
        UNPROTECT(2);
        mb_m.rewind();
        return 1;
        break;
    case PARSE_EOF:
        if (verbose_m) Rf_warning("%s: ParseStatus is eof (%d)\n", programName, status);
        break;
    default:
        if (verbose_m) Rf_warning("%s: ParseStatus is not documented %d\n", programName, status);
        UNPROTECT(2);
        mb_m.rewind();
        return 1;
        break;
    }
    UNPROTECT(2);
    return 0;
}

// this is a non-throwing version returning an error code
int REmbed::parseEval(QString line, SEXP & ans) {
    ParseStatus status;
    SEXP cmdSexp, cmdexpr = R_NilValue;
    int i, errorOccurred;

    program << line;

    PROTECT(cmdSexp = Rf_allocVector(STRSXP, 1));
    SET_STRING_ELT(cmdSexp, 0, Rf_mkChar(program.join(" ").toStdString().c_str()));

    cmdexpr = PROTECT(R_ParseVector(cmdSexp, -1, &status, R_NilValue));

    switch (status){
    case PARSE_OK:
        // Loop is needed here as EXPSEXP might be of length > 1
        for(i = 0; i < Rf_length(cmdexpr); i++){
            ans = R_tryEval(VECTOR_ELT(cmdexpr, i), R_GlobalEnv, &errorOccurred);
            if (errorOccurred) {
                if (verbose) Rf_warning("%s: Error in evaluating R code (%d)\n", name, status);
                UNPROTECT(2);
                program.clear();
                return 1;
            }
            if (verbose) {
                Rf_PrintValue(ans);
            }
        }
        program.clear();
        break;
    case PARSE_INCOMPLETE:
        // need to read another line
        break;
    case PARSE_NULL:
        if (verbose) Rf_warning("%s: ParseStatus is null (%d)\n", name, status);
        UNPROTECT(2);
        program.clear();
        return 1;
        break;
    case PARSE_ERROR:
        if (verbose) Rf_error("Parse Error: \"%s\"\n", line.toStdString().c_str());
        UNPROTECT(2);
        program.clear();
        return 1;
        break;
    case PARSE_EOF:
        if (verbose) Rf_warning("%s: ParseStatus is eof (%d)\n", name, status);
        break;
    default:
        if (verbose) Rf_warning("%s: ParseStatus is not documented %d\n", name, status);
        UNPROTECT(2);
        program.clear();
        return 1;
        break;
    }
    UNPROTECT(2);
    return 0;
}

/* Errors that may occur in loading font characters.
   Here we just give warnings. */
void errorcode(FT_Error err)
{
    switch(err)
    {
        case 0x10:
            Rf_warning("freetype: invalid glyph index");
            break;
        case 0x11:
            Rf_warning("freetype: invalid character code");
            break;
        case 0x12:
            Rf_warning("freetype: unsupported glyph image format");
            break;
        case 0x13:
            Rf_warning("freetype: cannot render this glyph format");
            break;
        case 0x14:
            Rf_warning("freetype: invalid outline");
            break;
        case 0x15:
            Rf_warning("freetype: invalid composite glyph");
            break;
        case 0x16:
            Rf_warning("freetype: too many hints");
            break;
        case 0x17:
            Rf_warning("freetype: invalid pixel size");
            break;
        default:
            Rf_warning("freetype: error code %d", err);
            break;
    }
}

void omxGlobal::reportProgress(const char *context, FitContext *fc)
{
	if (omx_absolute_thread_num() != 0) {
		mxLog("omxGlobal::reportProgress called in a thread context (report this bug to developers)");
		return;
	}

	R_CheckUserInterrupt();

	time_t now = time(0);
	if (Global->maxSeconds > 0 && now > Global->startTime + Global->maxSeconds && !Global->timedOut) {
		Global->timedOut = true;
		Rf_warning("Time limit of %d minutes %d seconds exceeded",
			   Global->maxSeconds/60, Global->maxSeconds % 60);
	}
	if (silent || now - lastProgressReport < 1 || fc->getGlobalComputeCount() == previousComputeCount) return;

	lastProgressReport = now;

	std::string str;
	if (previousReportFit == 0.0 || previousReportFit == fc->fit) {
		str = string_snprintf("%s %d %.6g",
				      context, fc->getGlobalComputeCount(), fc->fit);
	} else {
		str = string_snprintf("%s %d %.6g %.4g",
				      context, fc->getGlobalComputeCount(), fc->fit, fc->fit - previousReportFit);
	}

	reportProgressStr(str.c_str());
	previousReportLength = str.size();
	previousReportFit = fc->fit;
	previousComputeCount = fc->getGlobalComputeCount();
}

int R_curl_callback_progress(SEXP fun,
                             double dltotal, double dlnow,
                             double ultotal, double ulnow) {

    SEXP down = PROTECT(allocVector(REALSXP, 2));
    REAL(down)[0] = dltotal;
    REAL(down)[1] = dlnow;

    SEXP up = PROTECT(allocVector(REALSXP, 2));
    REAL(up)[0] = ultotal;
    REAL(up)[1] = ulnow;

    SEXP call = PROTECT(LCONS(fun, LCONS(down, LCONS(up, R_NilValue))));
    int ok;
    SEXP res = PROTECT(R_tryEval(call, R_GlobalEnv, &ok));

    if (ok != 0 || pending_interrupt()) {
        UNPROTECT(4);
        return 0;
    }

    if (TYPEOF(res) != LGLSXP || length(res) != 1) {
        UNPROTECT(4);
        Rf_warning("progress callback must return boolean");
        return 0;
    }

    UNPROTECT(4);
    return !asLogical(res);
}

/** Read settings flags from a list
 *
 * may call Rf_error
 *
 * @param opts_fixed list
 * @param allow_overlap
 * @return flags
 *
 * @version 0.4-1 (Marek Gagolewski, 2014-12-07)
 *
 * @version 0.4-1 (Marek Gagolewski, 2014-12-08)
 *    add `overlap` option
 */
uint32_t StriContainerByteSearch::getByteSearchFlags(SEXP opts_fixed, bool allow_overlap)
{
   uint32_t flags = 0;
   if (!isNull(opts_fixed) && !Rf_isVectorList(opts_fixed))
      Rf_error(MSG__ARG_EXPECTED_LIST, "opts_fixed"); // error() call allowed here

   R_len_t narg = isNull(opts_fixed)?0:LENGTH(opts_fixed);

   if (narg > 0) {

      SEXP names = Rf_getAttrib(opts_fixed, R_NamesSymbol);
      if (names == R_NilValue || LENGTH(names) != narg)
         Rf_error(MSG__FIXED_CONFIG_FAILED); // error() call allowed here

      for (R_len_t i=0; i<narg; ++i) {
         if (STRING_ELT(names, i) == NA_STRING)
            Rf_error(MSG__FIXED_CONFIG_FAILED); // error() call allowed here

         const char* curname = CHAR(STRING_ELT(names, i));

         if  (!strcmp(curname, "case_insensitive")) {
            bool val = stri__prepare_arg_logical_1_notNA(VECTOR_ELT(opts_fixed, i), "case_insensitive");
            if (val) flags |= BYTESEARCH_CASE_INSENSITIVE;
         } else if  (!strcmp(curname, "overlap") && allow_overlap) {
            bool val = stri__prepare_arg_logical_1_notNA(VECTOR_ELT(opts_fixed, i), "overlap");
            if (val) flags |= BYTESEARCH_OVERLAP;
         } else {
            Rf_warning(MSG__INCORRECT_FIXED_OPTION, curname);
         }
      }
   }

   return flags;
}

/* stdout() in R only supports text mode, but we need binary */
SEXP stdout_writeBin(SEXP what, SEXP sFlush) {
    if (TYPEOF(what) != RAWSXP) Rf_error("invalid content - must be a raw vector");
    if (LENGTH(what) && fwrite(RAW(what), LENGTH(what), 1, stdout) != 1)
	Rf_warning("write error while writing to stdout");
    if (asInteger(sFlush)) fflush(stdout);
    return R_NilValue;
}

SEXP dbarts_makeModelMatrixFromDataFrame(SEXP x, SEXP dropColumnsExpr)
{
  int errorCode = 0;
  SEXP result = R_NilValue;
  SEXP dropPatternExpr = R_NilValue;
  int protectCount = 0;
  
  size_t numInputColumns = (size_t) rc_getLength(x);
  size_t numOutputColumns = 0;
  
  column_type columnTypes[numInputColumns];
  
  getColumnTypes(x, columnTypes);
  
  bool createDropPattern = false;
  if (Rf_isLogical(dropColumnsExpr)) {
    createDropPattern = LOGICAL(dropColumnsExpr)[0] == TRUE;
    if (createDropPattern) {
      dropPatternExpr = PROTECT(rc_newList(numInputColumns));
      ++protectCount;
      if (rc_getNames(x) != R_NilValue) rc_setNames(dropPatternExpr, rc_getNames(x));
    }
  } else if (!createDropPattern && Rf_isVector(dropColumnsExpr)) {
    dropPatternExpr = dropColumnsExpr;
  }
  
  countMatrixColumns(x, columnTypes, dropPatternExpr, createDropPattern, &numOutputColumns);
  
  size_t numRows = getNumRowsForDataFrame(x);
  
  if (numRows == 0) {
    errorCode = EINVAL;
    goto mkmm_cleanup;
  }
  
  result = PROTECT(rc_newReal(numRows * numOutputColumns));
  ++protectCount;
  rc_setDims(result, (int) numRows, (int) numOutputColumns, -1);
  
  SEXP dimNamesExpr = PROTECT(rc_newList(2));
  rc_setDimNames(result, dimNamesExpr);
  UNPROTECT(1);
  SET_VECTOR_ELT(dimNamesExpr, 1, rc_newCharacter(numOutputColumns));
  
  errorCode = createMatrix(x, numRows, result, columnTypes, dropPatternExpr);
  
mkmm_cleanup:
  if (errorCode != 0) {
    if (protectCount > 0) UNPROTECT(protectCount);
    
    Rf_warning("error in makeModelMatrix: %s", strerror(errorCode));
    return R_NilValue;
  }
  
  if (dropPatternExpr != NULL) Rf_setAttrib(result, Rf_install("drop"), dropPatternExpr);
  
  if (protectCount > 0) UNPROTECT(protectCount);
  
  return result;
}

/**
 *  Unescape Unicode code points
 *
 *  @param str character vector
 *  @return character vector
 *
 * @version 0.1-?? (Marek Gagolewski, 2013-08-17)
 *
 * @version 0.3-1 (Marek Gagolewski, 2014-11-04)
 *    Issue #112: str_prepare_arg* retvals were not PROTECTed from gc
*/
SEXP stri_unescape_unicode(SEXP str)
{
   PROTECT(str = stri_prepare_arg_string(str, "str")); // prepare string argument

   STRI__ERROR_HANDLER_BEGIN(1)
   R_len_t str_length = LENGTH(str);
   StriContainerUTF16 str_cont(str, str_length, false); // writable

   for (R_len_t i = str_cont.vectorize_init();
         i != str_cont.vectorize_end();
         i = str_cont.vectorize_next(i))
   {
      if (str_cont.isNA(i) || str_cont.get(i).length() == 0)
         continue; // leave as-is

      str_cont.getWritable(i).setTo(str_cont.get(i).unescape());

      if (str_cont.get(i).length() == 0) {
         Rf_warning(MSG__INVALID_ESCAPE);
         str_cont.setNA(i); // something went wrong
      }
   }

   STRI__UNPROTECT_ALL
   return str_cont.toR();
   STRI__ERROR_HANDLER_END(;/* nothing special to be done on error */)
}

static void defaultSetVarGroup(omxExpectation *ox, FreeVarGroup *fvg)
{
	if (OMX_DEBUG && ox->freeVarGroup && ox->freeVarGroup != fvg) {
		Rf_warning("setFreeVarGroup called with different group (%d vs %d) on %s",
			ox->name, ox->freeVarGroup->id[0], fvg->id[0]);
	}
	ox->freeVarGroup = fvg;
}

void omxGlobal::unpackConfidenceIntervals(omxState *currentState)
{
	if (unpackedConfidenceIntervals) return;
	unpackedConfidenceIntervals = true;

	// take care to preserve order
	std::vector<ConfidenceInterval*> tmp;
	std::swap(tmp, intervalList);
	std::set<ConfidenceInterval*, ciCmp> uniqueCIs;

	for (int ix=0; ix < (int) tmp.size(); ++ix) {
		ConfidenceInterval *ci = tmp[ix];
		if (!ci->isWholeAlgebra()) {
			auto iter = uniqueCIs.find(ci);
			if (iter == uniqueCIs.end()) {
				uniqueCIs.insert(ci);
				intervalList.push_back(ci);
			} else if (ci->cmpBoundAndType(**iter)) {
				Rf_warning("Different confidence intervals '%s' and '%s' refer to the same thing",
					   ci->name.c_str(), (*iter)->name.c_str());
			}
			continue;
		}
		omxMatrix *mat = ci->getMatrix(currentState);
		for (int cx=0; cx < mat->cols; ++cx) {
			for (int rx=0; rx < mat->rows; ++rx) {
				ConfidenceInterval *cell = new ConfidenceInterval(*ci);
				cell->name = string_snprintf("%s[%d,%d]", ci->name.c_str(), 1+rx, 1+cx);
				cell->row = rx;
				cell->col = cx;
				auto iter = uniqueCIs.find(cell);
				if (iter == uniqueCIs.end()) {
					uniqueCIs.insert(cell);
					intervalList.push_back(cell);
				} else {
					if (cell->cmpBoundAndType(**iter)) {
						Rf_warning("Different confidence intervals '%s' and '%s' refer to the same thing",
							   cell->name.c_str(), (*iter)->name.c_str());
					}
					delete cell;
				}
			}
		}
		delete ci;
	}
}

/** Convert character vector to UTF-32
 *
 * @param str character vector
 * @return list with integer vectors
 *
 * @version 0.1-?? (Marek Gagolewski)
 *
 * @version 0.1-?? (Marek Gagolewski, 2013-06-16)
 *          make StriException-friendly
 *
 * @version 0.2-1 (Marek Gagolewski, 2014-03-26)
 *          use vector<UChar32> buf instead of R_alloc;
 *          warn and set NULL on improper UTF-8 byte sequences
 *
 * @version 0.2-3 (Marek Gagolewski, 2014-05-12)
 *          Use UChar32* instead of vector<UChar32> as ::data is C++11
 *
 * @version 0.3-1 (Marek Gagolewski, 2014-11-04)
 *    Issue #112: str_prepare_arg* retvals were not PROTECTed from gc
 */
SEXP stri_enc_toutf32(SEXP str)
{
   PROTECT(str = stri_prepare_arg_string(str, "str"));
   R_len_t n = LENGTH(str);

   STRI__ERROR_HANDLER_BEGIN(1)
   StriContainerUTF8 str_cont(str, n);

   R_len_t bufsize = 1; // to avoid allocating an empty buffer
   for (R_len_t i=0; i<n; ++i) {
      if (str_cont.isNA(i)) continue;
      R_len_t ni = str_cont.get(i).length();
      if (ni > bufsize) bufsize = ni;
   }

   UChar32* buf = (UChar32*)R_alloc((size_t)bufsize, (int)sizeof(UChar32)); // at most bufsize UChars32 (bufsize/4 min.)
   if (!buf) throw StriException(MSG__MEM_ALLOC_ERROR);
   // deque<UChar32> was slower than using a common, over-sized buf

   SEXP ret;
   STRI__PROTECT(ret = Rf_allocVector(VECSXP, n)); // all

   for (R_len_t i=0; i<n; ++i) {

      if (str_cont.isNA(i)) {
         SET_VECTOR_ELT(ret, i, R_NilValue);
         continue;
      }

      UChar32 c = (UChar32)0;
      const char* s = str_cont.get(i).c_str();
      R_len_t sn = str_cont.get(i).length();
      R_len_t j = 0;
      R_len_t k = 0;
      while (c >= 0 && j < sn) {
         U8_NEXT(s, j, sn, c);
         buf[k++] = (int)c;
      }

      if (c < 0) {
         Rf_warning(MSG__INVALID_UTF8);
         SET_VECTOR_ELT(ret, i, R_NilValue);
         continue;
      }
      else {
         SEXP conv;
         STRI__PROTECT(conv = Rf_allocVector(INTSXP, k));
         memcpy(INTEGER(conv), buf, (size_t)sizeof(int)*k);
         SET_VECTOR_ELT(ret, i, conv);
         STRI__UNPROTECT(1);
      }
   }

   STRI__UNPROTECT_ALL
   return ret;
   STRI__ERROR_HANDLER_END({ /* do nothing on error */ })
}

void
RXSLT_Warning(xmlXPathParserContextPtr ctxt, const char *msg)
{
/*XXX */
//    xsltTransformError(xsltXPathGetTransformContext(ctxt), NULL, xsltXPathGetTransformContext(ctxt)->insert, msg);
    Rf_warning(msg);
    /* PROBLEM msg
       WARN; */
}

/* Rmpc_get_rounding - return the MPC rounding method based on R option.
 *
 * Args:
 *   None
 * Return value:
 *   An MPC rounding mode, e.g. MPC_RNDNN.
 */
int Rmpc_get_rounding() {
	const char *round_mode = CHAR(STRING_ELT(Rf_GetOption(
			Rf_install("mpc.rounding"), R_BaseEnv), 0));
	int real_round, imag_round;
	if (strlen(round_mode) != 9) {
		Rf_warning("Invalid mpc.rounding option, using MPC_RNDNN");
		return(MPC_RNDNN);
	}
	switch (round_mode[7]) {
	case 'N':
		real_round = GMP_RNDN;
		break;
	case 'Z':
		real_round = GMP_RNDZ;
		break;
	case 'U':
		real_round = GMP_RNDU;
		break;
	case 'D':
		real_round = GMP_RNDD;
		break;
	default:
		Rf_warning("Invalid mpc.rounding option, using MPC_RNDNN");
		return(MPC_RNDNN);
	}
	switch(round_mode[8]) {
	case 'N':
		imag_round = GMP_RNDN;
		break;
	case 'Z':
		imag_round = GMP_RNDZ;
		break;
	case 'U':
		imag_round = GMP_RNDU;
		break;
	case 'D':
		imag_round = GMP_RNDD;
		break;
	default:
		Rf_warning("Invalid mpc.rounding option, using MPC_RNDNN");
		return(MPC_RNDNN);
	}
	return (RNDC(real_round, imag_round));
}