The R Project SVN – R – Diff – /trunk/src/main/plot.c

 	    s = CDR(s);
+	}
+    }
+}
 /*
  * Extract specified par from list of inline pars
  */
 SEXP getInlinePar(SEXP s, char *name)
+{
     SEXP result = R_NilValue;
 	while (s != R_NilValue) {
 	    if (isList(CAR(s))) {
 		result = getInlinePar(CAR(s), name);
 		if (result)
 		    found = 1;
 	    } else
 		if (TAG(s) != R_NilValue)
 		    if (!strcmp(CHAR(PRINTNAME(TAG(s))), name)) {
 			result = CAR(s);
 			found = 1;
+		    }
 	    s = CDR(s);
+	}
     }
     return result;
+}
 SEXP FixupPch(SEXP pch, int dflt)
+{
 	GConvert(&xx0, &yy0, USER, DEVICE, dd);
 	GConvert(&xx1, &yy1, USER, DEVICE, dd);
 	if (R_FINITE(xx0) && R_FINITE(yy0) && R_FINITE(xx1) && R_FINITE(yy1)) {
 	    if (isNAcol(rawcol, i, ncol))
 		Rf_gpptr(dd)->col = Rf_dpptr(dd)->col;
 	    else
 		Rf_gpptr(dd)->col = INTEGER(col)[i % ncol];
 	    if (nlty == 0 || INTEGER(lty)[i % nlty] == NA_INTEGER)
 		Rf_gpptr(dd)->lty = Rf_dpptr(dd)->lty;
 	    else
 		Rf_gpptr(dd)->lty = INTEGER(lty)[i % nlty];
 	if (R_FINITE(cexval)) Rf_gpptr(dd)->cex = cexval;
 	else cexval = cexsave;
 	Rf_gpptr(dd)->font = (fontval == NA_INTEGER) ? fontsave : fontval;
 	if (isNAcol(rawcol, i, ncol))
 	    Rf_gpptr(dd)->col = colsave;
 	else
 	    Rf_gpptr(dd)->col = colval;
 	Rf_gpptr(dd)->adj = ComputeAdjValue(adjval, sideval, Rf_gpptr(dd)->las);
 	atval = ComputeAtValue(atval, Rf_gpptr(dd)->adj, sideval, Rf_gpptr(dd)->las,
 			       outerval, dd);
     which = asInteger(CAR(args)); args = CDR(args);
     if (which < 1 || which > 4)
 	errorcall(call, "invalid \"which\" specification");
     /*
      * If specified non-NA col then use that, else ...
      *
      * if specified non-NA fg then use that, else ...
+     *
      * else use par("col")
      */
     col= Rf_gpptr(dd)->col;
     ProcessInlinePars(args, dd, call);
     colsxp = getInlinePar(args, "col");
     if (isNAcol(colsxp, 0, 1)) {
 	fgsxp = getInlinePar(args, "fg");
 	if (isNAcol(fgsxp, 0, 1))
 	    Rf_gpptr(dd)->col = col;
 	else
 	    Rf_gpptr(dd)->col = Rf_gpptr(dd)->fg;
     }
     /* override par("xpd") and force clipping to device region */
     Rf_gpptr(dd)->xpd = 2;
     GMode(1, dd);
     GBox(which, dd);
     GMode(0, dd);
 	return ans;
+    }
+}
-SEXP do_strheight(SEXP call, SEXP op, SEXP args, SEXP env)
+/* strheight(str, units)  ||  strwidth(str, units) */
-{
-    /* strheight(str, units) */
+#define DO_STR_DIM(KIND) 						\
+{									\
-    SEXP ans, str, ch;
+    SEXP ans, str, ch;							\
-    int i, n, units;
+    int i, n, units;							\
-    double cex, cexsave;
+    double cex, cexsave;						\
-    DevDesc *dd = CurrentDevice();
+    DevDesc *dd = CurrentDevice();					\
+									\
-    checkArity(op,args);
+    checkArity(op, args);						\
-    GCheckState(dd);
+    GCheckState(dd);							\
+									\
-    str = CAR(args);
+    str = CAR(args);							\
-    if (isSymbol(str) || isLanguage(str))
+    if (isSymbol(str) || isLanguage(str))				\
-	str = coerceVector(str, EXPRSXP);
+	str = coerceVector(str, EXPRSXP);				\
-    else if (!isExpression(str))
+    else if (!isExpression(str))					\
-	str = coerceVector(str, STRSXP);
+	str = coerceVector(str, STRSXP);				\
-    PROTECT(str);
+    PROTECT(str);							\
-    args = CDR(args);
+    args = CDR(args);							\
+									\
-    if ((units = asInteger(CAR(args))) == NA_INTEGER || units < 0)
+    if ((units = asInteger(CAR(args))) == NA_INTEGER || units < 0)	\
-	errorcall(call, "invalid units");
+	errorcall(call, "invalid units");				\
-    args = CDR(args);
+    args = CDR(args);							\
+									\
-    if (isNull(CAR(args)))
+    if (isNull(CAR(args)))						\
-	cex = Rf_gpptr(dd)->cex;
+	cex = Rf_gpptr(dd)->cex;					\
-    else if (!R_FINITE(cex = asReal(CAR(args))) || cex <= 0.0)
+    else if (!R_FINITE(cex = asReal(CAR(args))) || cex <= 0.0)		\
-	errorcall(call, "invalid cex value");
+	errorcall(call, "invalid cex value");				\
+									\
-    n = LENGTH(str);
+    n = LENGTH(str);							\
-    PROTECT(ans = allocVector(REALSXP, n));
+    PROTECT(ans = allocVector(REALSXP, n));				\
-    cexsave = Rf_gpptr(dd)->cex;
+    cexsave = Rf_gpptr(dd)->cex;					\
-    Rf_gpptr(dd)->cex = cex * Rf_gpptr(dd)->cexbase;
+    Rf_gpptr(dd)->cex = cex * Rf_gpptr(dd)->cexbase;			\
-    for (i = 0; i < n; i++)
+    for (i = 0; i < n; i++)						\
-	if (isExpression(str))
+	if (isExpression(str))						\
-	    REAL(ans)[i] = GExpressionHeight(VECTOR_ELT(str, i),
+	    REAL(ans)[i] = GExpression ## KIND(VECTOR_ELT(str, i),	\
-					     GMapUnits(units), dd);
+					     GMapUnits(units), dd);	\
-	else {
+	else {								\
-	    ch = STRING_ELT(str, i);
+	    ch = STRING_ELT(str, i);					\
-	    REAL(ans)[i] = (ch == NA_STRING) ? 0.0 :
+	    REAL(ans)[i] = (ch == NA_STRING) ? 0.0 :			\
-		GStrHeight(CHAR(ch), GMapUnits(units), dd);
+		GStr ## KIND(CHAR(ch), GMapUnits(units), dd);		\
-	}
+	}								\
-    Rf_gpptr(dd)->cex = cexsave;
+    Rf_gpptr(dd)->cex = cexsave;					\
-    UNPROTECT(2);
+    UNPROTECT(2);							\
-    return ans;
+    return ans;								\
+}
+SEXP do_strheight(SEXP call, SEXP op, SEXP args, SEXP env)
+DO_STR_DIM(Height)
-SEXP do_strwidth(SEXP call, SEXP op, SEXP args, SEXP env)
+SEXP do_strwidth (SEXP call, SEXP op, SEXP args, SEXP env)
-{
-    /* strwidth(str, units) */
-    SEXP ans, str, ch;
-    int i, n, units;
-    double cex, cexsave;
-    DevDesc *dd = CurrentDevice();
-    checkArity(op, args);
-    GCheckState(dd);
-    str = CAR(args);
-    if (isSymbol(str) || isLanguage(str))
-	str = coerceVector(str, EXPRSXP);
-    else if (!isExpression(str))
-	str = coerceVector(str, STRSXP);
-    PROTECT(str);
+DO_STR_DIM(Width)
-    args = CDR(args);
-    if ((units = asInteger(CAR(args))) == NA_INTEGER || units < 0)
-	errorcall(call, "invalid units");
-    args = CDR(args);
+#undef DO_STR_DIM
-    if (isNull(CAR(args)))
-	cex = Rf_gpptr(dd)->cex;
-    else if (!R_FINITE(cex = asReal(CAR(args))) || cex <= 0.0)
-	errorcall(call, "invalid cex value");
-    n = LENGTH(str);
-    PROTECT(ans = allocVector(REALSXP, n));
-    cexsave = Rf_gpptr(dd)->cex;
-    Rf_gpptr(dd)->cex = cex * Rf_gpptr(dd)->cexbase;
-    for (i = 0; i < n; i++)
-	if (isExpression(str))
-	    REAL(ans)[i] = GExpressionWidth(VECTOR_ELT(str, i),
-					    GMapUnits(units), dd);
-	else {
-	    ch = STRING_ELT(str, i);
-	    REAL(ans)[i] = (ch == NA_STRING) ? 0.0 :
-		GStrWidth(CHAR(ch), GMapUnits(units), dd);
-	}
-    Rf_gpptr(dd)->cex = cexsave;
-    UNPROTECT(2);
-    return ans;
-}
 static int *dnd_lptr;
 static int *dnd_rptr;
 static double *dnd_hght;
 static double *dnd_xpos;

The R Project SVN R

(root)/trunk/src/main/plot.c @ 28362 – Rev 30129 → 30186