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

+	}
+    }
     return at;
+}
+static double ComputePAdjValue(double padj, int side, int las)
+{
+    if (!R_FINITE(padj)) {
+    switch(las) {
+    case 0:/* parallel to axis */
+        padj = 0.0; break;
+    case 1:/* horizontal */
+        switch(side) {
+        case 1:
+        case 3: padj = 0.0; break;
+        case 2:
+        case 4: padj = 0.5; break;
+        }
+        break;
+    case 2:/* perpendicular to axis */
+        padj = 0.5; break;
+    case 3:/* vertical */
+        switch(side) {
+        case 1:
+        case 3: padj = 0.5; break;
+        case 2:
+        case 4: padj = 0.0; break;
+        }
+        break;
+    }
+    }
+    return padj;
+}
 SEXP do_axis(SEXP call, SEXP op, SEXP args, SEXP env)
+{
     /* axis(side, at, labels, tick, line, pos,
-     *	    outer, font, vfont, lty, lwd, col, ...) */
+     *	    outer, font, vfont, lty, lwd, col, padj, ...) */
-    SEXP at, lab, vfont;
+    SEXP at, lab, vfont, padj;
-    int col, font, lty;
+    int col, font, lty, npadj;
     int i, n, nint = 0, ntmp, side, *ind, outer, lineoff = 0;
     int istart, iend, incr;
     Rboolean dolabels, doticks, logflag = FALSE;
     Rboolean create_at, vectorFonts = FALSE;
     double x, y, temp, tnew, tlast;
     /* Optional argument: "col" */
     col = asInteger(FixupCol(CAR(args), Rf_gpptr(dd)->fg));
     args = CDR(args);
+    /* Optional argument: "padj" */
+    PROTECT(padj = coerceVector(CAR(args), REALSXP));
+    npadj = length(padj);
+    if (npadj <= 0) errorcall(call, "zero length \"padj\" specified");
+    if (n < npadj) n = npadj;
+    args = CDR(args);
     /* Retrieve relevant "par" values. */
     switch(side) {
     case 1:
     case 3:
      * If it is, we just bail out at this point. */
     if (((side == 1 || side == 3) && Rf_gpptr(dd)->xaxt == 'n') ||
 	((side == 2 || side == 4) && Rf_gpptr(dd)->yaxt == 'n')) {
 	GRestorePars(dd);
-	UNPROTECT(4);
+	UNPROTECT(5);
 	return R_NilValue;
+    }
     /* no! we do allow an `lty' argument -- will not be used often though
 	    istart = 0;
 	    iend = n;
 	    incr = 1;
+	}
 	for (i = istart; i != iend; i += incr) {
+	    double padjval = REAL(padj)[i%npadj];
+	    padjval = ComputePAdjValue(padjval, side, Rf_gpptr(dd)->las);
 	    x = REAL(at)[i];
 	    if (!R_FINITE(x)) continue;
 	    temp = GConvertX(x, USER, NFC, dd);
 	    if (dolabels) {
 		/* Clip tick labels to user coordinates. */
 		if (x > low && x < high) {
 		    if (isExpression(lab)) {
 			GMMathText(VECTOR_ELT(lab, ind[i]), side,
-				   axis_lab, 0, x, Rf_gpptr(dd)->las, dd);
+				   axis_lab, 0, x, Rf_gpptr(dd)->las,
+				   padjval, dd);
+		    }
 		    else {
 			label = STRING_ELT(lab, ind[i]);
 			if(label != NA_STRING) {
 			    labw = GStrWidth(CHAR(label), NFC, dd);
 			    /* Check room for perpendicular labels. */
 			    if (Rf_gpptr(dd)->las == 2 ||
 				Rf_gpptr(dd)->las == 3 ||
 				tnew - tlast >= gap) {
 				GMtext(CHAR(label), side, axis_lab, 0, x,
-				       Rf_gpptr(dd)->las, dd);
+				       Rf_gpptr(dd)->las, padjval, dd);
 				tlast = temp + 0.5 *labw;
+			    }
+			}
+		    }
+		}
 	    istart = 0;
 	    iend = n;
 	    incr = 1;
