FastR Grid: implement L_pretty

com.oracle.truffle.r.library/src/com/oracle/truffle/r/library/fastrGrid/FastRGridExternalLookup.java

@@ -89,6 +89,8 @@ public final class FastRGridExternalLookup {
                 return LConvert.create();
             case "L_validUnits":
                 return LValidUnit.create();
+            case "L_pretty":
+                return LPretty.create();
 
             // Viewport management
             case "L_upviewport":

com.oracle.truffle.r.library/src/com/oracle/truffle/r/library/fastrGrid/LPretty.java

+/*
+ * This material is distributed under the GNU General Public License
+ * Version 2. You may review the terms of this license at
+ * http://www.gnu.org/licenses/gpl-2.0.html
+ *
+ * Copyright (C) 2001-3 Paul Murrell
+ * Copyright (c) 1998-2013, The R Core Team
+ * Copyright (c) 2017, Oracle and/or its affiliates
+ *
+ * All rights reserved.
+ */
+package com.oracle.truffle.r.library.fastrGrid;
+
+import static com.oracle.truffle.r.nodes.builtin.CastBuilder.Predef.numericValue;
+import static com.oracle.truffle.r.runtime.nmath.TOMS708.fabs;
+
+import com.oracle.truffle.api.dsl.Specialization;
+import com.oracle.truffle.r.nodes.builtin.RExternalBuiltinNode;
+import com.oracle.truffle.r.runtime.PrettyIntevals;
+import com.oracle.truffle.r.runtime.RError.Message;
+import com.oracle.truffle.r.runtime.data.RDataFactory;
+import com.oracle.truffle.r.runtime.data.model.RAbstractDoubleVector;
+
+public abstract class LPretty extends RExternalBuiltinNode.Arg1 {
+    static {
+        Casts casts = new Casts(LPretty.class);
+        casts.arg(0).mustBe(numericValue()).asDoubleVector();
+    }
+
+    public static LPretty create() {
+        return LPrettyNodeGen.create();
+    }
+
+    @Specialization
+    protected Object doPretty(RAbstractDoubleVector scale) {
+        double min = scale.getLength() > 0 ? scale.getDataAt(0) : 0;
+        double max = scale.getLength() > 1 ? scale.getDataAt(1) : 0;
+        boolean swap = max < min;
+        if (swap) {
+            min = max;
+            max = scale.getDataAt(0);
+        }
+
+        if (Double.isInfinite(min) || Double.isInfinite(max)) {
+            throw error(Message.GENERIC, String.format("infinite axis extents [GEPretty(%g,%g,5)]", min, max));
+        }
+
+        double[] ns = new double[]{min};
+        double[] nu = new double[]{max};
+        int[] ndiv = new int[]{5};
+        double unit = PrettyIntevals.pretty(getErrorContext(), ns, nu, new int[]{5}, 1, 0.25, new double[]{.8, 1.7}, 2, false);
+
+        if (nu[0] >= ns[0] + 1) {
+            if (ns[0] * unit < min - 1e-7 * unit) {
+                ns[0]++;
+            }
+            if (nu[0] > ns[0] + 1 && nu[0] * unit > max + 1e-7 * unit) {
+                nu[0]--;
+            }
+            ndiv[0] = (int) (nu[0] - ns[0]);
+        }
+        min = ns[0] * unit;
+        max = nu[0] * unit;
+
+        if (swap) {
+            double temp = min;
+            min = max;
+            max = temp;
+        }
+        return createAtVector(min, max, ndiv[0]);
+    }
+
+    private static RAbstractDoubleVector createAtVector(double axp0, double axp1, double axp2) {
+        /*
+         * Create an 'at = ...' vector for axis(.) i.e., the vector of tick mark locations, when
+         * none has been specified (= default).
+         *
+         * axp[0:2] = (x1, x2, nInt), where x1..x2 are the extreme tick marks {unless in log case,
+         * where nInt \in {1,2,3 ; -1,-2,....} and the `nint' argument is used *instead*.} The
+         * resulting REAL vector must have length >= 1, ideally >= 2
+         *
+         * FastR Notes: we only implement case where logflag == false.
+         */
+        /* --- linear axis --- Only use axp[] arg. */
+        int n = (int) (fabs(axp2) + 0.25); /* >= 0 */
+        int dn = Math.max(1, n);
+        double rng = axp1 - axp0;
+        double small = fabs(rng) / (100. * dn);
+        double[] at = new double[n + 1];
+        for (int i = 0; i <= n; i++) {
+            at[i] = axp0 + ((double) i / dn) * rng;
+            if (fabs(at[i]) < small) {
+                at[i] = 0;
+            }
+        }
+        return RDataFactory.createDoubleVector(at, RDataFactory.COMPLETE_VECTOR);
+    }
+}

com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/Pretty.java

@@ -22,6 +22,7 @@ import static com.oracle.truffle.r.runtime.builtins.RBuiltinKind.INTERNAL;
 
 import com.oracle.truffle.api.dsl.Specialization;
 import com.oracle.truffle.r.nodes.builtin.RBuiltinNode;
+import com.oracle.truffle.r.runtime.PrettyIntevals;
 import com.oracle.truffle.r.runtime.RError;
 import com.oracle.truffle.r.runtime.RRuntime;
 import com.oracle.truffle.r.runtime.builtins.RBuiltin;
@@ -46,6 +47,8 @@ public abstract class Pretty extends RBuiltinNode {
         casts.arg("eps.correct").defaultError(RError.Message.GENERIC, "'eps.correct' must be 0, 1, or 2").asIntegerVector().findFirst().mustNotBeNA().mustBe(and(gte0(), lte(2)));
     }
 
+    public abstract RList execute(double l, double u, int n, int minN, double shrinkSml, RAbstractDoubleVector hi, int epsCorrect);
+
     @Specialization
     protected RList pretty(double l, double u, int n, int minN, double shrinkSml, RAbstractDoubleVector hi, int epsCorrect) {
         double hi0 = hi.getDataAt(0);
@@ -60,151 +63,11 @@ public abstract class Pretty extends RBuiltinNode {
         double[] lo = new double[]{l};
         double[] up = new double[]{u};
         int[] ndiv = new int[]{n};
-        rPretty(lo, up, ndiv, minN, shrinkSml, hi.materialize().getDataWithoutCopying(), epsCorrect, true);
+        PrettyIntevals.pretty(getErrorContext(), lo, up, ndiv, minN, shrinkSml, hi.materialize().getDataWithoutCopying(), epsCorrect, true);
         Object[] data = new Object[3];
         data[0] = lo[0];
         data[1] = up[0];
         data[2] = ndiv[0];
         return RDataFactory.createList(data, NAMES);
     }
-
-    double rPretty(double[] lo, double[] up, int[] ndiv, int minN,
-                    double shrinkSml, double[] highUFact,
-                    int epsCorrection, boolean returnBounds) {
-        /*
-         * From version 0.65 on, we had rounding_eps := 1e-5, before, r..eps = 0 1e-7 is consistent
-         * with seq.default()
-         */
-        double roundingEps = 1e-7;
-
-        double h = highUFact[0];
-        double h5 = highUFact[1];
-
-        double dx;
-        double cell;
-        double unit;
-        double base;
-        double uu;
-        double ns;
-        double nu;
-        int k;
-        boolean iSmall;
-
-        dx = up[0] - lo[0];
-        /* cell := "scale" here */
-        if (dx == 0 && up[0] == 0) { /* up == lo == 0 */
-            cell = 1;
-            iSmall = true;
-        } else {
-            cell = Math.max(Math.abs(lo[0]), Math.abs(up[0]));
-            /* uu = upper bound on cell/unit */
-            // uu = (1 + (h5 >= 1.5 * h + .5)) ? 1 / (1 + h) : 1.5 / (1 + h5);
-            // How can above expression ever be zero?
-            uu = 1 / (1 + h);
-            /* added times 3, as several calculations here */
-            iSmall = dx < cell * uu * Math.max(1, ndiv[0]) * RRuntime.EPSILON * 3;
-        }
-
-        /* OLD: cell = FLT_EPSILON+ dx / ndiv[0]; FLT_EPSILON = 1.192e-07 */
-        if (iSmall) {
-            if (cell > 10) {
-                cell = 9 + cell / 10;
-            }
-            cell *= shrinkSml;
-            if (minN > 1) {
-                cell /= minN;
-            }
-        } else {
-            cell = dx;
-            if (ndiv[0] > 1) {
-                cell /= ndiv[0];
-            }
-        }
-
-        if (cell < 20 * Double.MIN_VALUE) {
-            warning(RError.Message.GENERIC, "Internal(pretty()): very small range.. corrected");
-            cell = 20 * Double.MIN_VALUE;
-        } else if (cell * 10 > Double.MAX_VALUE) {
-            warning(RError.Message.GENERIC, "Internal(pretty()): very large range.. corrected");
-            cell = .1 * Double.MAX_VALUE;
-        }
-        /*
-         * NB: the power can be negative and this relies on exact calculation, which glibc's exp10
-         * does not achieve
-         */
-        base = Math.pow(10.0, Math.floor(Math.log10(cell))); /* base <= cell < 10*base */
-
-        /*
-         * unit : from { 1,2,5,10 } * base such that |u - cell| is small, favoring larger (if h > 1,
-         * else smaller) u values; favor '5' more than '2' if h5 > h (default h5 = .5 + 1.5 h)
-         */
-        unit = base;
-        if ((uu = 2 * base) - cell < h * (cell - unit)) {
-            unit = uu;
-            if ((uu = 5 * base) - cell < h5 * (cell - unit)) {
-                unit = uu;
-                if ((uu = 10 * base) - cell < h * (cell - unit)) {
-                    unit = uu;
-                }
-            }
-        }
-        /*
-         * Result: c := cell, u := unit, b := base c in [ 1, (2+ h) /(1+h) ] b ==> u= b c in ( (2+
-         * h)/(1+h), (5+2h5)/(1+h5)] b ==> u= 2b c in ( (5+2h)/(1+h), (10+5h) /(1+h) ] b ==> u= 5b c
-         * in ((10+5h)/(1+h), 10 ) b ==> u=10b
-         *
-         * ===> 2/5 *(2+h)/(1+h) <= c/u <= (2+h)/(1+h)
-         */
-
-        ns = Math.floor(lo[0] / unit + roundingEps);
-        nu = Math.ceil(up[0] / unit - roundingEps);
-        if (epsCorrection != 0 && (epsCorrection > 1 || !iSmall)) {
-            if (lo[0] != 0.) {
-                lo[0] *= (1 - RRuntime.EPSILON);
-            } else {
-                lo[0] = -Double.MIN_VALUE;
-            }
-            if (up[0] != 0.) {
-                up[0] *= (1 + RRuntime.EPSILON);
-            } else {
-                up[0] = +Double.MIN_VALUE;
-            }
-        }
-
-        while (ns * unit > lo[0] + roundingEps * unit) {
-            ns--;
-        }
-
-        while (nu * unit < up[0] - roundingEps * unit) {
-            nu++;
-        }
-
-        k = (int) (0.5 + nu - ns);
-        if (k < minN) {
-            /* ensure that nu - ns == min_n */
-            k = minN - k;
-            if (ns >= 0.) {
-                nu += k / 2;
-                ns -= k / 2 + k % 2; /* ==> nu-ns = old(nu-ns) + min_n -k = min_n */
-            } else {
-                ns -= k / 2;
-                nu += k / 2 + k % 2;
-            }
-            ndiv[0] = minN;
-        } else {
-            ndiv[0] = k;
-        }
-        if (returnBounds) { /* if()'s to ensure that result covers original range */
-            if (ns * unit < lo[0]) {
-                lo[0] = ns * unit;
-            }
-            if (nu * unit > up[0]) {
-                up[0] = nu * unit;
-            }
-        } else {
-            lo[0] = ns;
-            up[0] = nu;
-        }
-        return unit;
-    }
 }

com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/PrettyIntevals.java

+/*
+ * This material is distributed under the GNU General Public License
+ * Version 2. You may review the terms of this license at
+ * http://www.gnu.org/licenses/gpl-2.0.html
+ *
+ * Copyright (c) 1995, 1996  Robert Gentleman and Ross Ihaka
+ * Copyright (c) 1997-2014,  The R Core Team
+ * Copyright (c) 2016, 2017, Oracle and/or its affiliates
+ *
+ * All rights reserved.
+ */
+package com.oracle.truffle.r.runtime;
+
+import com.oracle.truffle.r.runtime.nodes.RBaseNode;
+
+/**
+ * Constructs m "pretty" values which cover the given interval. This code is used in both built-in
+ * {@code pretty} and the grid package.
+ */
+public final class PrettyIntevals {
+    private PrettyIntevals() {
+        // only static members
+    }
+
+    // transcribed from pretty.c
+
+    public static double pretty(RBaseNode errorCtx, double[] lo, double[] up, int[] ndiv, int minN,
+                    double shrinkSml, double[] highUFact,
+                    int epsCorrection, boolean returnBounds) {
+        /*
+         * From version 0.65 on, we had rounding_eps := 1e-5, before, r..eps = 0 1e-7 is consistent
+         * with seq.default()
+         */
+        double roundingEps = 1e-7;
+
+        double h = highUFact[0];
+        double h5 = highUFact[1];
+
+        double dx;
+        double cell;
+        double unit;
+        double base;
+        double uu;
+        double ns;
+        double nu;
+        int k;
+        boolean iSmall;
+
+        dx = up[0] - lo[0];
+        /* cell := "scale" here */
+        if (dx == 0 && up[0] == 0) { /* up == lo == 0 */
+            cell = 1;
+            iSmall = true;
+        } else {
+            cell = Math.max(Math.abs(lo[0]), Math.abs(up[0]));
+            /* uu = upper bound on cell/unit */
+            // uu = (1 + (h5 >= 1.5 * h + .5)) ? 1 / (1 + h) : 1.5 / (1 + h5);
+            // How can above expression ever be zero?
+            uu = 1 / (1 + h);
+            /* added times 3, as several calculations here */
+            iSmall = dx < cell * uu * Math.max(1, ndiv[0]) * RRuntime.EPSILON * 3;
+        }
+
+        /* OLD: cell = FLT_EPSILON+ dx / ndiv[0]; FLT_EPSILON = 1.192e-07 */
+        if (iSmall) {
+            if (cell > 10) {
+                cell = 9 + cell / 10;
+            }
+            cell *= shrinkSml;
+            if (minN > 1) {
+                cell /= minN;
+            }
+        } else {
+            cell = dx;
+            if (ndiv[0] > 1) {
+                cell /= ndiv[0];
+            }
+        }
+
+        if (cell < 20 * Double.MIN_VALUE) {
+            RError.warning(errorCtx, RError.Message.GENERIC, "Internal(pretty()): very small range.. corrected");
+            cell = 20 * Double.MIN_VALUE;
+        } else if (cell * 10 > Double.MAX_VALUE) {
+            RError.warning(errorCtx, RError.Message.GENERIC, "Internal(pretty()): very large range.. corrected");
+            cell = .1 * Double.MAX_VALUE;
+        }
+        /*
+         * NB: the power can be negative and this relies on exact calculation, which glibc's exp10
+         * does not achieve
+         */
+        base = Math.pow(10.0, Math.floor(Math.log10(cell))); /* base <= cell < 10*base */
+
+        /*
+         * unit : from { 1,2,5,10 } * base such that |u - cell| is small, favoring larger (if h > 1,
+         * else smaller) u values; favor '5' more than '2' if h5 > h (default h5 = .5 + 1.5 h)
+         */
+        unit = base;
+        if ((uu = 2 * base) - cell < h * (cell - unit)) {
+            unit = uu;
+            if ((uu = 5 * base) - cell < h5 * (cell - unit)) {
+                unit = uu;
+                if ((uu = 10 * base) - cell < h * (cell - unit)) {
+                    unit = uu;
+                }
+            }
+        }
+        /*
+         * Result: c := cell, u := unit, b := base c in [ 1, (2+ h) /(1+h) ] b ==> u= b c in ( (2+
+         * h)/(1+h), (5+2h5)/(1+h5)] b ==> u= 2b c in ( (5+2h)/(1+h), (10+5h) /(1+h) ] b ==> u= 5b c
+         * in ((10+5h)/(1+h), 10 ) b ==> u=10b
+         *
+         * ===> 2/5 *(2+h)/(1+h) <= c/u <= (2+h)/(1+h)
+         */
+
+        ns = Math.floor(lo[0] / unit + roundingEps);
+        nu = Math.ceil(up[0] / unit - roundingEps);
+        if (epsCorrection != 0 && (epsCorrection > 1 || !iSmall)) {
+            if (lo[0] != 0.) {
+                lo[0] *= (1 - RRuntime.EPSILON);
+            } else {
+                lo[0] = -Double.MIN_VALUE;
+            }
+            if (up[0] != 0.) {
+                up[0] *= (1 + RRuntime.EPSILON);
+            } else {
+                up[0] = +Double.MIN_VALUE;
+            }
+        }
+
+        while (ns * unit > lo[0] + roundingEps * unit) {
+            ns--;
+        }
+
+        while (nu * unit < up[0] - roundingEps * unit) {
+            nu++;
+        }
+
+        k = (int) (0.5 + nu - ns);
+        if (k < minN) {
+            /* ensure that nu - ns == min_n */
+            k = minN - k;
+            if (ns >= 0.) {
+                nu += k / 2;
+                ns -= k / 2 + k % 2; /* ==> nu-ns = old(nu-ns) + min_n -k = min_n */
+            } else {
+                ns -= k / 2;
+                nu += k / 2 + k % 2;
+            }
+            ndiv[0] = minN;
+        } else {
+            ndiv[0] = k;
+        }
+        if (returnBounds) { /* if()'s to ensure that result covers original range */
+            if (ns * unit < lo[0]) {
+                lo[0] = ns * unit;
+            }
+            if (nu * unit > up[0]) {
+                up[0] = nu * unit;
+            }
+        } else {
+            lo[0] = ns;
+            up[0] = nu;
+        }
+        return unit;
+    }
+}

mx.fastr/copyrights/overrides

@@ -185,6 +185,7 @@ com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/L
 com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/Merge.java,gnu_r_gentleman_ihaka2.copyright
 com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/Order.java,gnu_r_gentleman_ihaka.copyright
 com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/Pretty.java,gnu_r_gentleman_ihaka2.copyright
+com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/PrettyIntevals.java,gnu_r_gentleman_ihaka2.copyright
 com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/Quit.java,gnu_r_gentleman_ihaka.copyright
 com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/Rank.java,gnu_r_gentleman_ihaka.copyright
 com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/Prod.java,purdue.copyright
@@ -744,6 +745,7 @@ com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/p
 com.oracle.truffle.r.library/src/com/oracle/truffle/r/library/stats/deriv/Deriv.java,gnu_r_gentleman_ihaka2.copyright
 com.oracle.truffle.r.library/src/com/oracle/truffle/r/library/stats/deriv/DerivVisitor.java,gnu_r_gentleman_ihaka2.copyright
 com.oracle.truffle.r.library/src/com/oracle/truffle/r/library/fastrGrid/LRect.java,gnu_r_murrel_core.copyright
+com.oracle.truffle.r.library/src/com/oracle/truffle/r/library/fastrGrid/LPretty.java,gnu_r_murrel_core.copyright
 com.oracle.truffle.r.library/src/com/oracle/truffle/r/library/fastrGrid/LRectBounds.java,gnu_r_murrel_core.copyright
 com.oracle.truffle.r.library/src/com/oracle/truffle/r/library/fastrGrid/LCircleBounds.java,gnu_r_murrel_core.copyright
 com.oracle.truffle.r.library/src/com/oracle/truffle/r/library/fastrGrid/LLocnBounds.java,gnu_r_murrel_core.copyright