From 644abe30fe63912c395d242a1f39f4e1443bda2a Mon Sep 17 00:00:00 2001 From: Neil Toronto Date: Fri, 7 Oct 2011 17:28:56 -0600 Subject: [PATCH] Reworked number formatting for plot labels --- collects/plot/common/contract.rkt | 29 ++--- collects/plot/common/draw.rkt | 10 +- collects/plot/common/format.rkt | 124 ++++++++++++++++++---- collects/plot/common/legend.rkt | 6 +- collects/plot/common/ticks.rkt | 2 +- collects/plot/plot2d/decoration.rkt | 4 +- collects/plot/scribblings/common.rkt | 11 +- collects/plot/scribblings/contracts.scrbl | 23 ++-- collects/plot/scribblings/utils.scrbl | 27 +++-- collects/plot/tests/plot2d-tests.rkt | 14 ++- collects/plot/utils.rkt | 7 +- 11 files changed, 182 insertions(+), 75 deletions(-) diff --git a/collects/plot/common/contract.rkt b/collects/plot/common/contract.rkt index b096959cd4..1118616b1a 100644 --- a/collects/plot/common/contract.rkt +++ b/collects/plot/common/contract.rkt @@ -22,9 +22,9 @@ 'left 'center 'right 'bottom-left 'bottom 'bottom-right)) -(defcontract rgb/c (list/c real? real? real?)) - -(defcontract color/c (or/c rgb/c string? symbol? (is-a?/c color%))) +(defcontract color/c (or/c (list/c real? real? real?) + string? symbol? + (is-a?/c color%))) (defcontract plot-color/c (or/c exact-integer? color/c)) @@ -61,14 +61,17 @@ (defcontract point-sym/c (or/c char? string? integer? (apply one-of/c known-point-symbols))) -(defcontract plot-color-function/c ((listof real?) . -> . (listof plot-color/c))) -(defcontract pen-width-function/c ((listof real?) . -> . (listof (real>=/c 0)))) -(defcontract plot-pen-style-function/c ((listof real?) . -> . (listof plot-pen-style/c))) -(defcontract plot-brush-style-function/c ((listof real?) . -> . (listof plot-brush-style/c))) -(defcontract alpha-function/c ((listof real?) . -> . (listof (real-in 0 1)))) +(defcontract plot-colors/c (or/c (listof plot-color/c) + ((listof real?) . -> . (listof plot-color/c)))) -(defcontract plot-colors/c (or/c (listof plot-color/c) plot-color-function/c)) -(defcontract pen-widths/c (or/c (listof (real>=/c 0)) pen-width-function/c)) -(defcontract plot-pen-styles/c (or/c (listof plot-pen-style/c) plot-pen-style-function/c)) -(defcontract plot-brush-styles/c (or/c (listof plot-brush-style/c) plot-brush-style-function/c)) -(defcontract alphas/c (or/c (listof (real-in 0 1)) alpha-function/c)) +(defcontract pen-widths/c (or/c (listof (real>=/c 0)) + ((listof real?) . -> . (listof (real>=/c 0))))) + +(defcontract plot-pen-styles/c (or/c (listof plot-pen-style/c) + ((listof real?) . -> . (listof plot-pen-style/c)))) + +(defcontract plot-brush-styles/c (or/c (listof plot-brush-style/c) + ((listof real?) . -> . (listof plot-brush-style/c)))) + +(defcontract alphas/c (or/c (listof (real-in 0 1)) + ((listof real?) . -> . (listof (real-in 0 1))))) diff --git a/collects/plot/common/draw.rkt b/collects/plot/common/draw.rkt index afe24f2f2c..a5ac814832 100644 --- a/collects/plot/common/draw.rkt +++ b/collects/plot/common/draw.rkt @@ -57,7 +57,7 @@ (define (color%? c) (is-a? c color%)) -(defproc (->color [c color/c]) rgb/c +(defproc (->color [c color/c]) (list/c real? real? real?) (match c [(? color%?) (list (send c red) (send c green) (send c blue))] [(? string?) (define color (send the-color-database find-color c)) @@ -81,7 +81,7 @@ (160 32 240) ; magenta (160 160 160))) ; gray -(defproc (->pen-color [c plot-color/c]) rgb/c +(defproc (->pen-color [c plot-color/c]) (list/c real? real? real?) (cond [(integer? c) (vector-ref pen-colors (remainder (abs c) 8))] [else (->color c)])) @@ -95,7 +95,7 @@ (240 224 255) ; magenta (212 212 212))) ; gray -(defproc (->brush-color [c plot-color/c]) rgb/c +(defproc (->brush-color [c plot-color/c]) (list/c real? real? real?) (cond [(integer? c) (vector-ref brush-colors (remainder (abs c) 8))] [else (->color c)])) @@ -126,7 +126,7 @@ (defproc (color-seq [c1 color/c] [c2 color/c] [num (integer>=/c 0)] [#:start? start? boolean? #t] - [#:end? end? boolean? #t]) (listof rgb/c) + [#:end? end? boolean? #t]) (listof (list/c real? real? real?)) (match-define (list r1 g1 b1) (->color c1)) (match-define (list r2 g2 b2) (->color c2)) (define rs (linear-seq r1 r2 num #:start? start? #:end? end?)) @@ -136,7 +136,7 @@ (defproc (color-seq* [colors (listof color/c)] [num (integer>=/c 0)] [#:start? start? boolean? #t] - [#:end? end? boolean? #t]) (listof rgb/c) + [#:end? end? boolean? #t]) (listof (list/c real? real? real?)) (when (empty? colors) (raise-type-error 'color-seq* "nonempty (listof plot-color/c)" colors)) (match-define (list (list rs gs bs) ...) (map ->color colors)) (let ([rs (linear-seq* rs num #:start? start? #:end? end?)] diff --git a/collects/plot/common/format.rkt b/collects/plot/common/format.rkt index c34b25fe7e..2687fa5ab9 100644 --- a/collects/plot/common/format.rkt +++ b/collects/plot/common/format.rkt @@ -2,34 +2,118 @@ ;; Functions to format numbers, and data structures containing numbers. -(require racket/string racket/list racket/pretty racket/contract +(require racket/string racket/list racket/pretty racket/contract racket/match "math.rkt" "contract.rkt" "contract-doc.rkt") -(provide (all-defined-out)) +(provide digits-for-range real->plot-label ->plot-label real->string/trunc) -;; Like real->decimal-string, but removes trailing zeros -(defproc (real->string/trunc [x real?] [e exact-nonnegative-integer?]) string? - (define str (real->decimal-string x e)) - (let loop ([x (string-length str)]) - (cond [(zero? x) "0"] - [(char=? #\0 (string-ref str (sub1 x))) (loop (sub1 x))] - [(char=? #\. (string-ref str (sub1 x))) (substring str 0 (sub1 x))] - [else (substring str 0 x)]))) +(define (remove-trailing-zeros str) + (let loop ([i (string-length str)]) + (cond [(zero? i) "0"] + [(char=? #\0 (string-ref str (sub1 i))) (loop (sub1 i))] + [(char=? #\. (string-ref str (sub1 i))) (substring str 0 (sub1 i))] + [else (substring str 0 i)]))) -;; Returns the number of digits needed to distinguish numbers [x-min..x-max] +;; Returns the number of fractional digits needed to distinguish numbers [x-min..x-max] (defproc (digits-for-range [x-min real?] [x-max real?] - [extra-digits exact-nonnegative-integer? 3]) exact-nonnegative-integer? + [extra-digits exact-integer? 3]) exact-integer? (define range (abs (- x-max x-min))) - (+ extra-digits (if (zero? range) 0 (max 0 (- (floor-log10 range)))))) + (+ extra-digits (if (zero? range) 0 (- (floor-log10 range))))) + +(define (int-str->e-str str) + (define n (string-length str)) + (cond [(or (= 0 n) (string=? str "0")) "0"] + [else + (define fst (substring str 0 1)) + (define rst (substring str 1 n)) + (format "~ae~a" (remove-trailing-zeros (format "~a.~a" fst rst)) (sub1 n))])) + +(begin + (require rackunit) + (check-equal? (int-str->e-str "") "0") + (check-equal? (int-str->e-str "0") "0") + (check-equal? (int-str->e-str "10") "1e1")) + +(define (frac-str->e-str str) + (define n (string-length str)) + (let loop ([i 0]) + (cond [(= i n) "0"] + [(char=? #\0 (string-ref str i)) (loop (add1 i))] + [else + (define fst (substring str i (add1 i))) + (define rst (substring str (add1 i) n)) + (cond [(= 0 (string-length rst)) (format "~ae~a" fst (- (add1 i)))] + [else (format "~a.~ae~a" fst rst (- (add1 i)))])]))) + +(begin + (require rackunit) + (check-equal? (frac-str->e-str "") "0") + (check-equal? (frac-str->e-str "0") "0") + (check-equal? (frac-str->e-str "00") "0") + (check-equal? (frac-str->e-str "1") "1e-1") + (check-equal? (frac-str->e-str "01") "1e-2")) + +(define (zero-string n) + (list->string (build-list n (λ _ #\0)))) + +(defproc (real->plot-label [x real?] [digits exact-integer?]) any + (cond + [(zero? x) "0"] + [else + (define front-sign (if (x . < . 0) "-" "")) + (define mid-sign (if (x . < . 0) "-" "+")) + (let* ([x (abs (inexact->exact x))]) + ;; Round away any extra digits + (define round-fac (expt 10 digits)) + (define y (/ (round (* x round-fac)) round-fac)) + ;; Parse the output of real->decimal-string + (define-values (int-str frac-str) + (match-let ([(list _ int-str frac-str) + (regexp-match #rx"(.*)\\.(.*)" (real->decimal-string y (max 0 digits)))]) + (values int-str (remove-trailing-zeros frac-str)))) + ;; Get scientific notation for the integer and fractional parts + (define int-e-str (int-str->e-str int-str)) + (define frac-e-str (frac-str->e-str frac-str)) + ;(printf "int-str = ~v, frac-str = ~v~n" int-str frac-str) + ;(printf "int-e-str = ~v, frac-e-str = ~v~n" int-e-str frac-e-str) + (define int-zero? (string=? int-str "0")) + (define frac-zero? (string=? frac-str "0")) + (define int-e-zero? (string=? int-e-str "0")) + (define frac-e-zero? (string=? frac-e-str "0")) + ;; Build a list of possible output strings + (define strs + (list (cond [(and int-zero? frac-zero?) "0"] + [int-zero? (format "~a.~a" front-sign frac-str)] + [frac-zero? (format "~a~a" front-sign int-str)] + [else (format "~a~a.~a" front-sign int-str frac-str)]) + (cond [(and int-e-zero? frac-zero?) "0"] + [int-e-zero? (format "~a.~a" front-sign frac-str)] + [frac-zero? (format "~a~a" front-sign int-e-str)] + [else (format "~a(~a)~a.~a" front-sign int-e-str mid-sign frac-str)]) + (cond [(and int-zero? frac-e-zero?) "0"] + [int-zero? (format "~a~a" front-sign frac-e-str)] + [frac-e-zero? (format "~a~a" front-sign int-str)] + [else (format "~a~a~a(~a)" front-sign int-str mid-sign frac-e-str)]) + (cond [(and int-e-zero? frac-e-zero?) "0"] + [int-e-zero? (format "~a~a" front-sign frac-e-str)] + [frac-e-zero? (format "~a~a" front-sign int-e-str)] + [else + (format "~a(~a)~a(~a)" front-sign int-e-str mid-sign frac-e-str)]))) + ;; Return the shortest possible output string + (argmin string-length strs))])) (defproc (->plot-label [a any/c] [digits exact-nonnegative-integer? 7]) string? (let loop ([a a]) - (cond [(string? a) a] - [(symbol? a) (symbol->string a)] - [(real? a) (real->string/trunc a digits)] - [(list? a) (string-append "(" (string-join (map loop a) " ") ")")] - [(cons? a) (string-append "(" (loop (car a)) " . " (loop (cdr a)) ")")] - [(boolean? a) (if a "true" "false")] - [(char? a) (list->string (list a))] + (cond [(string? a) a] + [(symbol? a) (symbol->string a)] + [(real? a) (real->plot-label a digits)] + [(list? a) (string-append "(" (string-join (map loop a) " ") ")")] + [(cons? a) (string-append "(" (loop (car a)) " . " (loop (cdr a)) ")")] + [(boolean? a) (if a "true" "false")] + [(char? a) (list->string (list a))] [else (pretty-format a)]))) + +;; Like real->decimal-string, but removes trailing zeros +(defproc (real->string/trunc [x real?] [e exact-integer?]) string? + (remove-trailing-zeros (real->decimal-string x (max 0 e)))) diff --git a/collects/plot/common/legend.rkt b/collects/plot/common/legend.rkt index 6d25cec69f..8cd796bc34 100644 --- a/collects/plot/common/legend.rkt +++ b/collects/plot/common/legend.rkt @@ -29,7 +29,7 @@ [color (in-cycle (maybe-apply/list colors zs))] [width (in-cycle (maybe-apply/list widths zs))] [style (in-cycle (maybe-apply/list styles zs))]) - (define entry-label (real->string/trunc z digits)) + (define entry-label (real->plot-label z digits)) (assoc-cons hash (list color width style) entry-label))) (reverse @@ -62,7 +62,7 @@ [line-color (in-cycle (maybe-apply/list line-colors zs))] [line-width (in-cycle (maybe-apply/list line-widths zs))] [line-style (in-cycle (maybe-apply/list line-styles zs))]) - (define entry-label (real->string/trunc z digits)) + (define entry-label (real->plot-label z digits)) (assoc-cons hash (list fill-color fill-style line-color line-width line-style) entry-label))) (reverse @@ -113,7 +113,7 @@ [line2-width (in-cycle (maybe-apply/list line2-widths zs))] [line2-style (in-cycle (maybe-apply/list line2-styles zs))]) (define entry-label - (format "[~a,~a]" (real->string/trunc za digits) (real->string/trunc zb digits))) + (format "[~a,~a]" (real->plot-label za digits) (real->plot-label zb digits))) (assoc-cons hash (list fill-color fill-style line-color line-width line-style line1-color line1-width line1-style diff --git a/collects/plot/common/ticks.rkt b/collects/plot/common/ticks.rkt index e8bb755367..c6d8b6634b 100644 --- a/collects/plot/common/ticks.rkt +++ b/collects/plot/common/ticks.rkt @@ -37,7 +37,7 @@ (define num (+ 1 (round (/ (- stop start) step)))) (define ps (linear-seq start stop num)) (define digits (digits-for-range x-min x-max)) - (define labels (map (λ (p) (real->string/trunc p digits)) ps)) + (define labels (map (λ (p) (real->plot-label p digits)) ps)) (define majors (tick-ps->majors ps major-skip)) (map tick ps labels majors))) diff --git a/collects/plot/plot2d/decoration.rkt b/collects/plot/plot2d/decoration.rkt index bd4bed449e..810c74552d 100644 --- a/collects/plot/plot2d/decoration.rkt +++ b/collects/plot/plot2d/decoration.rkt @@ -155,12 +155,12 @@ (define (format-x-coordinate x area) (define x-min (send area get-x-min)) (define x-max (send area get-x-max)) - (format "~a" (real->string/trunc x (digits-for-range x-min x-max)))) + (format "~a" (real->plot-label x (digits-for-range x-min x-max)))) (define (format-y-coordinate y area) (define y-min (send area get-y-min)) (define y-max (send area get-y-max)) - (format "~a" (real->string/trunc y (digits-for-range y-min y-max)))) + (format "~a" (real->plot-label y (digits-for-range y-min y-max)))) (define (format-coordinate v area) (match-define (vector x y) v) diff --git a/collects/plot/scribblings/common.rkt b/collects/plot/scribblings/common.rkt index beb357266b..f1e02a6725 100644 --- a/collects/plot/scribblings/common.rkt +++ b/collects/plot/scribblings/common.rkt @@ -25,9 +25,10 @@ (define plot-eval (let ([eval (make-base-eval)]) - (eval #'(require racket/math racket/match racket/list racket/draw racket/class - (rename-in (except-in plot plot plot3d) - [plot-bitmap plot] - [plot3d-bitmap plot3d]) - plot/utils)) + (eval '(begin + (require racket/math racket/match racket/list racket/draw racket/class + (rename-in (except-in plot plot plot3d) + [plot-bitmap plot] + [plot3d-bitmap plot3d]) + plot/utils))) eval)) diff --git a/collects/plot/scribblings/contracts.scrbl b/collects/plot/scribblings/contracts.scrbl index d922335d3c..c88e3c34c9 100644 --- a/collects/plot/scribblings/contracts.scrbl +++ b/collects/plot/scribblings/contracts.scrbl @@ -6,16 +6,15 @@ @title[#:tag "contracts"]{Plot Contracts} -@section[#:tag "contracts.convenience"]{Conveniences} +@section{Convenience Contracts} @doc-apply[real>=/c] @doc-apply[integer>=/c] @doc-apply[treeof] -@section[#:tag "contracts.drawing"]{Drawing Parameters} +@section{Appearance Argument Contracts} @doc-apply[anchor/c] -@doc-apply[rgb/c] @doc-apply[color/c] @doc-apply[plot-color/c] @doc-apply[pen-style/c] @@ -28,21 +27,19 @@ @defthing[known-point-symbols (listof symbol?)]{ A list containing the symbols that are valid @(racket points) labels. -@interaction[#:eval plot-eval known-point-symbols] +@interaction[#:eval plot-eval + (require (only-in srfi/13 string-pad-right)) + (for ([sym (in-list known-point-symbols)] + [n (in-cycle (in-range 3))]) + (display (string-pad-right (format "~v" sym) 22)) + (when (= n 2) (newline))) + (length known-point-symbols)] } -@section[#:tag "contracts.sequence"]{Color, Width and Style Sequences} +@section{Appearance Argument Sequence Contracts} @doc-apply[plot-colors/c] @doc-apply[plot-pen-styles/c] @doc-apply[pen-widths/c] @doc-apply[plot-brush-styles/c] @doc-apply[alphas/c] - -@section[#:tag "contracts.function"]{Color, Width and Style Functions} - -@doc-apply[plot-color-function/c] -@doc-apply[plot-pen-style-function/c] -@doc-apply[pen-width-function/c] -@doc-apply[plot-brush-style-function/c] -@doc-apply[alpha-function/c] diff --git a/collects/plot/scribblings/utils.scrbl b/collects/plot/scribblings/utils.scrbl index 3c2b92b847..1c8be6f783 100644 --- a/collects/plot/scribblings/utils.scrbl +++ b/collects/plot/scribblings/utils.scrbl @@ -14,19 +14,33 @@ Converts degrees to radians. Converts radians to degrees. } -@doc-apply[real->string/trunc]{ -Like @(racket real->decimal-string), but removes trailing zeros and a trailing decimal point. -Used to format numbers for plots. +@doc-apply[digits-for-range]{ +Given a range, returns the number of decimal places necessary to distinguish numbers in the range. This may return negative numbers for large ranges. + +@examples[#:eval plot-eval + (digits-for-range 0.01 0.02) + (digits-for-range 0 100000)] } -@doc-apply[digits-for-range]{ -Given a range, returns the number of decimal places necessary to distinguish numbers in the range. +@doc-apply[real->plot-label]{ +Converts a real number to a plot label. Used to format axis tick labels, @(racket point-label)s, and numbers in legend entries. + +@examples[#:eval plot-eval + (let ([d (digits-for-range 0.01 0.03)]) + (real->plot-label 0.02555555 d)) + (real->plot-label 2352343 -2) + (real->plot-label 1000000000. 4) + (real->plot-label 1000000000.1234 4)] } @doc-apply[->plot-label]{ Converts a Racket value to a label. Used by @(racket discrete-histogram) and @(racket discrete-histogram3d). } +@doc-apply[real->string/trunc]{ +Like @(racket real->decimal-string), but removes trailing zeros and a trailing decimal point. +} + @doc-apply[linear-seq]{ Returns a list of evenly spaced real numbers between @(racket start) and @(racket end). If @(racket start?) is @(racket #t), the list includes @(racket start). @@ -151,7 +165,8 @@ Integer brush styles repeat starting at @(racket 7). @examples[#:eval plot-eval (eq? (->brush-style 0) (->brush-style 7)) - (map ->brush-style '(0 1 2 3 4 5 6))] + (map ->brush-style '(0 1 2 3)) + (map ->brush-style '(4 5 6))] } @defstruct[invertible-function ([f (real? . -> . real?)] [finv (real? . -> . real?)])]{ diff --git a/collects/plot/tests/plot2d-tests.rkt b/collects/plot/tests/plot2d-tests.rkt index 62a0d655f9..14a6ee42a9 100644 --- a/collects/plot/tests/plot2d-tests.rkt +++ b/collects/plot/tests/plot2d-tests.rkt @@ -88,9 +88,13 @@ ;; an exact rational function and a floating-point function ;; the plot of the exact rational function's graph should be smooth (time - (plot (list (function (λ (x) (+ x 1)) #:label "Exact") - (function (λ (x) (+ x 1.0)) #:color 2 #:label "Inexact")) + (plot (list (function (λ (x) x) #:label "Exact") + (function (λ (x) (exact->inexact x)) #:color 2 #:label "Inexact")) #:x-min #e100000000000000.0 #:x-max #e100000000000000.1 + #:width 450)) + +(time + (plot (function cos 0 0.0000001) #:width 500)) (time @@ -248,19 +252,21 @@ (time (plot (list (tick-grid) (contour-intervals f1 -5 2 -5 2 + #:levels 5 #:contour-styles '(transparent) #:label "") - (contours f1 -2 5 -2 5 #:label "")) + (contours f1 -2 5 -2 5 #:levels 5 #:label "")) #:x-min -5 #:x-max 5 #:y-min -5 #:y-max 5 #:legend-anchor 'center)) (time (plot (list (tick-grid) (contour-intervals f1 -5 2 -5 2 + #:levels '(0.25 0.5 0.75 1.0 1.25 1.5 1.75) #:colors default-contour-colors #:styles '(0 1 2 3 4 5 6) #:contour-styles '(transparent) #:label "z") - (contours f1 -2 5 -2 5)) + (contours f1 -2 5 -2 5 #:levels '(0.25 0.5 0.75 1.0 1.25 1.5 1.75))) #:x-min -5 #:x-max 5 #:y-min -5 #:y-max 5 #:legend-anchor 'top-left)) diff --git a/collects/plot/utils.rkt b/collects/plot/utils.rkt index 0c1d2758e8..53ea146643 100644 --- a/collects/plot/utils.rkt +++ b/collects/plot/utils.rkt @@ -7,9 +7,10 @@ radians->degrees) (require "common/format.rkt") -(provide real->string/trunc - digits-for-range - ->plot-label) +(provide digits-for-range + real->plot-label + ->plot-label + real->string/trunc) (require "common/draw.rkt") (provide color-seq color-seq*