+	}
 	for (i = istart; i != iend; i += incr) {
+	    double padjval = REAL(padj)[i%npadj];
+	    padjval = ComputePAdjValue(padjval, side, Rf_gpptr(dd)->las);
 	    y = REAL(at)[i];
 	    if (!R_FINITE(y)) continue;
 	    temp = GConvertY(y, USER, NFC, dd);
 	    if (dolabels) {
 		/* Clip tick labels to user coordinates. */
 		if (y > low && y < high) {
 		    if (isExpression(lab)) {
 			GMMathText(VECTOR_ELT(lab, ind[i]), side,
-				   axis_lab, 0, y, Rf_gpptr(dd)->las, dd);
+				   axis_lab, 0, y, Rf_gpptr(dd)->las,
+				   padjval, dd);
+		    }
 		    else {
 			label = STRING_ELT(lab, ind[i]);
 			if(label != NA_STRING) {
 			    labw = GStrWidth(CHAR(label), INCHES, dd);
 			    /* Check room for perpendicular labels. */
 			    if (Rf_gpptr(dd)->las == 1 ||
 				Rf_gpptr(dd)->las == 2 ||
 				tnew - tlast >= gap) {
 				GMtext(CHAR(label), side, axis_lab, 0, y,
-				       Rf_gpptr(dd)->las, dd);
+				       Rf_gpptr(dd)->las, padjval, dd);
 				tlast = temp + 0.5 *labw;
+			    }
+			}
+		    }
+		}
+	    }
+	}
 	break;
     } /* end  switch(side, ..) */
-    UNPROTECT(4); /* lab, vfont, at, lab again */
+    UNPROTECT(5); /* lab, vfont, at, lab, padj again */
     GMode(0, dd);
     GRestorePars(dd);
     /* NOTE: only record operation if no "error"  */
     if (GRecording(call))
 	recordGraphicOperation(op, originalArgs, dd);
 	 vfont = NULL,
 	 ...) */
 SEXP do_mtext(SEXP call, SEXP op, SEXP args, SEXP env)
+{
-    SEXP text, side, line, outer, at, adj, cex, col, font, vfont, string;
+    SEXP text, side, line, outer, at, adj, padj, cex, col, font, vfont, string;
     SEXP rawcol;
-    int ntext, nside, nline, nouter, nat, nadj, ncex, ncol, nfont;
+    int ntext, nside, nline, nouter, nat, nadj, npadj, ncex, ncol, nfont;
     Rboolean dirtyplot = FALSE, gpnewsave = FALSE, dpnewsave = FALSE;
     Rboolean vectorFonts = FALSE;
     int i, n, fontsave, colsave;
     double cexsave;
     SEXP originalArgs = args;
     nadj = length(adj);
     if (nadj <= 0) errorcall(call, "zero length \"adj\" specified");
     if (n < nadj) n = nadj;
     args = CDR(args);
+    /* Arg6b : padj= */
+    PROTECT(padj = coerceVector(CAR(args), REALSXP));
+    npadj = length(padj);
+    if (npadj <= 0) errorcall(call, "zero length \"padj\" specified");
+    if (n < npadj) n = npadj;
+    args = CDR(args);
     /* Arg7 : cex */
     PROTECT(cex = FixupCex(CAR(args), 1.0));
     ncex = length(cex);
     if (ncex <= 0) errorcall(call, "zero length \"cex\" specified");
     if (n < ncex) n = ncex;
     GMode(1, dd);
     for (i = 0; i < n; i++) {
 	double atval = REAL(at)[i%nat];
 	double adjval = REAL(adj)[i%nadj];
+	double padjval = REAL(padj)[i%npadj];
 	double cexval = REAL(cex)[i%ncex];
 	double lineval = REAL(line)[i%nline];
 	int outerval = INTEGER(outer)[i%nouter];
 	int sideval = INTEGER(side)[i%nside];
 	int fontval = INTEGER(font)[i%nfont];
 	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);
+	padjval = ComputePAdjValue(padjval, sideval, Rf_gpptr(dd)->las);
 	atval = ComputeAtValue(atval, Rf_gpptr(dd)->adj, sideval, Rf_gpptr(dd)->las,
 			       outerval, dd);
 	if (vectorFonts) {
 	    string = STRING_ELT(text, i%ntext);
 #ifdef GMV_implemented
 	    if(string != NA_STRING)
 		GMVText(CHAR(string),
 			INTEGER(vfont)[0], INTEGER(vfont)[1],
 			sideval, lineval, outerval, atval,
-			Rf_gpptr(dd)->las, dd);
+			Rf_gpptr(dd)->las, padjval, dd);
 #else
 	    warningcall(call,"Hershey fonts not yet implemented for mtext()");
 	    if(string != NA_STRING)
 		GMtext(CHAR(string), sideval, lineval, outerval, atval,
-		       Rf_gpptr(dd)->las, dd);
+		       Rf_gpptr(dd)->las, padjval, dd);
 #endif
