Пример #1
0
/* .Internal(print.default(x, digits, quote, na.print, print.gap,
                           right, useS4)) */
SEXP do_printdefault(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP x, naprint;
    int tryS4;
    Rboolean callShow = FALSE;

    checkArity(op, args);
    PrintDefaults(rho);

    x = CAR(args); args = CDR(args);

    if(!isNull(CAR(args))) {
	R_print.digits = asInteger(CAR(args));
	if (R_print.digits == NA_INTEGER ||
	    R_print.digits < R_MIN_DIGITS_OPT ||
	    R_print.digits > R_MAX_DIGITS_OPT)
		errorcall(call, _("invalid 'digits' argument"));
    }
    args = CDR(args);

    R_print.quote = asLogical(CAR(args));
    if(R_print.quote == NA_LOGICAL)
	errorcall(call, _("invalid 'quote' argument"));
    args = CDR(args);

    naprint = CAR(args);
    if(!isNull(naprint))  {
	if(!isString(naprint) || LENGTH(naprint) < 1)
	    errorcall(call, _("invalid 'na.print' specification"));
	R_print.na_string = R_print.na_string_noquote = STRING_ELT(naprint, 0);
	R_print.na_width = R_print.na_width_noquote =
	    strlen(CHAR(R_print.na_string));
    }
    args = CDR(args);

    if(!isNull(CAR(args))) {
	R_print.gap = asInteger(CAR(args));
	if (R_print.gap == NA_INTEGER || R_print.gap < 0)
	    errorcall(call, _("'gap' must be non-negative integer"));
    }
    args = CDR(args);

    R_print.right = asLogical(CAR(args));
    if(R_print.right == NA_LOGICAL)
	errorcall(call, _("invalid 'right' argument"));
    args = CDR(args);

    tryS4 = asLogical(CAR(args));
    if(tryS4 == NA_LOGICAL)
	errorcall(call, _("invalid 'tryS4' internal argument"));

    if(tryS4 && isObject(x) && isMethodsDispatchOn()) {
	SEXP class = getAttrib(x, R_ClassSymbol);
	if(length(class) == 1) {
	    /* internal version of isClass() */
	    char str[201];
	    snprintf(str, 200, ".__C__%s", CHAR(STRING_ELT(class, 0)));
	    if(findVar(install(str), rho) != R_UnboundValue)
		callShow = TRUE;
	}
    }
Пример #2
0
/* .Internal(print.default(x, digits, quote, na.print, print.gap,
			   right, max, useS4)) */
SEXP attribute_hidden do_printdefault(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP x, naprint;
    int tryS4;
    Rboolean callShow = FALSE;

    checkArity(op, args);
    PrintDefaults();

    x = CAR(args); args = CDR(args);

    if(!isNull(CAR(args))) {
	R_print.digits = asInteger(CAR(args));
	if (R_print.digits == NA_INTEGER ||
	    R_print.digits < R_MIN_DIGITS_OPT ||
	    R_print.digits > R_MAX_DIGITS_OPT)
	    error(_("invalid '%s' argument"), "digits");
    }
    args = CDR(args);

    R_print.quote = asLogical(CAR(args));
    if(R_print.quote == NA_LOGICAL)
	error(_("invalid '%s' argument"), "quote");
    args = CDR(args);

    naprint = CAR(args);
    if(!isNull(naprint))  {
	if(!isString(naprint) || LENGTH(naprint) < 1)
	    error(_("invalid 'na.print' specification"));
	R_print.na_string = R_print.na_string_noquote = STRING_ELT(naprint, 0);
	R_print.na_width = R_print.na_width_noquote =
	    (int) strlen(CHAR(R_print.na_string));
    }
    args = CDR(args);

    if(!isNull(CAR(args))) {
	R_print.gap = asInteger(CAR(args));
	if (R_print.gap == NA_INTEGER || R_print.gap < 0)
	    error(_("'gap' must be non-negative integer"));
    }
    args = CDR(args);

    R_print.right = (Rprt_adj) asLogical(CAR(args)); /* Should this be asInteger()? */
    if(R_print.right == NA_LOGICAL)
	error(_("invalid '%s' argument"), "right");
    args = CDR(args);

    if(!isNull(CAR(args))) {
	R_print.max = asInteger(CAR(args));
	if(R_print.max == NA_INTEGER || R_print.max < 0)
	    error(_("invalid '%s' argument"), "max");
	else if(R_print.max == INT_MAX) R_print.max--; // so we can add
    }
    args = CDR(args);

    R_print.useSource = asLogical(CAR(args));
    if(R_print.useSource == NA_LOGICAL)
	error(_("invalid '%s' argument"), "useSource");
    if(R_print.useSource) R_print.useSource = USESOURCE;
    args = CDR(args);

    tryS4 = asLogical(CAR(args));
    if(tryS4 == NA_LOGICAL)
	error(_("invalid 'tryS4' internal argument"));

    if(tryS4 && IS_S4_OBJECT(x) && isMethodsDispatchOn())
	callShow = TRUE;

    if(callShow) {
	/* we need to get show from the methods namespace if it is
	   not visible on the search path. */
	SEXP call, showS;
	showS = findVar(install("show"), rho);
	if(showS == R_UnboundValue) {
	    SEXP methodsNS = R_FindNamespace(mkString("methods"));
	    if(methodsNS == R_UnboundValue)
		error("missing methods namespace: this should not happen");
	    PROTECT(methodsNS);
	    showS = findVarInFrame3(methodsNS, install("show"), TRUE);
	    UNPROTECT(1);
	    if(showS == R_UnboundValue)
		error("missing show() in methods namespace: this should not happen");
	}
	PROTECT(call = lang2(showS, x));
	eval(call, rho);
	UNPROTECT(1);
    } else {
	CustomPrintValue(x, rho);
    }

    PrintDefaults(); /* reset, as na.print etc may have been set */
    return x;
}/* do_printdefault */