+	}
 	else if (isExpression(text))
 	    GMMathText(VECTOR_ELT(text, i%ntext),
-		       sideval, lineval, outerval, atval, Rf_gpptr(dd)->las, dd);
+		       sideval, lineval, outerval, atval, Rf_gpptr(dd)->las,
+		       padjval, dd);
 	else {
 	    string = STRING_ELT(text, i%ntext);
 	    if(string != NA_STRING)
 		GMtext(CHAR(string), sideval, lineval, outerval, atval,
-		       Rf_gpptr(dd)->las, dd);
+		       Rf_gpptr(dd)->las, padjval, dd);
+	}
 	if (outerval == 0) dirtyplot = TRUE;
+    }
     GMode(0, dd);
     GRestorePars(dd);
     if (!dirtyplot) {
 	Rf_gpptr(dd)->new = gpnewsave;
 	Rf_dpptr(dd)->new = dpnewsave;
+    }
-    UNPROTECT(10);
+    UNPROTECT(11);
     /* NOTE: only record operation if no "error"  */
     if (GRecording(call))
 	recordGraphicOperation(op, originalArgs, dd);
     return R_NilValue;
 	    hpos = GConvertX(adj, NPC, USER, dd);
 	    where = 0;
+	}
 	if (isExpression(sub))
 	    GMMathText(VECTOR_ELT(sub, 0), 1, vpos, where,
-		       hpos, 0, dd);
+		       hpos, 0, 0.0, dd);
 	else {
 	    n = length(sub);
 	    for (i = 0; i < n; i++) {
 		string = STRING_ELT(sub, i);
 		if(string != NA_STRING)
-		    GMtext(CHAR(string), 1, vpos, where, hpos, 0, dd);
+		    GMtext(CHAR(string), 1, vpos, where, hpos, 0, 0.0, dd);
+	    }
+	}
+    }
     if (xlab != R_NilValue) {
 	cex = Rf_gpptr(dd)->cexlab;
 	    hpos = GConvertX(adj, NPC, USER, dd);
 	    where = 0;
+	}
 	if (isExpression(xlab))
 	    GMMathText(VECTOR_ELT(xlab, 0), 1, vpos, where,
-		       hpos, 0, dd);
+		       hpos, 0, 0.0, dd);
 	else {
 	    n = length(xlab);
 	    for (i = 0; i < n; i++) {
 		string = STRING_ELT(xlab, i);
 		if(string != NA_STRING)
-		    GMtext(CHAR(string), 1, vpos + i, where, hpos, 0, dd);
+		    GMtext(CHAR(string), 1, vpos + i, where, hpos, 0, 0.0, dd);
+	    }
+	}
+    }
     if (ylab != R_NilValue) {
 	cex = Rf_gpptr(dd)->cexlab;
 	    hpos = GConvertY(adj, NPC, USER, dd);
 	    where = 0;
+	}
 	if (isExpression(ylab))
 	    GMMathText(VECTOR_ELT(ylab, 0), 2, vpos, where,
-		       hpos, 0, dd);
+		       hpos, 0, 0.0, dd);
 	else {
 	    n = length(ylab);
 	    for (i = 0; i < n; i++) {
 		string = STRING_ELT(ylab, i);
 		if(string != NA_STRING)
-		    GMtext(CHAR(string), 2, vpos - i, where, hpos, 0, dd);
+		    GMtext(CHAR(string), 2, vpos - i, where, hpos, 0, 0.0, dd);
+	    }
+	}
+    }
     GMode(0, dd);
     GRestorePars(dd);
     /* NOTE: only record operation if no "error"  */
     if (GRecording(call))
 	recordGraphicOperation(op, originalArgs, dd);
     return R_NilValue;
-}
+}/* do_title */
 /*  abline(a, b, h, v, col, lty, lwd, ...)
     draw lines in intercept/slope form.	 */
     GRestorePars(dd);
     /* NOTE: only record operation if no "error"  */
     if (GRecording(call))
 	recordGraphicOperation(op, originalArgs, dd);
     return R_NilValue;
-}
+}/* do_title */
 SEXP do_box(SEXP call, SEXP op, SEXP args, SEXP env)
+{
 /*     box(which="plot", lty="solid", ...)
        --- which is coded, 1 = plot, 2 = figure, 3 = inner, 4 = outer.

The R Project SVN R

(root)/trunk/src/main/plot.c @ 28362 – Rev 30980 → 30998