diff --git a/collects/plot/common/area.rkt b/collects/plot/common/area.rkt index ae9338fd00..ab8afa4564 100644 --- a/collects/plot/common/area.rkt +++ b/collects/plot/common/area.rkt @@ -14,6 +14,7 @@ "contract.rkt" "draw.rkt" "math.rkt" + "vector.rkt" "parameters.rkt") (provide plot-area% (struct-out legend-entry)) @@ -250,105 +251,118 @@ (send dc set-alpha old-alpha)) (define/public (draw-point v) - (match-define (vector x y) v) - (send dc draw-point x y)) + (when (vregular? v) + (match-define (vector x y) v) + (send dc draw-point x y))) (define/public (draw-polygon vs [fill-style 'winding]) - (send dc draw-polygon (map coord->cons vs) 0 0 fill-style)) + (when (andmap vregular? vs) + (send dc draw-polygon (map coord->cons vs) 0 0 fill-style))) (define/public (draw-rectangle v1 v2) - (match-define (vector x1 y1) v1) - (match-define (vector x2 y2) v2) - (draw-polygon - (list (vector x1 y1) (vector x1 y2) (vector x2 y2) (vector x2 y1)))) + (when (and (vregular? v1) (vregular? v2)) + (match-define (vector x1 y1) v1) + (match-define (vector x2 y2) v2) + (draw-polygon + (list (vector x1 y1) (vector x1 y2) (vector x2 y2) (vector x2 y1))))) (define/public (draw-lines vs) - (send dc draw-lines (map coord->cons vs))) + (when (andmap vregular? vs) + (send dc draw-lines (map coord->cons vs)))) (define/public (draw-line v1 v2) - (match-define (vector x1 y1) v1) - (match-define (vector x2 y2) v2) - (send dc draw-line x1 y1 x2 y2)) + (when (and (vregular? v1) (vregular? v2)) + (match-define (vector x1 y1) v1) + (match-define (vector x2 y2) v2) + (send dc draw-line x1 y1 x2 y2))) (define/public (draw-text str v [anchor 'top-left] [angle 0] #:outline? [outline? #f]) - (match-define (vector x y) v) - - (when outline? - (define alpha (send dc get-alpha)) - (define fg (send dc get-text-foreground)) + (when (vregular? v) + (match-define (vector x y) v) - (send dc set-alpha (alpha-expt alpha 1/8)) - (send dc set-text-foreground (send dc get-background)) - (for* ([dx (list -1 0 1)] - [dy (list -1 0 1)] - #:when (not (and (zero? dx) (zero? dy)))) - (draw-text/anchor dc str (+ x dx) (+ y dy) anchor #t 0 angle)) - (send dc set-alpha alpha) - (send dc set-text-foreground fg)) - - (draw-text/anchor dc str x y anchor #t 0 angle)) + (when outline? + (define alpha (send dc get-alpha)) + (define fg (send dc get-text-foreground)) + + (send dc set-alpha (alpha-expt alpha 1/8)) + (send dc set-text-foreground (send dc get-background)) + (for* ([dx (list -1 0 1)] + [dy (list -1 0 1)] + #:when (not (and (zero? dx) (zero? dy)))) + (draw-text/anchor dc str (+ x dx) (+ y dy) anchor #t 0 angle)) + (send dc set-alpha alpha) + (send dc set-text-foreground fg)) + + (draw-text/anchor dc str x y anchor #t 0 angle))) (define/public (get-text-corners str v [anchor 'top-left] [angle 0]) - (match-define (vector x y) v) - (get-text-corners/anchor dc str x y anchor #t 0 angle)) + (when (vregular? v) + (match-define (vector x y) v) + (get-text-corners/anchor dc str x y anchor #t 0 angle))) (define/public (draw-arrow v1 v2) - (match-define (vector x1 y1) v1) - (match-define (vector x2 y2) v2) - (define dx (- x2 x1)) - (define dy (- y2 y1)) - (define angle (if (and (zero? dy) (zero? dx)) 0 (atan dy dx))) - (define dist (sqrt (+ (sqr dx) (sqr dy)))) - (define head-r (* 2/5 dist)) - (define head-angle (* 1/6 pi)) - (define dx1 (* (cos (+ angle head-angle)) head-r)) - (define dy1 (* (sin (+ angle head-angle)) head-r)) - (define dx2 (* (cos (- angle head-angle)) head-r)) - (define dy2 (* (sin (- angle head-angle)) head-r)) - (send dc draw-line x1 y1 x2 y2) - (send dc draw-line x2 y2 (- x2 dx1) (- y2 dy1)) - (send dc draw-line x2 y2 (- x2 dx2) (- y2 dy2))) + (when (and (vregular? v1) (vregular? v2)) + (match-define (vector x1 y1) v1) + (match-define (vector x2 y2) v2) + (define dx (- x2 x1)) + (define dy (- y2 y1)) + (define angle (if (and (zero? dy) (zero? dx)) 0 (atan dy dx))) + (define dist (sqrt (+ (sqr dx) (sqr dy)))) + (define head-r (* 2/5 dist)) + (define head-angle (* 1/6 pi)) + (define dx1 (* (cos (+ angle head-angle)) head-r)) + (define dy1 (* (sin (+ angle head-angle)) head-r)) + (define dx2 (* (cos (- angle head-angle)) head-r)) + (define dy2 (* (sin (- angle head-angle)) head-r)) + (send dc draw-line x1 y1 x2 y2) + (send dc draw-line x2 y2 (- x2 dx1) (- y2 dy1)) + (send dc draw-line x2 y2 (- x2 dx2) (- y2 dy2)))) ;; ----------------------------------------------------------------------------------------------- ;; Glyph (point sym) primitives (define/public ((make-draw-circle-glyph r) v) - (match-define (vector x y) v) - (send dc draw-ellipse (- x r -1/2) (- y r -1/2) (* 2 r) (* 2 r))) + (when (vregular? v) + (match-define (vector x y) v) + (send dc draw-ellipse (- x r -1/2) (- y r -1/2) (* 2 r) (* 2 r)))) (define/public (make-draw-polygon-glyph r sides start-angle) (define angles (linear-seq start-angle (+ start-angle (* 2 pi)) (+ 1 sides))) (λ (v) - (match-define (vector x y) v) - (send dc draw-polygon (map (λ (a) (cons (+ x (* (cos a) r)) (+ y (* (sin a) r)))) - angles)))) + (when (vregular? v) + (match-define (vector x y) v) + (send dc draw-polygon (map (λ (a) (cons (+ x (* (cos a) r)) (+ y (* (sin a) r)))) + angles))))) (define/public (make-draw-star-glyph r sides start-angle) (define angles (linear-seq start-angle (+ start-angle (* 2 pi)) (+ 1 (* 2 sides)))) (λ (v) - (match-define (vector x y) v) - (define pts - (for/list ([a (in-list angles)] [i (in-naturals)]) - (define r-cos-a (* r (cos a))) - (define r-sin-a (* r (sin a))) - (cond [(odd? i) (cons (+ x r-cos-a) (+ y r-sin-a))] - [else (cons (+ x (* 1/2 r-cos-a)) (+ y (* 1/2 r-sin-a)))]))) - (send dc draw-polygon pts))) + (when (vregular? v) + (match-define (vector x y) v) + (define pts + (for/list ([a (in-list angles)] [i (in-naturals)]) + (define r-cos-a (* r (cos a))) + (define r-sin-a (* r (sin a))) + (cond [(odd? i) (cons (+ x r-cos-a) (+ y r-sin-a))] + [else (cons (+ x (* 1/2 r-cos-a)) (+ y (* 1/2 r-sin-a)))]))) + (send dc draw-polygon pts)))) (define/public (make-draw-flare-glyph r sticks start-angle) (define step (/ (* 2 pi) sticks)) (define angles (build-list sticks (λ (n) (+ start-angle (* n step))))) (λ (v) - (match-define (vector x y) v) - (for ([a (in-list angles)]) - (send dc draw-line x y (+ x (* (cos a) r)) (+ y (* (sin a) r)))))) + (when (vregular? v) + (match-define (vector x y) v) + (for ([a (in-list angles)]) + (send dc draw-line x y (+ x (* (cos a) r)) (+ y (* (sin a) r))))))) (define/public (make-draw-tick r angle) (define dx (* (cos angle) r)) (define dy (* (sin angle) r)) (λ (v) - (match-define (vector x y) v) - (send dc draw-line (- x dx) (- y dy) (+ x dx) (+ y dy)))) + (when (vregular? v) + (match-define (vector x y) v) + (send dc draw-line (- x dx) (- y dy) (+ x dx) (+ y dy))))) (define/public (draw-tick v r angle) ((make-draw-tick r angle) v)) @@ -363,14 +377,15 @@ (define dx2 (* (cos (- angle head-angle)) head-r)) (define dy2 (* (sin (- angle head-angle)) head-r)) (λ (v) - (match-define (vector x y) v) - (define head-x (+ x dx)) - (define head-y (+ y dy)) - (define tail-x (- x dx)) - (define tail-y (- y dy)) - (send dc draw-line head-x head-y tail-x tail-y) - (send dc draw-line head-x head-y (- head-x dx1) (- head-y dy1)) - (send dc draw-line head-x head-y (- head-x dx2) (- head-y dy2)))) + (when (vregular? v) + (match-define (vector x y) v) + (define head-x (+ x dx)) + (define head-y (+ y dy)) + (define tail-x (- x dx)) + (define tail-y (- y dy)) + (send dc draw-line head-x head-y tail-x tail-y) + (send dc draw-line head-x head-y (- head-x dx1) (- head-y dy1)) + (send dc draw-line head-x head-y (- head-x dx2) (- head-y dy2))))) (define/public (draw-arrow-glyph v r angle) ((make-draw-arrow-glyph r angle) v)) @@ -380,8 +395,9 @@ (define dx (* 1/2 x-size)) (define dy (* 1/2 y-size)) (λ (v) - (match-define (vector x y) v) - (send dc draw-text str (- x dx) (- y dy) #t))) + (when (vregular? v) + (match-define (vector x y) v) + (send dc draw-text str (- x dx) (- y dy) #t)))) (define ((mix-draw-glyph d1 d2) v) (d1 v) diff --git a/collects/plot/common/axis-transform.rkt b/collects/plot/common/axis-transform.rkt index 6959cca583..b26f9cda51 100644 --- a/collects/plot/common/axis-transform.rkt +++ b/collects/plot/common/axis-transform.rkt @@ -5,29 +5,70 @@ "contract.rkt" "contract-doc.rkt") (provide (struct-out invertible-function) - make-axis-transform + id-function + axis-transform/c id-transform + apply-transform + make-axis-transform + axis-transform-compose log-transform cbrt-transform - hand-drawn-transform) + hand-drawn-transform + stretch-transform + collapse-transform) (define-struct/contract invertible-function ([f (real? . -> . real?)] [finv (real? . -> . real?)]) #:transparent) +(define (invertible-compose f1 f2) + (match-let ([(invertible-function f1 g1) f1] + [(invertible-function f2 g2) f2]) + (invertible-function (compose f1 f2) (compose g2 g1)))) + +(define axis-transform/c (real? real? invertible-function? . -> . invertible-function?)) + +(defproc (id-transform [x-min real?] [x-max real?] [old-function invertible-function?] + ) invertible-function? + old-function) + +(define id-function (invertible-function (λ (x) x) (λ (x) x))) + +(defproc (apply-transform [t axis-transform/c] [x-min real?] [x-max real?]) invertible-function? + (t x-min x-max id-function)) + ;; Turns any total, surjective, monotone flonum op and its inverse into an axis transform -(define ((make-axis-transform flop flinv) x-min x-max) - (let ([x-min (exact->inexact x-min)] - [x-max (exact->inexact x-max)]) - (define fx-min (flop x-min)) - (define fx-scale (fl/ (fl- x-max x-min) - (fl- (flop x-max) fx-min))) - (define (f x) - (fl+ x-min (fl* (fl- (flop (exact->inexact x)) fx-min) - fx-scale))) - (define (finv y) - (flinv (fl+ fx-min (fl/ (fl- (exact->inexact y) x-min) - fx-scale)))) - (invertible-function f finv))) +(define ((make-axis-transform f g) x-min x-max old-function) + (define fx-min (f x-min)) + (define fx-scale (/ (- x-max x-min) (- (f x-max) fx-min))) + (define (new-f x) (+ x-min (* (- (f x) fx-min) fx-scale))) + (define (new-g y) (g (+ fx-min (/ (- y x-min) fx-scale)))) + (invertible-compose (invertible-function new-f new-g) old-function)) + +;; =================================================================================================== +;; Axis transform combinators + +(defproc (axis-transform-compose [t1 axis-transform/c] [t2 axis-transform/c]) axis-transform/c + (λ (x-min x-max old-function) + (t1 x-min x-max (t2 x-min x-max old-function)))) + +(defproc (axis-transform-append [t1 axis-transform/c] [t2 axis-transform/c] [x-mid real?] + ) axis-transform/c + (λ (x-min x-max old-function) + (match-define (invertible-function old-f old-g) old-function) + (let ([x-mid (old-f x-mid)]) + (cond [(x-mid . >= . x-max) (t1 x-min x-max old-function)] + [(x-mid . <= . x-min) (t2 x-min x-max old-function)] + [else + (match-define (invertible-function f1 g1) (t1 x-min x-mid old-function)) + (match-define (invertible-function f2 g2) (t2 x-mid x-max old-function)) + ((make-axis-transform (λ (x) (cond [((old-f x) . < . x-mid) (f1 x)] + [else (f2 x)])) + (λ (x) (cond [(x . < . x-mid) (g1 x)] + [else (g2 x)]))) + x-min x-max id-function)])))) + +(defproc (axis-transform-bound [t axis-transform/c] [x-min real?] [x-max real?]) axis-transform/c + (axis-transform-append (axis-transform-append id-transform t x-min) id-transform x-max)) ;; =================================================================================================== ;; Specific axis transforms @@ -65,21 +106,60 @@ (let ([x (exact->inexact x)]) (fl* x (fl* x x)))) +(define (real-log x) + (fllog (exact->inexact x))) -(defproc (id-transform [x-min real?] [x-max real?]) invertible-function? - (invertible-function values values)) +(define (real-exp x) + (flexp (exact->inexact x))) -(defproc (log-transform [x-min real?] [x-max real?]) invertible-function? +(defproc (log-transform [x-min real?] [x-max real?] [old-function invertible-function?] + ) invertible-function? (when ((exact->inexact x-min) . <= . 0) (raise-type-error 'log-transform "positive real" 0 x-min x-max)) - ((make-axis-transform fllog flexp) x-min x-max)) + ((make-axis-transform real-log real-exp) x-min x-max old-function)) -(define cbrt-trans (make-axis-transform cbrt cube)) +(defproc (cbrt-transform [x-min real?] [x-max real?] [old-function invertible-function?] + ) invertible-function? + ((make-axis-transform cbrt cube) x-min x-max old-function)) -(defproc (cbrt-transform [x-min real?] [x-max real?]) invertible-function? - (cbrt-trans x-min x-max)) +(defproc (hand-drawn-transform [freq (>/c 0)]) axis-transform/c + (λ (x-min x-max old-function) + (define d (/ freq (- x-max x-min))) + ((make-axis-transform (sine-diag d) (sine-diag-inv d)) x-min x-max old-function))) -(defproc (hand-drawn-transform [freq (>/c 0)]) (real? real? . -> . invertible-function?) - (λ (mn mx) - (define d (/ freq (- mx mn))) - ((make-axis-transform (sine-diag d) (sine-diag-inv d)) mn mx))) +;; =================================================================================================== + +(define (stretch a b s) + (define d (- b a)) + (define ds (* d s)) + (λ (x) + (cond [(x . < . a) x] + [(x . > . b) (+ (- x d) ds)] + [else (+ a (* (- x a) s))]))) + +(defproc (stretch-transform [a real?] [b real?] [scale (and/c real? (not/c (=/c 0)))] + ) axis-transform/c + (when (a . > . b) (error 'stretch-transform "expected a <= b; given ~e and ~e" a b)) + (λ (x-min x-max old-function) + (match-define (invertible-function old-f old-g) old-function) + (let ([a (old-f a)] + [b (old-f b)]) + (define f (stretch a b scale)) + (define g (stretch (f a) (f b) (/ 1 scale))) + ((make-axis-transform f g) x-min x-max old-function)))) + +(defproc (collapse-transform [a real?] [b real?]) axis-transform/c + (when (a . > . b) (error 'stretch-transform "expected a <= b; given ~e and ~e" a b)) + (λ (x-min x-max old-function) + (match-define (invertible-function old-f old-g) old-function) + (let ([a (old-f a)] + [b (old-f b)]) + (define 1/2size (* 1/2 (- b a))) + (define center (* 1/2 (+ a b))) + (define (f x) (cond [(x . < . a) (+ x 1/2size)] + [(x . > . b) (- x 1/2size)] + [else center])) + (define (g x) (cond [(x . < . center) (- x 1/2size)] + [(x . > . center) (+ x 1/2size)] + [else center])) + ((make-axis-transform f g) x-min x-max old-function)))) diff --git a/collects/plot/common/contract-doc.rkt b/collects/plot/common/contract-doc.rkt index 35267872dd..92a8fc1220 100644 --- a/collects/plot/common/contract-doc.rkt +++ b/collects/plot/common/contract-doc.rkt @@ -9,7 +9,7 @@ (prefix-in s. scribble/core) (prefix-in s. scribble/html-properties)) -(provide defproc defparam defcontract doc-apply) +(provide defproc defparam defthing defcontract doc-apply) (begin-for-syntax (struct proc+doc (proc-transformer doc-transformer) @@ -148,6 +148,24 @@ (quasisyntax/loc stx (defparam name #,(parameter-name->arg-name #'name) contract default))])) +(define-syntax (defthing stx) + (syntax-parse stx + [(_ name:id contract:expr value:expr) + (with-syntax ([value-name (make-value-name #'name)] + [serialized-contract (serialize-syntax #'contract)]) + (syntax/loc stx + (begin + (define/contract value-name contract value) + (define-syntax name + (make-proc+doc + #'value-name + (λ (doc-stx) + (syntax-case doc-stx () + [(ctx . pre-flows) + (with-syntax ([doc-name (make-doc-name #'ctx #'name)] + [doc-contract (unserialize-syntax #'ctx 'serialized-contract)]) + #'(s.defthing doc-name doc-contract . pre-flows))])))))))])) + ;; Define a contract or a procedure that returns a contract (define-syntax (defcontract stx) (syntax-parse stx diff --git a/collects/plot/common/currency.rkt b/collects/plot/common/currency.rkt new file mode 100644 index 0000000000..e73f2f3fa6 --- /dev/null +++ b/collects/plot/common/currency.rkt @@ -0,0 +1,122 @@ +#lang racket/base + +(provide (all-defined-out)) + +(define currency-code->sign + #hash((ALL . "Lek") + (AFN . "\u60b") + (ARS . "$") + (AWG . "\u192") + (AUD . "$") + (AZN . "\u43c\u430\u43d") + (BSD . "$") + (BBD . "$") + (BYR . "p.") + (BZD . "BZ$") + (BMD . "$") + (BOB . "$b") + (BAM . "KM") + (BWP . "P") + (BGN . "\u43b\u432") + (BRL . "R$") + (BND . "$") + (KHR . "\u17db") + (CAD . "$") + (KYD . "$") + (CLP . "$") + (CNY . "\ua5") + (COP . "$") + (CRC . "\u20a1") + (HRK . "kn") + (CUP . "\u20b1") + (CZK . "\u4b\u10d") + (DKK . "kr") + (DOP . "RD$") + (XCD . "$") + (EGP . "\ua3") + (SVC . "$") + (EEK . "kr") + (EUR . "\u20ac") + (FKP . "\ua3") + (FJD . "$") + (GHC . "\ua2") + (GIP . "\ua3") + (GTQ . "Q") + (GGP . "\ua3") + (GYD . "$") + (HNL . "L") + (HKD . "$") + (HUF . "Ft") + (ISK . "kr") + (INR . "\u20B9") + (IDR . "Rp") + (IRR . "\ufdfc") + (IMP . "\ua3") + (ILS . "\u20aa") + (JMD . "J$") + (JPY . "\ua5") + (JEP . "\ua3") + (KZT . "\u43b\u432") + (KPW . "\u20a9") + (KRW . "\u20a9") + (KGS . "\u43b\u432") + (LAK . "\u20ad") + (LVL . "Ls") + (LBP . "\ua3") + (LRD . "$") + (LTL . "Lt") + (MKD . "\u434\u435\u43d") + (MYR . "RM") + (MUR . "\u20a8") + (MXN . "$") + (MNT . "\u20ae") + (MZN . "MT") + (NAD . "$") + (NPR . "\u20a8") + (ANG . "\u192") + (NZD . "$") + (NIO . "C$") + (NGN . "\u20a6") + (KPW . "\u20a9") + (NOK . "kr") + (OMR . "\ufdfc") + (PKR . "\u20a8") + (PAB . "B/.") + (PYG . "Gs") + (PEN . "S/.") + (PHP . "\u20b1") + (PLN . "z\u142") + (QAR . "\ufdfc") + (RON . "lei") + (RUB . "\u440\u443\u431") + (SHP . "\ua3") + (SAR . "\ufdfc") + (RSD . "\u414\u438\u43d.") + (SCR . "\u20a8") + (SGD . "$") + (SBD . "$") + (SOS . "S") + (ZAR . "R") + (KRW . "\u20a9") + (LKR . "\u20a8") + (SEK . "kr") + (CHF . "CHF") + (SRD . "$") + (SYP . "\ua3") + (TWD . "NT$") + (THB . "\ue3f") + (TTD . "TT$") + (TRY . "TL") + (TRL . "\u20a4") + (TVD . "$") + (UAH . "\u20b4") + (GBP . "\ua3") + (USD . "$") + (UYU . "$U") + (UZS . "\u43b\u432") + (VEF . "Bs") + (VND . "\u20ab") + (YER . "\ufdfc") + (ZWD . "Z$"))) + +(define known-currency-codes (sort (hash-keys currency-code->sign) string<=? #:key symbol->string)) diff --git a/collects/plot/common/date-time.rkt b/collects/plot/common/date-time.rkt new file mode 100644 index 0000000000..e519542b9e --- /dev/null +++ b/collects/plot/common/date-time.rkt @@ -0,0 +1,186 @@ +#lang racket/base + +(require racket/date racket/contract racket/match + (prefix-in srfi-date: srfi/19) + db + "contract.rkt" + "contract-doc.rkt" + "math.rkt" + "format.rkt") + +(provide (all-defined-out)) + +(define seconds-per-minute 60) +(define seconds-per-hour (* 60 seconds-per-minute)) +(define seconds-per-day (* 24 seconds-per-hour)) +(define seconds-per-week (* 7 seconds-per-day)) +(define avg-seconds-per-year (* #e365.2425 seconds-per-day)) +(define avg-seconds-per-month (* 1/12 avg-seconds-per-year)) + +;; =================================================================================================== +;; UTC dates for plotting + +;; A date is always represented by the number of seconds since the platform-specific, UTC epoch + +(define (date*->seconds dt [local-time? #t]) + (match-define (date* s mn h d m y wd yd dst? tz ns tz-name) + dt) + (+ (date->seconds (date s mn h d m y wd yd dst? tz) local-time?) + (/ ns 1000000000))) + +(define (date*->utc-seconds dt) + (- (date*->seconds dt #f) (date-time-zone-offset dt))) + +(define (date->utc-seconds dt) + (- (date->seconds dt #f) (date-time-zone-offset dt))) + +(define (utc-seconds-second secs) + (define w (floor secs)) + (define f (- secs w)) + (+ f (date-second (seconds->date w #f)))) + +(define (utc-seconds-round-year secs) + (define dt (seconds->date secs #f)) + (define y1 (date-year dt)) + ;; Find start of this year, start of next year, and difference between them in UTC seconds + (define s1 (date->seconds (date 0 0 0 1 1 y1 0 0 #f 0) #f)) + (define s2 (date->seconds (date 0 0 0 1 1 (+ y1 1) 0 0 #f 0) #f)) + (define diff (- s2 s1)) + ;; Round by 1) subtracting this year; 2) rounding to this year or next; 3) adding this year + (+ (* (round (/ (- secs s1) diff)) diff) s1)) + +(define (utc-seconds-round-month secs) + (define dt (seconds->date secs #f)) + (define m1 (date-month dt)) + (define y1 (date-year dt)) + ;; Find start of this month, start of next month, and difference between them in UTC seconds + (define s1 (date->seconds (date 0 0 0 1 m1 y1 0 0 #f 0) #f)) + (define-values (m2 y2) (cond [((+ m1 1) . > . 12) (values 1 (+ y1 1))] + [else (values (+ m1 1) y1)])) + (define s2 (date->seconds (date 0 0 0 1 m2 y2 0 0 #f 0) #f)) + (define diff (- s2 s1)) + ;; Round by 1) subtracting this month; 2) rounding to this month or next; 3) adding this month + (+ (* (round (/ (- secs s1) diff)) diff) s1)) + +;; =================================================================================================== +;; Time + +;; A date-independent representation of time + +(define-struct/contract plot-time ([second (and/c (>=/c 0) (plot-time s) + (let* ([s (inexact->exact s)] + [day (floor (/ s seconds-per-day))] + [s (- s (* day seconds-per-day))] + [hour (floor (/ s seconds-per-hour))] + [s (- s (* hour seconds-per-hour))] + [minute (floor (/ s seconds-per-minute))] + [s (- s (* minute seconds-per-minute))]) + (plot-time s minute hour day))) + +(define (plot-time->seconds t) + (match-define (plot-time second minute hour day) t) + (+ second + (* minute seconds-per-minute) + (* hour seconds-per-hour) + (* day seconds-per-day))) + +(defproc (datetime->real [x (or/c plot-time? date? date*? sql-date? sql-time? sql-timestamp?)]) real? + (match x + [(? plot-time?) (plot-time->seconds x)] + [(? date*?) (date*->utc-seconds x)] + [(? date?) (date->utc-seconds x)] + [(sql-date y m d) (date->utc-seconds (date 0 0 0 d m y 0 0 #t 0))] + [(sql-time h m s ns tz) (plot-time->seconds (- (plot-time (+ s (/ ns 1000000000)) m h 0) + (if tz tz 0)))] + [(sql-timestamp y m d h mn s ns tz) (date*->utc-seconds + (date* s mn h d m y 0 0 #t (if tz tz 0) ns "UTC"))])) + +;; =================================================================================================== +;; Formatting following SRFI 19, with alterations + +#| +Supported format specifiers: + +~a locale's abbreviated weekday name (Sun...Sat) +~A locale's full weekday name (Sunday...Saturday) +~b locale's abbreviate month name (Jan...Dec) +~B locale's full month day (January...December) +~d day of month, zero padded (01...31) +~D date (mm/dd/yy) +~e day of month, blank padded ( 1...31) +~h same as ~b +~H hour, zero padded, 24-hour clock (00...23) +~I hour, zero padded, 12-hour clock (01...12) +~j day of year, zero padded +~k hour, blank padded, 24-hour clock (00...23) +~l hour, blank padded, 12-hour clock (01...12) +~m month, zero padded (01...12) +~M minute, zero padded (00...59) +~N nanosecond, zero padded +~p locale's AM or PM +~r time, 12 hour clock, same as "~I:~M:~S ~p" +~S second, zero padded (00...60) +~f seconds+fractional seconds, using locale's decimal separator (e.g. 5.2). +~s number of full seconds since "the epoch" (in UTC) +~T time, 24 hour clock, same as "~H:~M:~S" +~U week number of year with Sunday as first day of week (00...53) +~V week number of year with Monday as first day of week (01...52) +~w day of week (0...6) +~W week number of year with Monday as first day of week (01...52) +~x week number of year with Monday as first day of week (00...53) +~X locale's date representation, for example: "07/31/00" +~y last two digits of year (00...99) +~Y year +~1 ISO-8601 year-month-day format +~3 ISO-8601 hour-minute-second format +~5 ISO-8601 year-month-day-hour-minute-second format +|# + +(define (plot-date-formatter x-min x-max) + (define digits (digits-for-range x-min x-max)) + (λ (fmt secs) + (case fmt + [(~f) (define s (utc-seconds-second secs)) + (define str (real->string/trunc s (max 0 digits))) + (if (s . < . 10) (format "0~a" str) str)] + [(~s) (real->plot-label secs digits)] + [(~a ~A ~b ~B ~d ~D ~e ~h ~H ~I ~j ~k ~l ~m ~M ~N + ~p ~r ~S ~f ~s ~T ~U ~V ~w ~W ~x ~X ~y ~Y ~1 ~3 ~5) + (match-define (date* s mn h d m y _wd _yd _dst? tz ns _tz-name) + (seconds->date secs #f)) + (srfi-date:date->string (srfi-date:make-date ns s mn h d m y tz) (symbol->string fmt))] + [else #f]))) + +#| +Supported format specifiers: + +~d day +~H hour, zero padded, 24-hour clock (00...23) +~I hour, zero padded, 12-hour clock (01...12) +~k hour, blank padded, 24-hour clock ( 0...23) +~l hour, blank padded, 12-hour clock ( 1...12) +~p locale's AM or PM +~M minute, zero padded (00...59) +~S second, zero padded (00...60) +~f seconds+fractional seconds, using locale's decimal separator (e.g. 5.2). +~s second, formatted (nanoseconds, etc.) +~r time, 12 hour clock, same as "~I:~M:~S ~p" +~T time, 24 hour clock, same as "~H:~M:~S" +~3 ISO-8601 hour-minute-second format +|# + +(define (plot-time-formatter x-min x-max) + (define digits (digits-for-range x-min x-max)) + (λ (fmt secs) + (case fmt + [(~H ~I ~k ~l ~p ~M ~S ~f ~s ~r ~T ~3) + ((plot-date-formatter x-min x-max) fmt (real-modulo secs seconds-per-day))] + [(~d) (define digits (digits-for-range (/ x-min seconds-per-day) (/ x-max seconds-per-day))) + (real->plot-label (plot-time-day (seconds->plot-time secs)) digits)] + [else #f]))) diff --git a/collects/plot/common/format.rkt b/collects/plot/common/format.rkt index 769ab2df42..c8199734c9 100644 --- a/collects/plot/common/format.rkt +++ b/collects/plot/common/format.rkt @@ -4,9 +4,46 @@ (require racket/string racket/list racket/pretty racket/contract racket/match "math.rkt" - "contract.rkt" "contract-doc.rkt") + "contract.rkt" + "contract-doc.rkt") -(provide digits-for-range real->plot-label ->plot-label real->string/trunc) +(provide integer->superscript + real->decimal-string* real->string/trunc + digits-for-range real->plot-label ->plot-label + parse-format-string apply-formatter) + +(define (string-map f str) + (list->string (map f (string->list str)))) + +(defproc (integer->superscript [x exact-integer?]) string? + (string-map (λ (c) (case c + [(#\0) #\u2070] + [(#\1) #\u00b9] + [(#\2) #\u00b2] + [(#\3) #\u00b3] + [(#\4) #\u2074] + [(#\5) #\u2075] + [(#\6) #\u2076] + [(#\7) #\u2077] + [(#\8) #\u2078] + [(#\9) #\u2079] + [(#\+) #\u207a] + [(#\-) #\u207b] + [else c])) + (number->string x))) + +(defproc (real->decimal-string* [x real?] + [min-digits exact-nonnegative-integer?] + [max-digits exact-nonnegative-integer? min-digits]) string? + (when (min-digits . > . max-digits) + (error 'real->decimal-string* "expected min-digits <= max-digits; given ~e and ~e" + min-digits max-digits)) + (define str (real->decimal-string x max-digits)) + (let loop ([i (string-length str)] [j (- max-digits min-digits)]) + (cond [(zero? j) (substring str 0 i)] + [(zero? i) "0"] ; shouldn't happen, as real->decimal-string guarantees a "0." prefix + [(char=? #\0 (string-ref str (- i 1))) (loop (- i 1) (- j 1))] + [else (substring str 0 i)]))) (define (remove-trailing-zeros str) (let loop ([i (string-length str)]) @@ -19,7 +56,7 @@ (defproc (digits-for-range [x-min real?] [x-max real?] [extra-digits exact-integer? 3]) exact-integer? (define range (abs (- x-max x-min))) - (+ extra-digits (if (zero? range) 0 (- (floor-log10 range))))) + (+ extra-digits (if (zero? range) 0 (- (floor-log/base 10 range))))) (define (int-str->e-str str) (define n (string-length str)) @@ -27,37 +64,42 @@ [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))])) + (format "~a×10~a" + (remove-trailing-zeros (format "~a.~a" fst rst)) + (integer->superscript (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")) + (check-equal? (int-str->e-str "10") "1×10\u00b9")) (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)))])]))) + [else (define fst (substring str i (add1 i))) + (define rst (substring str (add1 i) n)) + (cond [(= 0 (string-length rst)) + (format "~a×10~a" fst (integer->superscript (- (add1 i))))] + [else + (format "~a.~a×10~a" fst rst (integer->superscript (- (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")) + (check-equal? (frac-str->e-str "1") "1×10\u207b\u00b9") + (check-equal? (frac-str->e-str "01") "1×10\u207b\u00b2")) (define (zero-string n) (list->string (build-list n (λ _ #\0)))) -(defproc (real->plot-label [x real?] [digits exact-integer?]) any +(defproc (real->plot-label [x real?] [digits exact-integer?] [scientific? boolean? #t]) any (cond [(zero? x) "0"] [else @@ -72,36 +114,43 @@ (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))])) + (cond + [scientific? + ;; 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-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)] + [else + (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)])]))])) (defproc (->plot-label [a any/c] [digits exact-integer? 7]) string? (let loop ([a a]) @@ -117,3 +166,24 @@ ;; 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)))) + +;; =================================================================================================== +;; Format strings + +(defproc (parse-format-string [str string?]) (listof (or/c string? symbol?)) + (define n (string-length str)) + (let loop ([i 0] [fmt-list empty]) + (cond [(i . >= . n) (reverse fmt-list)] + [(i . = . (- n 1)) (reverse (cons (substring str i (+ i 1)) fmt-list))] + [(char=? #\~ (string-ref str i)) + (loop (+ i 2) (cons (string->symbol (substring str i (+ i 2))) fmt-list))] + [else (loop (+ i 1) (cons (substring str i (+ i 1)) fmt-list))]))) + +(define (apply-formatter [formatter (symbol? . -> . (or/c string? #f))] + [fmt-list (listof (or/c string? symbol?))] + [d any/c]) (listof string?) + (for/list ([fmt (in-list fmt-list)]) + (cond [(eq? fmt '~~) "~"] + [(symbol? fmt) (let ([val (formatter fmt d)]) + (if val val (symbol->string fmt)))] + [(string? fmt) fmt]))) diff --git a/collects/plot/common/legend.rkt b/collects/plot/common/legend.rkt index 8cd796bc34..60da57d813 100644 --- a/collects/plot/common/legend.rkt +++ b/collects/plot/common/legend.rkt @@ -20,17 +20,14 @@ (send plot-area set-alpha 1) (send plot-area draw-line (vector x-min y) (vector x-max y))))) -(define (line-legend-entries label zs colors widths styles) - (define z-min (first zs)) - (define z-max (last zs)) - (define digits (digits-for-range z-min z-max)) +(define (line-legend-entries label zs z-labels colors widths styles) (define hash - (for/fold ([hash empty]) ([z (in-list zs)] - [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->plot-label z digits)) - (assoc-cons hash (list color width style) entry-label))) + (for/fold ([hash empty]) ([z (in-list zs)] + [z-label (in-list z-labels)] + [color (in-cycle (maybe-apply/list colors zs))] + [width (in-cycle (maybe-apply/list widths zs))] + [style (in-cycle (maybe-apply/list styles zs))]) + (assoc-cons hash (list color width style) z-label))) (reverse (for/list ([entry (in-list hash)]) @@ -92,15 +89,15 @@ (send plot-area set-pen line2-color line2-width line2-style) (send plot-area draw-line (vector x-min y-min) (vector x-max y-min))))) -(define (interval-legend-entries label zs fill-colors fill-styles line-colors line-widths line-styles +(define (interval-legend-entries label zs labels fill-colors fill-styles + line-colors line-widths line-styles line1-colors line1-widths line1-styles line2-colors line2-widths line2-styles) - (define z-min (first zs)) - (define z-max (last zs)) - (define digits (digits-for-range z-min z-max)) (define hash (for/fold ([hash empty]) ([za (in-list zs)] [zb (in-list (rest zs))] + [la (in-list labels)] + [lb (in-list (rest labels))] [fill-color (in-cycle (maybe-apply/list fill-colors zs))] [fill-style (in-cycle (maybe-apply/list fill-styles zs))] [line-color (in-cycle (maybe-apply/list line-colors zs))] @@ -112,8 +109,7 @@ [line2-color (in-cycle (maybe-apply/list line2-colors zs))] [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->plot-label za digits) (real->plot-label zb digits))) + (define entry-label (format "[~a,~a]" la lb)) (assoc-cons hash (list fill-color fill-style line-color line-width line-style line1-color line1-width line1-style @@ -132,22 +128,21 @@ line1-color line1-width line1-style line2-color line2-width line2-style)))) -(define (contour-intervals-legend-entries label z-min z-max zs +(define (contour-intervals-legend-entries label zs labels fill-colors fill-styles line-colors line-widths line-styles contour-colors contour-widths contour-styles) - (define interval-zs (append (list z-min) zs (list z-max))) - + (define n (- (length zs) 2)) (define ccs (append (list 0) - (sequence-take (in-cycle (maybe-apply/list contour-colors zs)) 0 (length zs)) + (sequence-take (in-cycle (maybe-apply/list contour-colors zs)) 0 n) (list 0))) (define cws (append (list 0) - (sequence-take (in-cycle (maybe-apply/list contour-widths zs)) 0 (length zs)) + (sequence-take (in-cycle (maybe-apply/list contour-widths zs)) 0 n) (list 0))) (define css (append '(transparent) - (sequence-take (in-cycle (maybe-apply/list contour-styles zs)) 0 (length zs)) + (sequence-take (in-cycle (maybe-apply/list contour-styles zs)) 0 n) '(transparent))) - (interval-legend-entries label interval-zs + (interval-legend-entries label zs labels fill-colors fill-styles line-colors line-widths line-styles ccs cws css (rest ccs) (rest cws) (rest css))) diff --git a/collects/plot/common/math.rkt b/collects/plot/common/math.rkt index 2af4f6a9be..db41e784e2 100644 --- a/collects/plot/common/math.rkt +++ b/collects/plot/common/math.rkt @@ -126,11 +126,17 @@ (if x (if y (max* x y) x) (if y y #f)))) -(define (floor-log10 x) - (inexact->exact (floor (/ (log (abs x)) (log 10))))) +(defproc (floor-log/base [b (and/c exact-integer? (>=/c 2))] [x (>/c 0)]) real? + (define y (inexact->exact (floor (/ (log x) (log b))))) + (cond [(exact? x) + (let loop ([y y] [x (/ x (expt b y))]) + (cond [(x . >= . b) (loop (add1 y) (/ x b))] + [(x . < . 1) (loop (sub1 y) (* x b))] + [else y]))] + [else y])) -(define (ceiling-log10 x) - (inexact->exact (ceiling (/ (log (abs x)) (log 10))))) +(define (ceiling-log/base b x) + (inexact->exact (ceiling (/ (log (abs x)) (log b))))) (define (bin-samples bin-bounds xs) (let* ([bin-bounds (filter (compose not nan?) (remove-duplicates bin-bounds))] diff --git a/collects/plot/common/parameters.rkt b/collects/plot/common/parameters.rkt index dbb8d5ce70..d29cd0acc6 100644 --- a/collects/plot/common/parameters.rkt +++ b/collects/plot/common/parameters.rkt @@ -5,7 +5,8 @@ (require racket/contract "contract.rkt" "contract-doc.rkt" "draw.rkt" - "axis-transform.rkt") + "axis-transform.rkt" + "ticks.rkt") (provide (all-defined-out)) @@ -50,6 +51,31 @@ (cond [(plot-animating?) (max 2 (ceiling (* 1/4 samples)))] [else samples])) +;; Sampling + +(defparam plot-x-transform axis-transform/c id-transform) +(defparam plot-y-transform axis-transform/c id-transform) +(defparam plot-z-transform axis-transform/c id-transform) + +;; Ticks + +(defparam plot-x-max-ticks exact-positive-integer? 5) +(defparam plot-y-max-ticks exact-positive-integer? 5) +(defparam plot-z-max-ticks exact-positive-integer? 8) + +(defparam plot-x-ticks ticks? (linear-ticks)) +(defparam plot-y-ticks ticks? (linear-ticks)) +(defparam plot-z-ticks ticks? (linear-ticks)) + +(defproc (default-x-ticks [x-min real?] [x-max real?]) (listof tick?) + ((plot-x-ticks) x-min x-max (plot-x-max-ticks) (plot-x-transform))) + +(defproc (default-y-ticks [y-min real?] [y-max real?]) (listof tick?) + ((plot-y-ticks) y-min y-max (plot-y-max-ticks) (plot-y-transform))) + +(defproc (default-z-ticks [z-min real?] [z-max real?]) (listof tick?) + ((plot-z-ticks) z-min z-max (plot-z-max-ticks) (plot-z-transform))) + ;; Lines (defparam line-samples (and/c exact-integer? (>=/c 2)) 500) @@ -134,18 +160,13 @@ (defparam polar-axes-number exact-positive-integer? 12) (defparam polar-axes-ticks? boolean? #t) +(defparam polar-axes-max-ticks exact-positive-integer? 8) (defparam label-anchor anchor/c 'left) (defparam label-angle real? 0) (defparam label-alpha (real-in 0 1) 1) (defparam label-point-size (>=/c 0) 4) -;; Sampling - -(defparam plot-x-transform (real? real? . -> . invertible-function?) id-transform) -(defparam plot-y-transform (real? real? . -> . invertible-function?) id-transform) -(defparam plot-z-transform (real? real? . -> . invertible-function?) id-transform) - ;; =================================================================================================== ;; 3D-specific parameters diff --git a/collects/plot/common/sample.rkt b/collects/plot/common/sample.rkt index 80e8a19698..5d7ed26a1f 100644 --- a/collects/plot/common/sample.rkt +++ b/collects/plot/common/sample.rkt @@ -3,11 +3,14 @@ ;; Functions that sample from functions, and functions that create memoized samplers. (require racket/match racket/flonum racket/math racket/contract racket/list - "contract.rkt" "contract-doc.rkt" + "contract.rkt" + "contract-doc.rkt" "math.rkt" "axis-transform.rkt" "parameters.rkt" - "contract.rkt") + "contract.rkt" + "format.rkt" + "ticks.rkt") (provide (all-defined-out)) @@ -23,10 +26,10 @@ [_ (map f xs)])) (defproc (nonlinear-seq [start real?] [end real?] [num exact-nonnegative-integer?] - [transform (real? real? . -> . invertible-function?)] + [transform axis-transform/c] [#:start? start? boolean? #t] [#:end? end? boolean? #t]) (listof real?) - (match-define (invertible-function _ finv) (transform start end)) + (match-define (invertible-function _ finv) (apply-transform transform start end)) (map finv (linear-seq start end num #:start? start? #:end? end?))) (define ((2d-polar->3d-function f) x y z) @@ -103,3 +106,50 @@ [ds (in-vector dss)] [d (in-vector ds)]) d)) + +;; =================================================================================================== +;; Common memoized samplers + +(define function->sampler (make-function->sampler plot-x-transform)) +(define inverse->sampler (make-function->sampler plot-y-transform)) +(define 2d-function->sampler (make-2d-function->sampler plot-x-transform plot-y-transform)) +(define 3d-function->sampler + (make-3d-function->sampler plot-x-transform plot-y-transform plot-z-transform)) + +;; =================================================================================================== +;; Contour ticks + +(defproc (contour-ticks [z-min real?] [z-max real?] + [levels (or/c 'auto exact-positive-integer? (listof real?))] + [intervals? boolean?]) (listof tick?) + (define epsilon (expt 10 (- (digits-for-range z-min z-max)))) + (match-define (ticks layout format) (plot-z-ticks)) + (define ts + (cond [(eq? levels 'auto) (filter pre-tick-major? + (layout z-min z-max (plot-z-max-ticks) (plot-z-transform)))] + [else (define zs (cond [(list? levels) (filter (λ (z) (<= z-min z z-max)) levels)] + [else (linear-seq z-min z-max levels #:start? #f #:end? #f)])) + (map (λ (z) (pre-tick z #t)) zs)])) + (define all-ts + (cond [intervals? + (let* ([ts (cond [((abs (- z-min (pre-tick-value (first ts)))) . < . epsilon) ts] + [else (cons (pre-tick z-min #t) ts)])] + [ts (cond [((abs (- z-max (pre-tick-value (last ts)))) . < . epsilon) ts] + [else (append ts (list (pre-tick z-max #t)))])]) + ts)] + [else + (let* ([ts (cond [((abs (- z-min (pre-tick-value (first ts)))) . >= . epsilon) ts] + [else (rest ts)])] + [ts (cond [((abs (- z-max (pre-tick-value (last ts)))) . >= . epsilon) ts] + [else (take ts (- (length ts) 1))])]) + ts)])) + (match-define (list (pre-tick zs majors) ...) all-ts) + (define labels (format z-min z-max all-ts)) + (map tick zs majors labels)) + +(defproc (auto-contour-values [z-min real?] [z-max real?]) (listof real?) + (define ts (default-z-ticks z-min z-max)) + (let* ([zs (map pre-tick-value (filter pre-tick-major? ts))] + [zs (if (= (first zs) z-min) (rest zs) zs)] + [zs (if (= (last zs) z-max) (take zs (sub1 (length zs))) zs)]) + zs)) diff --git a/collects/plot/common/ticks.rkt b/collects/plot/common/ticks.rkt index d87c12ba66..7563b5db04 100644 --- a/collects/plot/common/ticks.rkt +++ b/collects/plot/common/ticks.rkt @@ -2,50 +2,620 @@ ;; Data structure that represents a tick, and functions that produce ticks. -(require racket/string racket/list racket/contract racket/pretty +(require racket/string racket/list racket/contract racket/pretty racket/match "math.rkt" "format.rkt" "utils.rkt" - "contract.rkt" "contract-doc.rkt" - "parameters.rkt") + "contract.rkt" + "contract-doc.rkt" + "date-time.rkt" + "axis-transform.rkt" + "currency.rkt") -(provide (all-defined-out)) +(provide (struct-out pre-tick) (struct-out tick) (struct-out ticks) + ;; No ticks + no-ticks-layout no-ticks-format no-ticks + ;; Linear ticks + linear-ticks-base linear-ticks-divisors + linear-ticks-layout linear-ticks-format linear-ticks + ;; Uniform ticks + uniform-ticks-layout uniform-ticks + ;; Log-scale ticks + log-ticks-base + log-ticks-layout log-ticks-format log-ticks + ;; Date ticks + date-ticks-formats 24h-descending-date-ticks-formats 12h-descending-date-ticks-formats + date-ticks-layout date-ticks-format date-ticks + ;; Time ticks + time-ticks-formats descending-time-ticks-formats + time-ticks-layout time-ticks-format time-ticks + ;; Bit/byte ticks + bit/byte-ticks-format bit/byte-ticks + ;; Currency ticks and formats + currency-scale-suffixes + us-currency-scale-suffixes uk-currency-scale-suffixes eu-currency-scale-suffixes + currency-format-strings + us-currency-format-strings uk-currency-format-strings eu-currency-format-strings + currency-ticks-format currency-ticks + ;; Fractions + fraction-ticks-format fraction-ticks + ) -(define-struct/contract tick - ([p real?] [label string?] [major? boolean?]) - #:transparent) +(define-struct/contract pre-tick ([value real?] [major? boolean?]) #:transparent) +(define-struct/contract (tick pre-tick) ([label string?]) #:transparent) -(define (tick-ps->majors ps major-skip) - (define zero-idx (list-index 0 ps =)) - (define zero-idx-rem (if (zero-idx . < . 0) 0 (remainder zero-idx major-skip))) - (for/list ([n (in-range (length ps))]) - (= (remainder n major-skip) zero-idx-rem))) +(defcontract ticks-layout/c + (real? real? exact-positive-integer? axis-transform/c . -> . (listof pre-tick?))) -(define (linear-ticks major-skip x-min x-max) - (when (x-min . >= . x-max) - (error 'default-range->ticks "expected x-min < x-max; got x-min = ~e and x-max = ~e" x-min x-max)) - (let ([x-min (inexact->exact x-min)] - [x-max (inexact->exact x-max)]) - (define e (floor-log10 (- x-max x-min))) - (define mag (expt 10 e)) - (define step (let ([y (/ (- x-max x-min) mag)]) - (cond [(y . < . 2) (* 1/5 mag)] - [(y . < . 5) (* 1/2 mag)] - [else mag]))) - (define start (* (ceiling (/ x-min step)) step)) - (define stop (* (floor (/ x-max step)) step)) - (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->plot-label p digits)) ps)) - (define majors (tick-ps->majors ps major-skip)) - (map tick ps labels majors))) +(defcontract ticks-format/c + (real? real? (listof pre-tick?) . -> . (listof string?))) -(defproc (default-ticks-fun [x-min real?] [x-max real?]) (listof tick?) - (linear-ticks 2 x-min x-max)) +(define-struct/contract ticks ([layout ticks-layout/c] [format ticks-format/c]) #:transparent + #:property prop:procedure + (λ (t x-min x-max max-ticks transform) + (match-define (ticks layout format) t) + (define ts (layout x-min x-max max-ticks transform)) + (match-define (list (pre-tick xs majors) ...) ts) + (map tick xs majors (format x-min x-max ts)))) -(defproc (auto-contour-zs [z-min real?] [z-max real?]) (listof real?) - (let* ([zs (map tick-p (default-ticks-fun z-min z-max))] - [zs (if (= (first zs) z-min) (rest zs) zs)] - [zs (if (= (last zs) z-max) (take zs (sub1 (length zs))) zs)]) - zs)) +;; =================================================================================================== +;; Helpers + +(define-syntax-rule (with-exact-bounds x-min x-max body ...) + (cond [(x-min . >= . x-max) + (error 'bounds-check "expected min < max; given min = ~e and max = ~e" x-min x-max)] + [else (let ([x-min (inexact->exact x-min)] + [x-max (inexact->exact x-max)]) + body ...)])) + +(define (linear-seq-args x-min x-max step) + (define start (* (ceiling (/ x-min step)) step)) + (define end (* (floor (/ x-max step)) step)) + (define num (+ 1 (inexact->exact (round (/ (- end start) step))))) + (values start end num)) + +(define (linear-major-values/step x-min x-max step) + (define-values (start end num) (linear-seq-args x-min x-max step)) + (linear-seq start end num)) + +(defproc (linear-minor-values/step [major-xs (listof real?)] [major-step real?] + [minor-ticks exact-nonnegative-integer?]) (listof real?) + (cond [(or (zero? minor-ticks) (empty? major-xs)) empty] + [else + (define major-start (first major-xs)) + (define minor-step (/ major-step (+ minor-ticks 1))) + (for*/list ([x (in-list (cons (- major-start major-step) major-xs))] + [i (in-range 1 (+ minor-ticks 1))]) + (+ x (* i minor-step)))])) + +(defproc (tick-values->pre-ticks [major-xs (listof real?)] [minor-xs (listof real?)] + ) (listof pre-tick?) + (define major-ts (map (λ (x) (pre-tick x #t)) major-xs)) + (define minor-ts (map (λ (x) (pre-tick x #f)) minor-xs)) + (sort (append major-ts minor-ts) < #:key pre-tick-value)) + +;; =================================================================================================== +;; No ticks + +(defthing no-ticks-layout ticks-layout/c + (λ (x-min x-max max-ticks transform) + empty)) + +(defthing no-ticks-format ticks-format/c + (λ (x-min x-max ts) + empty)) + +(defthing no-ticks ticks? + (ticks no-ticks-layout no-ticks-format)) + +;; =================================================================================================== +;; Linear ticks (default tick function, evenly spaced) + +(defparam linear-ticks-base (and/c exact-integer? (>=/c 2)) 10) +(defparam linear-ticks-divisors (listof exact-positive-integer?) '(1 2 5)) + +(defproc (linear-tick-step+divisor [x-min real?] [x-max real?] + [max-ticks exact-positive-integer?] + [base (and/c exact-integer? (>=/c 2))] + [divisors (listof exact-positive-integer?)] + ) (values real? exact-positive-integer?) + (define range (- x-max x-min)) + (define mag (expt base (floor-log/base base range))) + (define ds (sort divisors >)) + (let/ec break + (for* ([e (in-range (floor-log/base base max-ticks) -2 -1)] + [d (in-list ds)]) + ;(printf "new-d = ~v~n" (* d (expt base e))) + (define step (/ mag d (expt base e))) + (define-values (_start _end num) (linear-seq-args x-min x-max step)) + (when (num . <= . max-ticks) + (break step d))) + ;(printf "default!~n") + (values (/ range max-ticks) max-ticks))) + +(defproc (linear-tick-values [x-min real?] [x-max real?] + [max-ticks exact-positive-integer?] + [base (and/c exact-integer? (>=/c 2))] + [divisors (listof exact-positive-integer?)] + ) (values (listof real?) (listof real?)) + (with-exact-bounds + x-min x-max + (define-values (step d) (linear-tick-step+divisor x-min x-max max-ticks base divisors)) + (define major-xs (linear-major-values/step x-min x-max step)) + (define major-ticks (length major-xs)) + + (define ns (filter (λ (n) (zero? (remainder (* n d) base))) divisors)) + (define n + (cond [(empty? ns) 1] + [else (argmin (λ (n) (abs (- (* n major-ticks) max-ticks))) (sort ns <))])) + (define minor-xs (linear-minor-values/step major-xs step (- n 1))) + (values major-xs (filter (λ (x) (<= x-min x x-max)) minor-xs)))) + +(defproc (linear-ticks-layout [#:base base (and/c exact-integer? (>=/c 2)) (linear-ticks-base)] + [#:divisors divisors (listof exact-positive-integer?) + (linear-ticks-divisors)] + ) ticks-layout/c + (λ (x-min x-max max-ticks transform) + (define-values (major-xs minor-xs) (linear-tick-values x-min x-max max-ticks base divisors)) + (tick-values->pre-ticks major-xs minor-xs))) + +(defproc (linear-ticks-format) ticks-format/c + (λ (x-min x-max ts) + (with-exact-bounds + x-min x-max + (define digits (digits-for-range x-min x-max)) + (for/list ([t (in-list ts)]) + (real->plot-label (pre-tick-value t) digits))))) + +(defproc (linear-ticks [#:base base (and/c exact-integer? (>=/c 2)) (linear-ticks-base)] + [#:divisors divisors (listof exact-positive-integer?) (linear-ticks-divisors)] + ) ticks? + (ticks (linear-ticks-layout #:base base #:divisors divisors) + (linear-ticks-format))) + +;; =================================================================================================== +;; Uniform spacing ticks + +(defproc (uniform-ticks-layout [#:layout layout ticks-layout/c (linear-ticks-layout)]) ticks-layout/c + (λ (x-min x-max max-ticks transform) + (define ts (layout x-min x-max max-ticks transform)) + (define xs (map pre-tick-value ts)) + (define majors (map pre-tick-major? ts)) + (define new-xs (map (invertible-function-finv (apply-transform transform x-min x-max)) xs)) + (map pre-tick new-xs majors))) + +(defproc (uniform-ticks [#:layout layout ticks-layout/c (linear-ticks-layout)]) ticks? + (ticks (uniform-ticks-layout #:layout layout) + (linear-ticks-format))) + +;; =================================================================================================== +;; Exponential ticks (use for log scale) + +(defparam log-ticks-base (and/c exact-integer? (>=/c 2)) 10) + +(defproc (log-ticks-layout [#:base base (and/c exact-integer? (>=/c 2)) (log-ticks-base)] + ) ticks-layout/c + (λ (x-min x-max max-ticks transform) + (with-exact-bounds + x-min x-max + (when ((exact->inexact x-min) . <= . 0) + (raise-type-error 'log-ticks-layout "positive real" 0 x-min x-max)) + (define log-start (floor-log/base base x-min)) + (define log-end (ceiling-log/base base x-max)) + (define log-xs (for/list ([i (in-range log-start (add1 log-end))]) i)) + (define skip (max 1 (floor (/ (+ (length log-xs) 2) 5)))) + (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) + (append* + (for/list ([log-x (in-list log-xs)] + [m (in-cycle (in-range skip))]) + (define x (expt base log-x)) + (cond [(= skip 1) (for/list ([i (in-range 0 (sub1 base) skip)]) + (pre-tick (+ x (* i x)) + (and (zero? i) (zero? m))))] + [else (list (cond [(zero? m) (pre-tick x #t)] + [else (pre-tick x #f)]))]))))))) + +(defproc (log-ticks-format [#:base base (and/c exact-integer? (>=/c 2)) (log-ticks-base)] + ) ticks-format/c + (define base-str (number->string base)) + (λ (x-min x-max ts) + (with-exact-bounds + x-min x-max + (define epsilon (expt 10 (- (digits-for-range x-min x-max)))) + (define base-digits (digits-for-range 0 base)) + (for/list ([t (in-list ts)]) + (define x (pre-tick-value t)) + (define log-x (floor-log/base base x)) + (define round? ((abs (- x (expt base log-x))) . < . epsilon)) + (define major-str (format "~a~a" base-str (integer->superscript log-x))) + (cond [round? major-str] + [else (format "~a×~a" + (real->plot-label (/ x (expt base log-x)) base-digits) + major-str)]))))) + +(defproc (log-ticks [#:base base (and/c exact-integer? (>=/c 2)) (log-ticks-base)]) ticks? + (ticks (log-ticks-layout #:base base) + (log-ticks-format #:base base))) + +;; =================================================================================================== +;; Date/time helpers + +(defproc (find-linear-tick-step [x-min real?] [x-max real?] [max-ticks exact-positive-integer?] + [steps (listof real?)]) real? + (with-exact-bounds + x-min x-max + (let/ec break + (for ([step (in-list (sort steps <))]) + (define-values (_start _end num) (linear-seq-args x-min x-max step)) + (when (num . <= . max-ticks) + (break step))) + #f))) + +(define (count-unchanging-fields formatter fmt-list xs) + (let ([fmt-list (filter symbol? fmt-list)]) + (define formatted-dates (for/list ([x (in-list xs)]) + (apply-formatter formatter fmt-list x))) + (count equal?* (transpose formatted-dates)))) + +(define (choose-format-list formatter fmt-lists xs) + (let ([fmt-lists (sort fmt-lists > + #:key (λ (fmt-list) (count symbol? fmt-list)) + #:cache-keys? #t)]) + (argmin (λ (fmt-list) (count-unchanging-fields formatter fmt-list xs)) + fmt-lists))) + +;; =================================================================================================== +;; Date ticks + +(define 12h-descending-date-ticks-formats + '("~Y-~m-~d ~I:~M:~f~p" + "~Y-~m-~d ~I:~M~p" + "~Y-~m-~d ~I~p" + "~Y-~m-~d" + "~Y-~m" + "~Y" + + "~m-~d ~I:~M:~f~p" + "~m-~d ~I:~M~p" + "~m-~d ~I~p" + "~m-~d" + + "~I:~M:~f~p" + "~I:~M~p" + + "~M:~fs" + + "~fs")) + +(define 24h-descending-date-ticks-formats + '("~Y-~m-~d ~H:~M:~f" + "~Y-~m-~d ~H:~M" + "~Y-~m-~d ~Hh" + "~Y-~m-~d" + "~Y-~m" + "~Y" + + "~m-~d ~H:~M:~f" + "~m-~d ~H:~M" + "~m-~d ~Hh" + "~m-~d" + + "~H:~M:~f" + "~H:~M" + + "~M:~fs" + + "~fs")) + +(defparam date-ticks-formats (listof string?) 24h-descending-date-ticks-formats) + +;; Tick steps to try, in seconds +(define date-steps + (list 1 2 5 10 15 20 30 40 45 + seconds-per-minute + (* 2 seconds-per-minute) + (* 5 seconds-per-minute) + (* 10 seconds-per-minute) + (* 15 seconds-per-minute) + (* 20 seconds-per-minute) + (* 30 seconds-per-minute) + seconds-per-hour + (* 2 seconds-per-hour) + (* 3 seconds-per-hour) + (* 4 seconds-per-hour) + (* 6 seconds-per-hour) + (* 8 seconds-per-hour) + (* 12 seconds-per-hour) + seconds-per-day + (* 2 seconds-per-day) + (* 5 seconds-per-day) + (* 10 seconds-per-day) + seconds-per-week + (* 2 seconds-per-week) + avg-seconds-per-month + (* 2 avg-seconds-per-month) + (* 3 avg-seconds-per-month) + (* 4 avg-seconds-per-month) + (* 6 avg-seconds-per-month) + (* 8 avg-seconds-per-month) + (* 9 avg-seconds-per-month) + avg-seconds-per-year + (* 2 avg-seconds-per-year) + (* 5 avg-seconds-per-year))) + +(define (date-tick-values x-min x-max max-ticks) + (with-exact-bounds + x-min x-max + (define range (- x-max x-min)) + (define step + (cond [(range . < . (* max-ticks (first date-steps))) + (define-values (step _) + (linear-tick-step+divisor x-min x-max max-ticks 10 '(1 2 5))) + step] + [(range . > . (* max-ticks (last date-steps))) + (define-values (step _) + (linear-tick-step+divisor (/ x-min avg-seconds-per-year) + (/ x-max avg-seconds-per-year) + max-ticks 10 '(1 2 5))) + (* step avg-seconds-per-year)] + [else (find-linear-tick-step x-min x-max max-ticks date-steps)])) + (define date-round + (cond [(step . >= . avg-seconds-per-year) utc-seconds-round-year] + [(step . >= . avg-seconds-per-month) utc-seconds-round-month] + [else (λ (d) d)])) + (define major-xs (linear-major-values/step x-min x-max step)) + (values (map date-round major-xs) empty))) + +(defproc (date-ticks-layout) ticks-layout/c + (λ (x-min x-max max-ticks transform) + (define-values (major-xs minor-xs) (date-tick-values x-min x-max max-ticks)) + (tick-values->pre-ticks major-xs minor-xs))) + +(defproc (date-ticks-format [#:formats formats (listof string?) (date-ticks-formats)]) ticks-format/c + (define fmt-lists (map parse-format-string formats)) + (λ (x-min x-max ts) + (with-exact-bounds + x-min x-max + (define formatter (plot-date-formatter x-min x-max)) + (define xs (map pre-tick-value ts)) + (define fmt-list (choose-format-list formatter fmt-lists xs)) + (for/list ([x (in-list xs)]) + (string-append* (apply-formatter formatter fmt-list x)))))) + +(defproc (date-ticks [#:formats formats (listof string?) (date-ticks-formats)]) ticks? + (ticks (date-ticks-layout) + (date-ticks-format #:formats formats))) + +;; =================================================================================================== +;; Time ticks + +(define descending-time-ticks-formats + '("~dd ~H:~M:~f" + "~dd ~H:~M" + "~dd ~Hh" + "~dd" + + "~H:~M:~f" + "~H:~M" + "~Hh" + + "~M:~f" + "~Mm" + + "~ss")) + +(defparam time-ticks-formats (listof string?) descending-time-ticks-formats) + +;; Tick steps to try, in seconds +(define time-steps + (list 1 2 5 10 15 20 30 40 45 + seconds-per-minute + (* 2 seconds-per-minute) + (* 5 seconds-per-minute) + (* 10 seconds-per-minute) + (* 15 seconds-per-minute) + (* 20 seconds-per-minute) + (* 30 seconds-per-minute) + (* 45 seconds-per-minute) + seconds-per-hour + (* 2 seconds-per-hour) + (* 3 seconds-per-hour) + (* 4 seconds-per-hour) + (* 6 seconds-per-hour) + (* 8 seconds-per-hour) + (* 12 seconds-per-hour) + (* 18 seconds-per-hour) + seconds-per-day + (* 2 seconds-per-day) + (* 5 seconds-per-day) + (* 10 seconds-per-day) + (* 15 seconds-per-day) + (* 30 seconds-per-day) + (* 60 seconds-per-day) + (* 90 seconds-per-day))) + +(define (time-tick-values x-min x-max max-ticks) + (with-exact-bounds + x-min x-max + (define range (- x-max x-min)) + (define step + (cond [(range . < . (* max-ticks (first time-steps))) + (define-values (step _) + (linear-tick-step+divisor x-min x-max max-ticks 10 '(1 2 5))) + step] + [(range . > . (* max-ticks (last time-steps))) + (define-values (step _) + (linear-tick-step+divisor (/ x-min seconds-per-day) + (/ x-max seconds-per-day) + max-ticks 10 '(1 2 5))) + (* step seconds-per-day)] + [else + (find-linear-tick-step x-min x-max max-ticks time-steps)])) + (define major-xs (linear-major-values/step x-min x-max step)) + (values major-xs empty))) + +(defproc (time-ticks-layout) ticks-layout/c + (λ (x-min x-max max-ticks transform) + (define-values (major-xs minor-xs) (time-tick-values x-min x-max max-ticks)) + (tick-values->pre-ticks major-xs minor-xs))) + +(defproc (time-ticks-format [#:formats formats (listof string?) (time-ticks-formats)]) ticks-format/c + (define fmt-lists (map parse-format-string formats)) + (λ (x-min x-max ts) + (with-exact-bounds + x-min x-max + (define formatter (plot-time-formatter x-min x-max)) + (define xs (map pre-tick-value ts)) + (define fmt-list (choose-format-list formatter fmt-lists xs)) + (for/list ([x (in-list xs)]) + (string-append* (apply-formatter formatter fmt-list x)))))) + +(defproc (time-ticks [#:formats formats (listof string?) (time-ticks-formats)]) ticks? + (ticks (time-ticks-layout) + (time-ticks-format #:formats formats))) + +;; =================================================================================================== +;; Byte and bit ticks + +;; "", Kilo, Mega, Giga, Tera, Peta, Exa, Zeta, Yotta +(define byte-suffixes #("B" "KB" "MB" "GB" "TB" "PB" "EB" "ZB" "YB")) +(define bit-suffixes #("b" "Kb" "Mb" "Gb" "Tb" "Pb" "Eb" "Zb" "Yb")) + +(defproc (bit/byte-ticks-format [#:size size (or/c 'byte 'bit) 'byte] + [#:kind kind (or/c 'CS 'SI) 'CS]) ticks-format/c + (λ (x-min x-max ts) + (with-exact-bounds + x-min x-max + (define suffixes (if (eq? size 'bit) bit-suffixes byte-suffixes)) + (define-values (base pow) (case kind + [(SI) (values 10 3)] + [else (values 2 10)])) + (define x-largest (max* (abs x-min) (abs x-max))) + (define b (floor-log/base (expt base pow) x-largest)) + (define format-str + (cond [(and (b . >= . 0) (b . < . (vector-length suffixes))) + (format "~a ~a" "~a" (vector-ref suffixes b))] + [else + (format "~a×~a~a ~a" "~a" + base (integer->superscript (* b pow)) (vector-ref suffixes 0))])) + (define unit (expt base (* b pow))) + (define digits (digits-for-range (/ x-min unit) (/ x-max unit))) + (for/list ([t (in-list ts)]) + (define unit-x (/ (pre-tick-value t) unit)) + (format format-str (real->plot-label unit-x digits #f)))))) + +(defproc (bit/byte-ticks [#:size size (or/c 'byte 'bit) 'byte] + [#:kind kind (or/c 'CS 'SI) 'CS]) ticks? + (define layout + (case kind + [(SI) (linear-ticks-layout #:base 10 #:divisors '(1 2 5))] + [else (linear-ticks-layout #:base 2 #:divisors '(1 2))])) + (ticks layout (bit/byte-ticks-format #:size size #:kind kind))) + +;; =================================================================================================== +;; Currency + +;; US "short scale" suffixes +(define us-currency-scale-suffixes '("" "K" "M" "B" "T")) +;; The UK officially uses the short scale now +;; Million is abbreviated "m" instead of "mn" because "mn" stands for minutes; also, the Daily +;; Telegraph Style Guide totally says to use "m" +(define uk-currency-scale-suffixes '("" "k" "m" "bn" "tr")) +;; European countries use the long scale: million, milliard, billion +(define eu-currency-scale-suffixes '("" "K" "M" "Md" "B")) +;; The larger the scale suffixes get, the less standardized they are; so we stop at trillion (short) + +;; US negative amounts are in parenthesis: +(define us-currency-format-strings '("~$~w.~f~s" "(~$~w.~f~s)" "~$0")) +;; The UK is more reasonable, using a negative sign for negative amounts: +(define uk-currency-format-strings '("~$~w.~f ~s" "-~$~w.~f ~s" "~$0")) +;; The more common EU format (e.g. France, Germany, Italy, Spain): +(define eu-currency-format-strings '("~w,~f ~s~$" "-~w,~f ~s~$" "0 ~$")) + +(defparam currency-scale-suffixes (listof string?) us-currency-scale-suffixes) +(defparam currency-format-strings (list/c string? string? string?) us-currency-format-strings) + +(struct amount-data (sign whole fractional unit suffix) #:transparent) + +(define (currency-formatter x-min x-max) + (λ (fmt data) + (case fmt + [(~$) (amount-data-sign data)] + [(~w) (number->string (amount-data-whole data))] + [(~f) (match-define (amount-data _sign _whole f unit _suffix) data) + (define digits (digits-for-range (/ x-min unit) (/ x-max unit))) + (cond [(= 1 unit) (substring (real->decimal-string* f 2 (max 2 digits)) 2)] + [(zero? f) "0"] + [else (substring (real->decimal-string* f 1 (max 1 digits)) 2)])] + [(~s) (amount-data-suffix data)] + [else #f]))) + +(defproc (currency-ticks-format [#:kind kind (or/c string? symbol?) 'USD]) ticks-format/c + (λ (x-min x-max ts) + (with-exact-bounds + x-min x-max + (define formatter (currency-formatter x-min x-max)) + (match-define (list positive-format-string negative-format-string zero-format-string) + (currency-format-strings)) + (define positive-format-list (parse-format-string positive-format-string)) + (define negative-format-list (parse-format-string negative-format-string)) + (define zero-format-list (parse-format-string zero-format-string)) + (define suffixes (list->vector (currency-scale-suffixes))) + (define n (vector-length suffixes)) + (define sign (cond [(string? kind) kind] + [else (hash-ref currency-code->sign kind (λ () (symbol->string kind)))])) + (define x-largest (max* (abs x-min) (abs x-max))) + (define b (let ([b (floor-log/base 1000 x-largest)]) + (if (b . < . 0) (+ b 1) b))) + (define suffix + (cond [(and (b . >= . 0) (b . < . n)) (vector-ref suffixes b)] + [else (format "×10~a" (integer->superscript (* b 3)))])) + (define unit + (cond [(= 0 (string-length suffix)) 1] + [else (expt 1000 b)])) + (for/list ([t (in-list ts)]) + (define x (pre-tick-value t)) + (define format-list (cond [(positive? x) positive-format-list] + [(negative? x) negative-format-list] + [else zero-format-list])) + (define unit-x (/ (abs x) unit)) + (string-append* + (apply-formatter formatter format-list + (amount-data sign (floor unit-x) (- unit-x (floor unit-x)) unit suffix))))))) + +(defproc (currency-ticks-layout) ticks-layout/c + (linear-ticks-layout #:base 10 #:divisors '(1 2 4 5))) + +(defproc (currency-ticks [#:kind kind (or/c string? symbol?) 'USD]) ticks? + (ticks (currency-ticks-layout) + (currency-ticks-format #:kind kind))) + +;; =================================================================================================== +;; Fractions + +(defparam fraction-ticks-base (and/c exact-integer? (>=/c 2)) 10) +(defparam fraction-ticks-divisors (listof exact-positive-integer?) '(1 2 3 4 5)) + +(define (format-fraction x) + (cond [(inexact? x) (format-fraction (inexact->exact x))] + [(x . < . 0) (format "-~a" (format-fraction (- x)))] + [(x . = . 0) "0"] + [(x . < . 1) (format "~a/~a" (numerator x) (denominator x))] + [else + (define d (denominator x)) + (cond [(d . = . 1) (format "~a" (numerator x))] + [else + (define w (floor x)) + (let ([x (- x w)]) + (format "~a ~a/~a" w (numerator x) (denominator x)))])])) + +(defproc (fraction-ticks-format) ticks-format/c + (λ (x-min x-max ts) + (for/list ([t (in-list ts)]) + (format-fraction (pre-tick-value t))))) + +(defproc (fraction-ticks [#:base base (and/c exact-integer? (>=/c 2)) (fraction-ticks-base)] + [#:divisors divisors (listof exact-positive-integer?) + (fraction-ticks-divisors)]) ticks? + (ticks (linear-ticks #:base base #:divisors divisors) + (fraction-ticks-format))) diff --git a/collects/plot/common/utils.rkt b/collects/plot/common/utils.rkt index 50dcacbafd..7decacee39 100644 --- a/collects/plot/common/utils.rkt +++ b/collects/plot/common/utils.rkt @@ -37,3 +37,23 @@ (let ([sorted-lst (sort lst)]) (make-hash (map cons sorted-lst (f sorted-lst))))) (map (λ (e) (hash-ref h e)) lst)) + +(define (transpose lsts) + (apply map list lsts)) + +(define (equal?* xs) + (cond [(empty? xs) #f] + [(empty? (rest xs)) #t] + [else (and (equal? (first xs) (second xs)) + (equal?* (rest xs)))])) + +(define (group-neighbors lst equiv?) + (reverse + (map reverse + (cond + [(empty? lst) empty] + [else + (for/fold ([res (list (list (first lst)))]) ([e (in-list (rest lst))]) + (cond + [(andmap (λ (e2) (equiv? e e2)) (first res)) (cons (cons e (first res)) (rest res))] + [else (list* (list e) res)]))])))) diff --git a/collects/plot/compat.rkt b/collects/plot/compat.rkt index 481bd46c55..e76fb7f258 100644 --- a/collects/plot/compat.rkt +++ b/collects/plot/compat.rkt @@ -6,13 +6,14 @@ ;; Plotting "common/contract.rkt" "common/contract-doc.rkt" - "common/ticks.rkt" + ;"common/ticks.rkt" "plot2d/area.rkt" "plot2d/renderer.rkt" "plot3d/area.rkt" "plot3d/renderer.rkt" (prefix-in new. (only-in "main.rkt" x-axis y-axis + default-x-ticks default-y-ticks default-z-ticks points error-bars vector-field plot-title plot-x-label plot-y-label plot-z-label plot-foreground plot-background @@ -72,8 +73,8 @@ [#:lncolor lncolor (list/c byte? byte? byte?) '(255 0 0)] [#:out-file out-file (or/c path-string? output-port? #f) #f] ) (is-a?/c image-snip%) - (define x-ticks (default-ticks-fun x-min x-max)) - (define y-ticks (default-ticks-fun y-min y-max)) + (define x-ticks (new.default-x-ticks x-min x-max)) + (define y-ticks (new.default-y-ticks y-min y-max)) (parameterize ([new.plot-title title] [new.plot-x-label x-label] @@ -110,9 +111,9 @@ [#:lncolor lncolor (list/c byte? byte? byte?) '(255 0 0)] [#:out-file out-file (or/c path-string? output-port? #f) #f] ) (is-a?/c image-snip%) - (define x-ticks (default-ticks-fun x-min x-max)) - (define y-ticks (default-ticks-fun y-min y-max)) - (define z-ticks (default-ticks-fun z-min z-max)) + (define x-ticks (new.default-x-ticks x-min x-max)) + (define y-ticks (new.default-y-ticks y-min y-max)) + (define z-ticks (new.default-z-ticks z-min z-max)) (parameterize ([new.plot-title title] [new.plot-x-label x-label] diff --git a/collects/plot/main.rkt b/collects/plot/main.rkt index 5365ba612e..2549c82bec 100644 --- a/collects/plot/main.rkt +++ b/collects/plot/main.rkt @@ -12,8 +12,10 @@ (all-from-out "common/contract.rkt")) (require "common/axis-transform.rkt") -(provide invertible-function? - id-transform log-transform cbrt-transform hand-drawn-transform) +(provide (all-from-out "common/axis-transform.rkt")) + +(require "common/ticks.rkt") +(provide (all-from-out "common/ticks.rkt")) (require "common/math.rkt") (provide (contract-out (struct ivl ([min real?] [max real?])))) diff --git a/collects/plot/plot2d/area.rkt b/collects/plot/plot2d/area.rkt index 8ed1256b0c..c0ce4f166c 100644 --- a/collects/plot/plot2d/area.rkt +++ b/collects/plot/plot2d/area.rkt @@ -1,6 +1,6 @@ #lang racket/base -(require racket/draw racket/class racket/contract racket/match racket/math racket/list +(require racket/draw racket/class racket/contract racket/match racket/math racket/list racket/string "../common/area.rkt" "../common/ticks.rkt" "../common/vector.rkt" @@ -10,14 +10,14 @@ "../common/sample.rkt" "../common/legend.rkt" "../common/parameters.rkt" - "clip.rkt" - "sample.rkt") + "../common/utils.rkt" + "clip.rkt") (provide 2d-plot-area%) (define 2d-plot-area% (class plot-area% - (init-field x-ticks y-ticks x-min x-max y-min y-max) + (init-field rx-ticks ry-ticks x-min x-max y-min y-max) (init dc dc-x-min dc-y-min dc-x-size dc-y-size) (inherit set-alpha set-pen set-major-pen set-minor-pen set-brush set-background set-text-foreground @@ -31,25 +31,22 @@ (reset-drawing-params) - (define max-y-tick-label-width - (for/fold ([max-w 0]) ([t (in-list y-ticks)]) - (cond [(tick-major? t) (define-values (w h _1 _2) - (get-text-extent (tick-label t))) - (max max-w w)] - [else max-w]))) + (define x-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) rx-ticks)) + (define y-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max)) ry-ticks)) - (define char-height (get-char-height)) + (define (max-tick-label-width ts) + (apply max 0 (for/list ([t (in-list ts)] #:when (pre-tick-major? t)) + (get-text-width (tick-label t))))) + (define max-x-tick-label-width (max-tick-label-width x-ticks)) + (define max-y-tick-label-width (max-tick-label-width y-ticks)) + + (define char-height (get-char-height)) (define last-x-tick-label-width - (cond [(empty? x-ticks) 0] - [else - (define last-x-tick (argmax tick-p x-ticks)) - (cond [(tick-major? last-x-tick) (define-values (w _1 _2 _3) - (get-text-extent - (tick-label last-x-tick))) - w] - [else 0])])) + (let ([x-ticks (filter pre-tick-major? x-ticks)]) + (cond [(empty? x-ticks) 0] + [else (get-text-width (tick-label (argmax pre-tick-value x-ticks)))]))) (define dc-x-max (+ dc-x-min dc-x-size)) (define dc-y-max (+ dc-y-min dc-y-size)) @@ -169,18 +166,19 @@ (equal? (plot-y-transform) id-transform))) (define plot->view - (cond [identity-transforms? (λ (v) v)] - [else - (match-define (invertible-function fx _) ((plot-x-transform) x-min x-max)) - (match-define (invertible-function fy _) ((plot-y-transform) y-min y-max)) - (λ (v) - (match-define (vector x y) v) - (vector (fx x) (fy y)))])) + (cond + [identity-transforms? (λ (v) v)] + [else + (match-define (invertible-function fx _) (apply-transform (plot-x-transform) x-min x-max)) + (match-define (invertible-function fy _) (apply-transform (plot-y-transform) y-min y-max)) + (λ (v) + (match-define (vector x y) v) + (vector (fx x) (fy y)))])) (define/public (plot->dc v) (view->dc (plot->view v))) - ;; ------------------------------------------------------------------------- + ;; =============================================================================================== ;; Plot decoration (define (draw-borders) @@ -189,33 +187,56 @@ (draw-rectangle (vector area-x-min area-y-min) (vector area-x-max area-y-max))) + (define (collapse-ticks ts dc-pos) + (define (dc-dist t1 t2) (abs (- (dc-pos t1) (dc-pos t2)))) + (let ([ts (sort ts < #:key pre-tick-value)]) + (define tss + (group-neighbors ts (λ (t1 t2) ((dc-dist t1 t2) . <= . (* 2 (plot-line-width)))))) + (for/list ([ts (in-list tss)]) + (match-define (list (tick xs majors labels) ...) ts) + (define x (let ([xs (remove-duplicates xs)]) + (/ (apply + xs) (length xs)))) + (define major? (ormap values majors)) + (define label (string-join (remove-duplicates (map tick-label (filter pre-tick-major? ts))) + "|")) + (tick x major? label)))) + + (define collapsed-x-ticks + (collapse-ticks x-ticks (λ (t) (vector-ref (plot->dc (vector (pre-tick-value t) y-min)) 0)))) + (define collapsed-y-ticks + (collapse-ticks y-ticks (λ (t) (vector-ref (plot->dc (vector x-min (pre-tick-value t))) 1)))) + (define (draw-x-ticks) - (define half (* 1/2 (plot-tick-size))) - (for ([t (in-list x-ticks)]) - (match-define (tick x x-str major?) t) + (define radius (* 1/2 (plot-tick-size))) + (define 1/2radius (* 1/2 radius)) + (for ([t (in-list collapsed-x-ticks)]) + (match-define (tick x major? _) t) (if major? (set-major-pen) (set-minor-pen)) - (put-tick (vector x y-min) half 1/2pi) - (put-tick (vector x y-max) half 1/2pi))) + (put-tick (vector x y-min) (if major? radius 1/2radius) 1/2pi) + (put-tick (vector x y-max) (if major? radius 1/2radius) 1/2pi))) (define (draw-y-ticks) - (define half (* 1/2 (plot-tick-size))) - (for ([t (in-list y-ticks)]) - (match-define (tick y y-str major?) t) + (define radius (* 1/2 (plot-tick-size))) + (define 1/2radius (* 1/2 radius)) + (for ([t (in-list collapsed-y-ticks)]) + (match-define (tick y major? _) t) (if major? (set-major-pen) (set-minor-pen)) - (put-tick (vector x-min y) half 0) - (put-tick (vector x-max y) half 0))) + (put-tick (vector x-min y) (if major? radius 1/2radius) 0) + (put-tick (vector x-max y) (if major? radius 1/2radius) 0))) (define (draw-x-tick-labels) (define offset (vector 0 (+ (pen-gap) (* 1/2 (plot-tick-size))))) - (for ([t (in-list (filter tick-major? x-ticks))]) - (match-define (tick x x-str major?) t) - (draw-text x-str (v+ (plot->dc (vector x y-min)) offset) 'top))) + (for ([t (in-list collapsed-x-ticks)]) + (match-define (tick x major? label) t) + (when (and major? ((string-length label) . > . 0)) + (draw-text label (v+ (plot->dc (vector x y-min)) offset) 'top)))) (define (draw-y-tick-labels) (define offset (vector (+ (pen-gap) (* 1/2 (plot-tick-size))) 0)) - (for ([t (in-list (filter tick-major? y-ticks))]) - (match-define (tick y y-str major?) t) - (draw-text y-str (v- (plot->dc (vector x-min y)) offset) 'right))) + (for ([t (in-list collapsed-y-ticks)]) + (match-define (tick y major? label) t) + (when (and major? ((string-length label) . > . 0)) + (draw-text label (v- (plot->dc (vector x-min y)) offset) 'right)))) (define (draw-title) (define-values (title-x-size _1 _2 _3) diff --git a/collects/plot/plot2d/contour.rkt b/collects/plot/plot2d/contour.rkt index 777dfe6f91..f18acfbcac 100644 --- a/collects/plot/plot2d/contour.rkt +++ b/collects/plot/plot2d/contour.rkt @@ -6,14 +6,15 @@ "../common/math.rkt" "../common/draw.rkt" "../common/marching-squares.rkt" - "../common/contract.rkt" "../common/contract-doc.rkt" + "../common/contract.rkt" + "../common/contract-doc.rkt" "../common/legend.rkt" "../common/sample.rkt" "../common/parameters.rkt" "../common/ticks.rkt" "../common/vector.rkt" - "renderer.rkt" - "sample.rkt") + "../common/format.rkt" + "renderer.rkt") (provide contours contour-intervals) @@ -30,10 +31,7 @@ (when (empty? zs) (return empty)) (values (apply min* zs) (apply max* zs)))) - (define zs - (cond [(list? levels) levels] - [(eq? levels 'auto) (auto-contour-zs z-min z-max)] - [else (linear-seq z-min z-max levels #:start? #f #:end? #f)])) + (match-define (list (tick zs _ labels) ...) (contour-ticks z-min z-max levels #f)) (define cs (maybe-apply/list colors zs)) (define ws (maybe-apply/list widths zs)) @@ -64,7 +62,7 @@ (match-define (vector x1 y1 x2 y2) (scale-normalized-line line xa xb ya yb)) (send area put-line (vector x1 y1) (vector x2 y2))))) - (cond [label (line-legend-entries label zs colors widths styles)] + (cond [label (line-legend-entries label zs labels colors widths styles)] [else empty]))) (defproc (contours @@ -100,12 +98,8 @@ (when (empty? flat-zs) (return empty)) (values (apply min* flat-zs) (apply max* flat-zs)))) - (define contour-zs - (cond [(list? levels) levels] - [(eq? levels 'auto) (auto-contour-zs z-min z-max)] - [else (linear-seq z-min z-max levels #:start? #f #:end? #f)])) + (match-define (list (tick zs _ labels) ...) (contour-ticks z-min z-max levels #t)) - (define zs (append (list z-min) contour-zs (list z-max))) (define cs (map ->brush-color (maybe-apply/list colors zs))) (define fss (map ->brush-style (maybe-apply/list styles zs))) (define pss (map (λ (fill-style) (if (eq? fill-style 'solid) 'solid 'transparent)) fss)) @@ -163,8 +157,7 @@ area) (cond [label (contour-intervals-legend-entries - label z-min z-max contour-zs - cs fss cs '(1) pss contour-colors contour-widths contour-styles)] + label zs labels cs fss cs '(1) pss contour-colors contour-widths contour-styles)] [else empty]))) (defproc (contour-intervals diff --git a/collects/plot/plot2d/decoration.rkt b/collects/plot/plot2d/decoration.rkt index 7f2b2335d6..a624901362 100644 --- a/collects/plot/plot2d/decoration.rkt +++ b/collects/plot/plot2d/decoration.rkt @@ -6,19 +6,21 @@ "../common/ticks.rkt" "../common/math.rkt" "../common/format.rkt" - "../common/contract.rkt" "../common/contract-doc.rkt" + "../common/contract.rkt" + "../common/contract-doc.rkt" "../common/legend.rkt" "../common/vector.rkt" "../common/area.rkt" "../common/sample.rkt" "../common/parameters.rkt" + "../common/axis-transform.rkt" "renderer.rkt" "area.rkt" "line.rkt" "interval.rkt" "point.rkt" "contour.rkt" - "sample.rkt") + "clip.rkt") (provide x-axis y-axis axes polar-axes @@ -38,72 +40,128 @@ (define x-ticks (send area get-x-ticks)) (define half (* 1/2 (plot-tick-size))) - (send area set-minor-pen) + (send area set-alpha 1/2) + (send area set-major-pen) (send area put-line (vector x-min y) (vector x-max y)) (when ticks? (for ([t (in-list x-ticks)]) - (match-define (tick x _ major?) t) + (match-define (tick x major? _) t) (if major? (send area set-major-pen) (send area set-minor-pen)) (send area put-tick (vector x y) half 1/2pi))) empty) +(define ((x-axis-ticks-fun y) x-min x-max y-min y-max) + (define digits (digits-for-range y-min y-max)) + (values empty (list (tick y #t (real->plot-label y digits))))) + +(defproc (x-axis [y real? 0] [add-y-tick? boolean? #f] + [#:ticks? ticks? boolean? (x-axis-ticks?)]) renderer2d? + (renderer2d (x-axis-render-proc y ticks?) + (if add-y-tick? (x-axis-ticks-fun y) null-2d-ticks-fun) + null-2d-bounds-fun #f #f #f #f)) + (define ((y-axis-render-proc x ticks?) area) (define y-min (send area get-y-min)) (define y-max (send area get-y-max)) (define y-ticks (send area get-y-ticks)) (define half (* 1/2 (plot-tick-size))) - (send area set-minor-pen) + (send area set-alpha 1/2) + (send area set-major-pen) (send area put-line (vector x y-min) (vector x y-max)) (when ticks? (for ([t (in-list y-ticks)]) - (match-define (tick y _ major?) t) + (match-define (tick y major? _) t) (if major? (send area set-major-pen) (send area set-minor-pen)) (send area put-tick (vector x y) half 0))) empty) -(defproc (x-axis [y real? 0] [#:ticks? ticks? boolean? (x-axis-ticks?)]) renderer2d? - (renderer2d (x-axis-render-proc y ticks?) null-2d-ticks-fun null-2d-bounds-fun #f #f #f #f)) +(define ((y-axis-ticks-fun x) x-min x-max y-min y-max) + (define digits (digits-for-range x-min x-max)) + (values (list (tick x #t (real->plot-label x digits))) empty)) -(defproc (y-axis [x real? 0] [#:ticks? ticks? boolean? (y-axis-ticks?)]) renderer2d? - (renderer2d (y-axis-render-proc x ticks?) null-2d-ticks-fun null-2d-bounds-fun #f #f #f #f)) +(defproc (y-axis [x real? 0] [add-x-tick? boolean? #f] + [#:ticks? ticks? boolean? (y-axis-ticks?)]) renderer2d? + (renderer2d (y-axis-render-proc x ticks?) + (if add-x-tick? (y-axis-ticks-fun x) null-2d-ticks-fun) + null-2d-bounds-fun #f #f #f #f)) -(defproc (axes [x real? 0] [y real? 0] +(defproc (axes [x real? 0] [y real? 0] [add-x-tick? boolean? #f] [add-y-tick? boolean? #f] [#:x-ticks? x-ticks? boolean? (x-axis-ticks?)] [#:y-ticks? y-ticks? boolean? (y-axis-ticks?)] ) (listof renderer2d?) - (list (x-axis y #:ticks? x-ticks?) - (y-axis x #:ticks? y-ticks?))) + (list (x-axis y add-y-tick? #:ticks? x-ticks?) + (y-axis x add-x-tick? #:ticks? y-ticks?))) ;; =================================================================================================== ;; Polar axes +(define (build-polar-axes num x-min x-max y-min y-max) + (define step (/ (* 2 pi) num)) + (define θs (build-list num (λ (n) (* n step)))) + (define max-r (max (vmag (vector x-min y-min)) (vmag (vector x-min y-max)) + (vmag (vector x-max y-max)) (vmag (vector x-max y-min)))) + (define-values (r-mins r-maxs) + (for/lists (r-mins r-maxs) ([θ (in-list θs)]) + (define-values (v1 v2) + (clip-line (vector 0 0) (vector (* max-r (cos θ)) (* max-r (sin θ))) + x-min x-max y-min y-max)) + (values (if v1 (vmag v1) #f) + (if v2 (vmag v2) #f)))) + (for/lists (θs r-mins r-maxs) ([θ (in-list θs)] [r-min (in-list r-mins)] [r-max (in-list r-maxs)] + #:when (and r-min r-max (not (= r-min r-max)))) + (values θ r-min r-max))) + (define ((polar-axes-render-proc num ticks?) area) (define x-min (send area get-x-min)) (define x-max (send area get-x-max)) (define y-min (send area get-y-min)) (define y-max (send area get-y-max)) - (define step (/ (* 2 pi) num)) - (define θs (build-list num (λ (n) (* n step)))) + (define-values (θs r-mins r-maxs) (build-polar-axes num x-min x-max y-min y-max)) - (send area set-minor-pen) - (let ([r (* 2 (max (- x-min) x-max (- y-min) y-max))]) - (for ([θ (in-list θs)]) - (send area put-line (vector 0 0) (vector (* r (cos θ)) (* r (sin θ)))))) + ;; Draw the axes + (send area set-alpha 1/2) + (send area set-major-pen) + (for ([θ (in-list θs)] [r-min (in-list r-mins)] [r-max (in-list r-maxs)]) + (send area put-line + (vector (* r-min (cos θ)) (* r-min (sin θ))) + (vector (* r-max (cos θ)) (* r-max (sin θ))))) - (define ticks (remove-duplicates (map (λ (t) (abs (tick-p t))) - (send area get-x-ticks)))) - - (send area set-minor-pen 'long-dash) - (for ([r (in-list ticks)]) - (define pts (for/list ([θ (in-list (linear-seq 0 (* 2 pi) 100))]) - (vector (* r (cos θ)) (* r (sin θ))))) - (send area put-lines pts)) + (when ticks? + (define corner-rs + (list (vmag (vector x-min y-min)) (vmag (vector x-min y-max)) + (vmag (vector x-max y-max)) (vmag (vector x-max y-min)))) + (define r-min (if (and (<= x-min 0 x-max) (<= y-min 0 y-max)) 0 (apply min corner-rs))) + (define r-max (apply max corner-rs)) + (define ts ((linear-ticks) r-min r-max (polar-axes-max-ticks) id-transform)) + + (send area set-alpha 1/2) + (for ([t (in-list ts)]) + (match-define (tick r major? label) t) + (if major? (send area set-major-pen) (send area set-minor-pen 'long-dash)) + (define pts (for/list ([θ (in-list (linear-seq 0 (* 2 pi) 100))]) + (vector (* r (cos θ)) (* r (sin θ))))) + (send area put-lines pts)) + + (when (not (empty? θs)) + ;; find the longest axis + (define mag (expt 10 (- (digits-for-range r-min r-max)))) + (match-define (list mθ mr-min mr-max) + ;; find the longest, rounded to drown out floating-point error + (argmax (λ (lst) (* (round (/ (- (third lst) (second lst)) mag)) mag)) + (map list θs r-mins r-maxs))) + + (send area set-alpha 1) + (for ([t (in-list ts)]) + (match-define (tick r major? label) t) + (when (and major? (<= mr-min r mr-max)) + (send area put-text label (vector (* r (cos mθ)) (* r (sin mθ))) + 'center 0 #:outline? #t))))) empty) @@ -121,9 +179,10 @@ (define y-max (send area get-y-max)) (define x-ticks (send area get-x-ticks)) - (send area set-pen (plot-foreground) (* 1/2 (plot-line-width)) 'long-dash) + (send area set-alpha 1/2) (for ([t (in-list x-ticks)]) - (match-define (tick x _ major?) t) + (match-define (tick x major? _) t) + (if major? (send area set-major-pen) (send area set-minor-pen 'long-dash)) (send area put-line (vector x y-min) (vector x y-max))) empty) @@ -133,9 +192,10 @@ (define x-max (send area get-x-max)) (define y-ticks (send area get-y-ticks)) - (send area set-pen (plot-foreground) (* 1/2 (plot-line-width)) 'long-dash) + (send area set-alpha 1/2) (for ([t (in-list y-ticks)]) - (match-define (tick y _ major?) t) + (match-define (tick y major? _) t) + (if major? (send area set-major-pen) (send area set-minor-pen 'long-dash)) (send area put-line (vector x-min y) (vector x-max y))) empty) diff --git a/collects/plot/plot2d/interval.rkt b/collects/plot/plot2d/interval.rkt index 03d81bda6a..41b21717aa 100644 --- a/collects/plot/plot2d/interval.rkt +++ b/collects/plot/plot2d/interval.rkt @@ -5,14 +5,14 @@ (require racket/contract racket/class racket/match racket/math racket/list "../common/math.rkt" "../common/vector.rkt" - "../common/contract.rkt" "../common/contract-doc.rkt" + "../common/contract.rkt" + "../common/contract-doc.rkt" "../common/legend.rkt" "../common/draw.rkt" "../common/sample.rkt" "../common/parameters.rkt" "renderer.rkt" - "bounds.rkt" - "sample.rkt") + "bounds.rkt") (provide lines-interval parametric-interval polar-interval function-interval inverse-interval) diff --git a/collects/plot/plot2d/kde.rkt b/collects/plot/plot2d/kde.rkt index c9864fe080..fd0c6e6fb8 100644 --- a/collects/plot/plot2d/kde.rkt +++ b/collects/plot/plot2d/kde.rkt @@ -1,7 +1,8 @@ #lang racket/base (require racket/flonum racket/list racket/promise racket/math racket/contract - "../common/contract.rkt" "../common/contract-doc.rkt" + "../common/contract.rkt" + "../common/contract-doc.rkt" "../common/math.rkt" "../common/utils.rkt" "../common/sample.rkt" diff --git a/collects/plot/plot2d/line.rkt b/collects/plot/plot2d/line.rkt index 470b23e4d5..fcfd62a39a 100644 --- a/collects/plot/plot2d/line.rkt +++ b/collects/plot/plot2d/line.rkt @@ -6,13 +6,13 @@ "../common/math.rkt" "../common/vector.rkt" "../common/ticks.rkt" - "../common/contract.rkt" "../common/contract-doc.rkt" + "../common/contract.rkt" + "../common/contract-doc.rkt" "../common/legend.rkt" "../common/sample.rkt" "../common/parameters.rkt" "renderer.rkt" - "bounds.rkt" - "sample.rkt") + "bounds.rkt") (provide lines parametric polar function inverse) diff --git a/collects/plot/plot2d/plot.rkt b/collects/plot/plot2d/plot.rkt index 9555afbb34..bdd0ab6f3d 100644 --- a/collects/plot/plot2d/plot.rkt +++ b/collects/plot/plot2d/plot.rkt @@ -131,6 +131,9 @@ (define x-transform (plot-x-transform)) (define y-transform (plot-y-transform)) (define z-transform (plot-z-transform)) + (define x-ticks (plot-x-ticks)) + (define y-ticks (plot-y-ticks)) + (define z-ticks (plot-z-ticks)) (define animating? (plot-animating?)) (dc (λ (dc x y) @@ -146,6 +149,9 @@ [plot-x-transform x-transform] [plot-y-transform y-transform] [plot-z-transform z-transform] + [plot-x-ticks x-ticks] + [plot-y-ticks y-ticks] + [plot-z-ticks z-ticks] [plot-animating? animating?]) (plot/dc renderer-tree dc x y width height #:x-min x-min #:x-max x-max #:y-min y-min #:y-max y-max diff --git a/collects/plot/plot2d/rectangle.rkt b/collects/plot/plot2d/rectangle.rkt index 881147a535..af425ee161 100644 --- a/collects/plot/plot2d/rectangle.rkt +++ b/collects/plot/plot2d/rectangle.rkt @@ -101,8 +101,8 @@ (define ((discrete-histogram-ticks-fun cats tick-xs) _x-min _x-max y-min y-max) (define x-ticks (for/list ([cat (in-list cats)] [x (in-list tick-xs)]) - (tick x (->plot-label cat) #t))) - (values x-ticks (default-ticks-fun y-min y-max))) + (tick x #t (->plot-label cat)))) + (values x-ticks (default-y-ticks y-min y-max))) (defproc (discrete-histogram [cat-vals (listof (vector/c any/c real?))] diff --git a/collects/plot/plot2d/renderer.rkt b/collects/plot/plot2d/renderer.rkt index 2a79af1b6b..6d2312faaf 100644 --- a/collects/plot/plot2d/renderer.rkt +++ b/collects/plot/plot2d/renderer.rkt @@ -1,9 +1,11 @@ #lang racket/base (require racket/list racket/match racket/contract - "../common/contract.rkt" "../common/contract-doc.rkt" + "../common/contract.rkt" + "../common/contract-doc.rkt" "../common/math.rkt" - "../common/ticks.rkt") + "../common/ticks.rkt" + "../common/parameters.rkt") (provide (all-defined-out)) @@ -52,5 +54,5 @@ (defproc (default-2d-ticks-fun [x-min real?] [x-max real?] [y-min real?] [y-max real?] ) (values (listof tick?) (listof tick?)) - (values (default-ticks-fun x-min x-max) - (default-ticks-fun y-min y-max))) + (values (default-x-ticks x-min x-max) + (default-y-ticks y-min y-max))) diff --git a/collects/plot/plot2d/sample.rkt b/collects/plot/plot2d/sample.rkt deleted file mode 100644 index ebca302ac5..0000000000 --- a/collects/plot/plot2d/sample.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket/base - -(require racket/contract - "../common/contract.rkt" - "../common/sample.rkt" - "../common/parameters.rkt") - -(provide (all-defined-out)) - -(define function->sampler (make-function->sampler plot-x-transform)) -(define inverse->sampler (make-function->sampler plot-y-transform)) -(define 2d-function->sampler (make-2d-function->sampler plot-x-transform plot-y-transform)) diff --git a/collects/plot/plot3d/area.rkt b/collects/plot/plot3d/area.rkt index c000c4c0e7..2f7dc955f2 100644 --- a/collects/plot/plot3d/area.rkt +++ b/collects/plot/plot3d/area.rkt @@ -11,14 +11,13 @@ "../common/parameters.rkt" "matrix.rkt" "shape.rkt" - "clip.rkt" - "sample.rkt") + "clip.rkt") (provide 3d-plot-area%) (define 3d-plot-area% (class plot-area% - (init-field x-ticks y-ticks z-ticks x-min x-max y-min y-max z-min z-max) + (init-field rx-ticks ry-ticks rz-ticks x-min x-max y-min y-max z-min z-max) (init dc dc-x-min dc-y-min dc-x-size dc-y-size) (inherit set-alpha set-pen set-major-pen set-minor-pen set-brush set-background set-text-foreground @@ -32,6 +31,10 @@ (reset-drawing-params) + (define x-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) rx-ticks)) + (define y-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max)) ry-ticks)) + (define z-ticks (filter (λ (t) (<= z-min (pre-tick-value t) z-max)) rz-ticks)) + (define char-height (get-char-height)) (define clipping? #f) @@ -104,19 +107,20 @@ (equal? (plot-z-transform) id-transform))) (define center - (cond [identity-axis-transforms? - (λ (v) - (match-define (vector x y z) v) - (vector (- x x-mid) (- y y-mid) (- z z-mid)))] - [else - (match-define (invertible-function fx _) ((plot-x-transform) x-min x-max)) - (match-define (invertible-function fy _) ((plot-y-transform) y-min y-max)) - (match-define (invertible-function fz _) ((plot-z-transform) z-min z-max)) - (λ (v) - (match-define (vector x y z) v) - (if do-axis-transforms? - (vector (- (fx x) x-mid) (- (fy y) y-mid) (- (fz z) z-mid)) - (vector (- x x-mid) (- y y-mid) (- z z-mid))))])) + (cond + [identity-axis-transforms? + (λ (v) + (match-define (vector x y z) v) + (vector (- x x-mid) (- y y-mid) (- z z-mid)))] + [else + (match-define (invertible-function fx _) (apply-transform (plot-x-transform) x-min x-max)) + (match-define (invertible-function fy _) (apply-transform (plot-y-transform) y-min y-max)) + (match-define (invertible-function fz _) (apply-transform (plot-z-transform) z-min z-max)) + (λ (v) + (match-define (vector x y z) v) + (if do-axis-transforms? + (vector (- (fx x) x-mid) (- (fy y) y-mid) (- (fz z) z-mid)) + (vector (- x x-mid) (- y y-mid) (- z z-mid))))])) (define transform-matrix/no-rho (m3* (m3-rotate-z theta) (m3-scale (/ x-size) (/ y-size) (/ z-size)))) @@ -187,13 +191,12 @@ (define x-labels-y-min? ((cos theta) . >= . 0)) (define y-labels-x-min? ((sin theta) . >= . 0)) - (define max-x-tick-label-width - (cond [(empty? x-ticks) 0] - [else (apply max (map (λ (t) (get-text-width (tick-label t))) x-ticks))])) + (define (max-tick-label-width ts) + (apply max 0 (for/list ([t (in-list ts)] #:when (pre-tick-major? t)) + (get-text-width (tick-label t))))) - (define max-y-tick-label-width - (cond [(empty? y-ticks) 0] - [else (apply max (map (λ (t) (get-text-width (tick-label t))) y-ticks))])) + (define max-x-tick-label-width (max-tick-label-width x-ticks)) + (define max-y-tick-label-width (max-tick-label-width y-ticks)) ;; Label drawing parameters @@ -242,10 +245,10 @@ [(s . < . (sin (degrees->radians 67.5))) (if x-labels-y-min? 'top-left 'top-right)] [else (if x-labels-y-min? 'top-left 'top-right)])) - (define fx (invertible-function-f ((plot-x-transform) x-min x-max))) - (for/list ([t (in-list (filter tick-major? x-ticks))]) - (match-define (tick x x-str major?) t) - (list x-str (v+ (plot->dc (vector (fx x) y z-min)) offset) anchor 0))) + (define fx (invertible-function-f (apply-transform (plot-x-transform) x-min x-max))) + (for/list ([t (in-list x-ticks)] #:when (pre-tick-major? t)) + (match-define (tick x _ label) t) + (list label (v+ (plot->dc (vector (fx x) y z-min)) offset) anchor 0))) (define (get-y-tick-label-params) (define x-axis-angle (plot-dir->dc-angle (vector 1 0 0))) @@ -261,10 +264,10 @@ [(c . > . (cos (degrees->radians 157.5))) (if y-labels-x-min? 'top-left 'top-right)] [else (if y-labels-x-min? 'top-left 'top-right)])) - (define fy (invertible-function-f ((plot-y-transform) y-min y-max))) - (for/list ([t (in-list (filter tick-major? y-ticks))]) - (match-define (tick y y-str major?) t) - (list y-str (v+ (plot->dc (vector x (fy y) z-min)) offset) anchor 0))) + (define fy (invertible-function-f (apply-transform (plot-y-transform) y-min y-max))) + (for/list ([t (in-list y-ticks)] #:when (pre-tick-major? t)) + (match-define (tick y _ label) t) + (list label (v+ (plot->dc (vector x (fy y) z-min)) offset) anchor 0))) (define (get-z-tick-label-params) (define dist (+ (pen-gap) (* 1/2 (plot-tick-size)))) @@ -272,10 +275,10 @@ (define x (if x-labels-y-min? x-min x-max)) (define y (if y-labels-x-min? y-max y-min)) - (define fz (invertible-function-f ((plot-z-transform) z-min z-max))) - (for/list ([t (in-list (filter tick-major? z-ticks))]) - (match-define (tick z z-str major?) t) - (list z-str (v+ (plot->dc (vector x y (fz z))) offset) 'bottom-right 0))) + (define fz (invertible-function-f (apply-transform (plot-z-transform) z-min z-max))) + (for/list ([t (in-list z-ticks)] #:when (pre-tick-major? t)) + (match-define (tick z _ label) t) + (list label (v+ (plot->dc (vector x y (fz z))) offset) 'bottom-right 0))) (define (get-label-params) (append (if (plot-x-label) (list (get-x-label-params)) empty) @@ -351,37 +354,40 @@ (define (put-x-ticks) (define radius (* 1/2 (plot-tick-size))) + (define 1/2radius (* 1/2 radius)) (define angle (plot-dir->dc-angle (vector 0 1 0))) - (define fx (invertible-function-f ((plot-x-transform) x-min x-max))) + (define fx (invertible-function-f (apply-transform (plot-x-transform) x-min x-max))) (for ([t (in-list x-ticks)]) - (match-define (tick x x-str major?) t) + (match-define (tick x major? _) t) (if major? (put-major-pen) (put-minor-pen)) ; x ticks on the y-min and y-max border (for ([y (list y-min y-max)]) - (put-tick (vector (fx x) y z-min) radius angle)))) + (put-tick (vector (fx x) y z-min) (if major? radius 1/2radius) angle)))) (define (put-y-ticks) (define radius (* 1/2 (plot-tick-size))) + (define 1/2radius (* 1/2 radius)) (define angle (plot-dir->dc-angle (vector 1 0 0))) - (define fy (invertible-function-f ((plot-y-transform) y-min y-max))) + (define fy (invertible-function-f (apply-transform (plot-y-transform) y-min y-max))) (for ([t (in-list y-ticks)]) - (match-define (tick y y-str major?) t) + (match-define (tick y major? _) t) (if major? (put-major-pen) (put-minor-pen)) ; y ticks on the x-min border (for ([x (list x-min x-max)]) - (put-tick (vector x (fy y) z-min) radius angle)))) + (put-tick (vector x (fy y) z-min) (if major? radius 1/2radius) angle)))) (define (put-z-ticks) (define radius (* 1/2 (plot-tick-size))) + (define 1/2radius (* 1/2 radius)) (define angle 0) - (define fz (invertible-function-f ((plot-z-transform) z-min z-max))) + (define fz (invertible-function-f (apply-transform (plot-z-transform) z-min z-max))) (for ([t (in-list z-ticks)]) - (match-define (tick z z-str major?) t) + (match-define (tick z major? _) t) (if major? (put-major-pen) (put-minor-pen)) ; z ticks on all four axes (for* ([x (list x-min x-max)] [y (list y-min y-max)]) - (put-tick (vector x y (fz z)) radius angle)))) + (put-tick (vector x y (fz z)) (if major? radius 1/2radius) angle)))) (define (draw-labels) (for ([params (in-list (get-label-params))]) @@ -656,7 +662,7 @@ ;; Right (if ((sin theta) . < . 0) (list (vector x2 y1 z1) (vector x2 y2 z1) (vector x2 y2 z2) (vector x2 y1 z2)) - empty)) + empty)) c))) (define/public (put-glyphs vs symbol size) diff --git a/collects/plot/plot3d/contour.rkt b/collects/plot/plot3d/contour.rkt index 05ed7646e5..204a793418 100644 --- a/collects/plot/plot3d/contour.rkt +++ b/collects/plot/plot3d/contour.rkt @@ -1,7 +1,8 @@ #lang racket/base (require racket/class racket/match racket/list racket/flonum racket/contract - "../common/contract.rkt" "../common/contract-doc.rkt" + "../common/contract.rkt" + "../common/contract-doc.rkt" "../common/math.rkt" "../common/vector.rkt" "../common/marching-squares.rkt" @@ -11,7 +12,6 @@ "../common/sample.rkt" "../common/parameters.rkt" "renderer.rkt" - "sample.rkt" "bounds.rkt") (provide contours3d contour-intervals3d) @@ -23,10 +23,8 @@ (define-values (x-min x-max y-min y-max z-min z-max) (send area get-bounds)) (match-define (list xs ys zss) (f x-min x-max (animated-samples samples) y-min y-max (animated-samples samples))) - (define zs - (cond [(list? levels) levels] - [(eq? levels 'auto) (auto-contour-zs z-min z-max)] - [else (linear-seq z-min z-max levels #:start? #f #:stop? #f)])) + + (match-define (list (tick zs _ labels) ...) (contour-ticks z-min z-max levels #f)) (define cs (maybe-apply/list colors zs)) (define ws (maybe-apply/list widths zs)) @@ -61,7 +59,7 @@ (center-coord (list (vector xa ya z1) (vector xb ya z2) (vector xa yb z3) (vector xb yb z4))))))) - (cond [label (line-legend-entries label zs colors widths styles)] + (cond [label (line-legend-entries label zs labels colors widths styles)] [else empty])) (defproc (contours3d @@ -94,12 +92,8 @@ (match-define (list xs ys zss) (f x-min x-max (animated-samples samples) y-min y-max (animated-samples samples))) - (define contour-zs - (cond [(list? levels) levels] - [(eq? levels 'auto) (auto-contour-zs z-min z-max)] - [else (linear-seq z-min z-max levels #:start? #f #:end? #f)])) + (match-define (list (tick zs _ labels) ...) (contour-ticks z-min z-max levels #t)) - (define zs (append (list z-min) contour-zs (list z-max))) (define cs (maybe-apply/list colors zs)) (define lcs (maybe-apply/list line-colors zs)) (define lws (maybe-apply/list line-widths zs)) @@ -140,7 +134,7 @@ area) (cond [label (contour-intervals-legend-entries - label z-min z-max contour-zs colors '(solid) line-colors line-widths line-styles + label zs labels colors '(solid) line-colors line-widths line-styles contour-colors contour-widths contour-styles)] [else empty])) diff --git a/collects/plot/plot3d/isosurface.rkt b/collects/plot/plot3d/isosurface.rkt index e8b745fd73..ec1e50102f 100644 --- a/collects/plot/plot3d/isosurface.rkt +++ b/collects/plot/plot3d/isosurface.rkt @@ -4,13 +4,13 @@ "../common/marching-cubes.rkt" "../common/math.rkt" "../common/vector.rkt" - "../common/contract.rkt" "../common/contract-doc.rkt" + "../common/contract.rkt" + "../common/contract-doc.rkt" "../common/draw.rkt" "../common/legend.rkt" "../common/sample.rkt" "../common/parameters.rkt" - "renderer.rkt" - "sample.rkt") + "renderer.rkt") (provide isosurface3d isosurfaces3d polar3d) diff --git a/collects/plot/plot3d/line.rkt b/collects/plot/plot3d/line.rkt index e7ced21fc5..768d3dc2c4 100644 --- a/collects/plot/plot3d/line.rkt +++ b/collects/plot/plot3d/line.rkt @@ -3,12 +3,12 @@ (require racket/class racket/match racket/list racket/contract "../common/math.rkt" "../common/vector.rkt" - "../common/contract.rkt" "../common/contract-doc.rkt" + "../common/contract.rkt" + "../common/contract-doc.rkt" "../common/legend.rkt" "../common/sample.rkt" "../common/parameters.rkt" - "renderer.rkt" - "sample.rkt") + "renderer.rkt") (provide lines3d parametric3d) diff --git a/collects/plot/plot3d/plot.rkt b/collects/plot/plot3d/plot.rkt index 97b9b6ded5..60941360c1 100644 --- a/collects/plot/plot3d/plot.rkt +++ b/collects/plot/plot3d/plot.rkt @@ -153,6 +153,9 @@ (define x-transform (plot-x-transform)) (define y-transform (plot-y-transform)) (define z-transform (plot-z-transform)) + (define x-ticks (plot-x-ticks)) + (define y-ticks (plot-y-ticks)) + (define z-ticks (plot-z-ticks)) (define animating? (plot-animating?)) (define samples (plot3d-samples)) (define ambient-light (plot3d-ambient-light)) @@ -172,6 +175,9 @@ [plot-x-transform x-transform] [plot-y-transform y-transform] [plot-z-transform z-transform] + [plot-x-ticks x-ticks] + [plot-y-ticks y-ticks] + [plot-z-ticks z-ticks] [plot-animating? animating?] [plot3d-samples samples] [plot3d-ambient-light ambient-light] diff --git a/collects/plot/plot3d/rectangle.rkt b/collects/plot/plot3d/rectangle.rkt index 473bd6bd20..10c3e7aa24 100644 --- a/collects/plot/plot3d/rectangle.rkt +++ b/collects/plot/plot3d/rectangle.rkt @@ -68,11 +68,11 @@ _x-min _x-max _y-min _y-max z-min z-max) (define x-ticks (for/list ([cat (in-list c1s)] [x (in-list tick-xs)]) - (tick x (->plot-label cat) #t))) + (tick x #t (->plot-label cat)))) (define y-ticks (for/list ([cat (in-list c2s)] [y (in-list tick-ys)]) - (tick y (->plot-label cat) #t))) - (values x-ticks y-ticks (default-ticks-fun z-min z-max))) + (tick y #t (->plot-label cat)))) + (values x-ticks y-ticks (default-z-ticks z-min z-max))) (define (adjust/gap i gap) (match-define (ivl x1 x2) i) diff --git a/collects/plot/plot3d/renderer.rkt b/collects/plot/plot3d/renderer.rkt index c6bf395d45..2c320d70cd 100644 --- a/collects/plot/plot3d/renderer.rkt +++ b/collects/plot/plot3d/renderer.rkt @@ -1,9 +1,11 @@ #lang racket/base (require racket/list racket/match racket/contract - "../common/contract.rkt" "../common/contract-doc.rkt" + "../common/contract.rkt" + "../common/contract-doc.rkt" "../common/math.rkt" - "../common/ticks.rkt") + "../common/ticks.rkt" + "../common/parameters.rkt") (provide (all-defined-out)) @@ -63,6 +65,6 @@ [y-min real?] [y-max real?] [z-min real?] [z-max real?] ) (values (listof tick?) (listof tick?) (listof tick?)) - (values (default-ticks-fun x-min x-max) - (default-ticks-fun y-min y-max) - (default-ticks-fun z-min z-max))) + (values (default-x-ticks x-min x-max) + (default-y-ticks y-min y-max) + (default-z-ticks z-min z-max))) diff --git a/collects/plot/plot3d/sample.rkt b/collects/plot/plot3d/sample.rkt deleted file mode 100644 index 8081a3263c..0000000000 --- a/collects/plot/plot3d/sample.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket/base - -(require racket/contract - "../common/contract.rkt" - "../common/sample.rkt" - "../common/parameters.rkt") - -(provide (all-defined-out)) - -(define 2d-function->sampler (make-2d-function->sampler plot-x-transform plot-y-transform)) -(define 3d-function->sampler - (make-3d-function->sampler plot-x-transform plot-y-transform plot-z-transform)) diff --git a/collects/plot/plot3d/surface.rkt b/collects/plot/plot3d/surface.rkt index e858f586d0..f3a5e4e692 100644 --- a/collects/plot/plot3d/surface.rkt +++ b/collects/plot/plot3d/surface.rkt @@ -1,7 +1,8 @@ #lang racket/base (require racket/class racket/match racket/list racket/flonum racket/contract - "../common/contract.rkt" "../common/contract-doc.rkt" + "../common/contract.rkt" + "../common/contract-doc.rkt" "../common/math.rkt" "../common/vector.rkt" "../common/marching-squares.rkt" @@ -12,7 +13,6 @@ "../common/parameters.rkt" "area.rkt" "renderer.rkt" - "sample.rkt" "bounds.rkt") (provide surface3d) diff --git a/collects/plot/tests/axis-transform-tests.rkt b/collects/plot/tests/axis-transform-tests.rkt new file mode 100644 index 0000000000..d10a092e35 --- /dev/null +++ b/collects/plot/tests/axis-transform-tests.rkt @@ -0,0 +1,301 @@ +#lang racket + +(require racket/flonum + plot + plot/utils + plot/common/contract + plot/common/contract-doc + plot/common/axis-transform + ) + +(x-axis-ticks? #f) +(y-axis-ticks? #f) + +(values + (parameterize ([plot-x-transform log-transform]) + (plot (list (function values 1 5) + (function cos 1 5 #:color 3)))) + (parameterize ([plot-x-transform cbrt-transform]) + (plot (list (function values -2 2) + (function cos -2 2 #:color 3)))) + (parameterize ([plot-x-transform log-transform] + [plot-y-transform cbrt-transform]) + (define xs (nonlinear-seq 1 5 20 log-transform)) + (define ys (nonlinear-seq -1 5 20 cbrt-transform)) + (plot (points (map vector xs ys))))) + +(let () + (define trans1 (hand-drawn-transform 25)) + (define trans2 (hand-drawn-transform 100)) + (values + (parameterize ([plot-x-transform trans1]) + (plot (list (function values -2 2) + (function cos -2 2 #:color 3)))) + (parameterize ([plot-x-transform trans2]) + (plot (list (function values -2 2) + (function cos -2 2 #:color 3)))) + (parameterize ([plot-x-transform trans1] + [plot-y-transform trans2]) + (define xs (nonlinear-seq -2 2 20 trans1)) + (define ys (nonlinear-seq -2 2 20 trans2)) + (plot (points (map vector xs ys)))))) + +(let () + (define trans1 (stretch-transform -1/2 1/2 4)) + (define trans2 (stretch-transform -1/2 1/2 1/4)) + (values + (parameterize ([plot-x-transform trans1] + [plot-y-transform trans2]) + (plot (list (y-axis -1/2) (y-axis 1/2) + (x-axis -1/2) (x-axis 1/2) + (function values -2 2) + (function cos -2 2 #:color 3)))) + (parameterize ([plot-x-transform trans1] + [plot-y-transform trans2]) + (define xs (nonlinear-seq -2 2 20 trans1)) + (define ys (nonlinear-seq -2 2 20 trans2)) + (plot (points (map vector xs ys)))))) + +(let () + (define trans1 (axis-transform-compose id-transform (stretch-transform -1 1 1/4))) + (define trans2 (axis-transform-compose (stretch-transform -1 1 1/4) id-transform)) + (values + (parameterize ([plot-x-transform trans1]) + (plot (list (y-axis -1) (y-axis 1) + (function values -2 2) + (function cos -2 2 #:color 3)))) + (parameterize ([plot-x-transform trans2]) + (plot (list (y-axis -1) (y-axis 1) + (function values -2 2) + (function cos -2 2 #:color 3)))) + (parameterize ([plot-x-transform trans1] + [plot-y-transform trans2]) + (define xs (nonlinear-seq -2 2 20 trans1)) + (define ys (nonlinear-seq -2 2 20 trans2)) + (plot (points (map vector xs ys)))))) + +(let () + (define t1 (stretch-transform -2 -1 4)) + (define t2 (stretch-transform 1 2 4)) + (values + (parameterize ([plot-x-transform (axis-transform-compose t1 t2)]) + (plot (list (y-axis -2) (y-axis -1 #t) + (y-axis 1 #t) (y-axis 2) + (function values -3 3) + (function cos -3 3 #:color 3)))) + (parameterize ([plot-x-transform (axis-transform-compose t2 t1)]) + (plot (list (y-axis -2) (y-axis -1 #t) + (y-axis 1 #t) (y-axis 2) + (function values -3 3) + (function cos -3 3 #:color 3)))) + (parameterize ([plot-x-transform (axis-transform-compose t2 t1)] + [plot-y-transform (axis-transform-compose t1 t2)]) + (define xs (nonlinear-seq -3 3 20 (axis-transform-compose t2 t1))) + (define ys (nonlinear-seq -3 3 20 (axis-transform-compose t1 t2))) + (plot (points (map vector xs ys)))))) + +(let () + (define t1 (stretch-transform -2 0 4)) + (define t2 (stretch-transform -1 1 1/4)) + (define t3 (stretch-transform 2 3 4)) + (define trans1 (axis-transform-compose (axis-transform-compose t3 t2) t1)) + (define trans2 (axis-transform-compose (axis-transform-compose t2 t1) t3)) + (values + (parameterize ([plot-x-transform trans1]) + (plot (list (y-axis -2) (y-axis 0) + (y-axis -1) (y-axis 1) + (y-axis 2) (y-axis 3) + (function values -3 4) + (function cos -3 4 #:color 3)))) + (parameterize ([plot-x-transform trans2]) + (plot (list (y-axis -2) (y-axis 0) + (y-axis -1) (y-axis 1) + (y-axis 2) (y-axis 3) + (function values -3 4) + (function cos -3 4 #:color 3)))) + (parameterize ([plot-x-transform trans1] + [plot-y-transform trans2]) + (define xs (nonlinear-seq -3 4 20 trans1)) + (define ys (nonlinear-seq -3 4 20 trans2)) + (plot (points (map vector xs ys)))))) + +(let () + (define trans1 (axis-transform-compose (stretch-transform 2 3 4) log-transform)) + (define trans2 (axis-transform-compose log-transform (stretch-transform 2 3 4))) + (values + (parameterize ([plot-x-transform trans1]) + (plot (list (y-axis 2) (y-axis 3) + (function values 1 5) + (function cos 1 5 #:color 3)))) + (parameterize ([plot-x-transform trans2]) + (plot (list (y-axis 2) (y-axis 3) + (function values 1 5) + (function cos 1 5 #:color 3)))) + (parameterize ([plot-x-transform trans1] + [plot-y-transform trans2]) + (define xs (nonlinear-seq 1 5 20 trans1)) + (define ys (nonlinear-seq 1 5 20 trans2)) + (plot (points (map vector xs ys)))))) + +(let () + (define trans (collapse-transform -1 1)) + (values + (parameterize ([plot-x-transform trans]) + (plot (list (y-axis 1) + (function values -2 2) + (function cos -2 2 #:color 3)))) + (parameterize ([plot-x-transform trans] + [plot-y-transform trans]) + (define xs (nonlinear-seq -2 2 20 trans)) + (plot (points (map vector xs xs)))))) + +(let () + (define trans1 (axis-transform-compose (collapse-transform 2 3) log-transform)) + (define trans2 (axis-transform-compose log-transform (collapse-transform 2 3))) + (values + (parameterize ([plot-x-transform trans1]) + (plot (list (y-axis 3) + (function values 1 5) + (function cos 1 5 #:color 3)))) + (parameterize ([plot-x-transform trans2]) + (plot (list (y-axis 3) + (function values 1 5) + (function cos 1 5 #:color 3)))) + (parameterize ([plot-x-transform trans1] + [plot-y-transform trans2]) + (define xs (nonlinear-seq 1 5 20 trans1)) + (define ys (nonlinear-seq 1 5 20 trans2)) + (plot (points (map vector xs ys)))))) + +(let () + (define trans1 (axis-transform-compose (stretch-transform -1 1 4) + (collapse-transform -1/2 1/2))) + (define trans2 (axis-transform-compose (collapse-transform -1/2 1/2) + (stretch-transform -1 1 4))) + (values + (parameterize ([plot-x-transform trans1]) + (plot (list (y-axis -1) (y-axis 1) + (y-axis -1/2) (y-axis 1/2) + (function values -2 2) + (function cos -2 2 #:color 3)))) + (parameterize ([plot-x-transform trans2]) + (plot (list (y-axis -1) (y-axis 1) + (y-axis -1/2) (y-axis 1/2) + (function values -2 2) + (function cos -2 2 #:color 3)))) + (parameterize ([plot-x-transform trans1] + [plot-y-transform trans2]) + (define xs (nonlinear-seq -2 2 20 trans1)) + (define ys (nonlinear-seq -2 2 20 trans2)) + (plot (points (map vector xs ys)))))) + +(let () + (define trans1 (axis-transform-compose (collapse-transform -1 1) (collapse-transform -1/2 1/2))) + (define trans2 (axis-transform-compose (collapse-transform -1/2 1/2) (collapse-transform -1 1))) + (values + (parameterize ([plot-x-transform trans1]) + (plot (list (y-axis 1) (y-axis 1/2) + (function values -2 2) + (function cos -2 2 #:color 3)))) + (parameterize ([plot-x-transform trans2]) + (plot (list (y-axis 1) (y-axis 1/2) + (function values -2 2) + (function cos -2 2 #:color 3)))) + (parameterize ([plot-x-transform trans1] + [plot-y-transform trans2]) + (define xs (nonlinear-seq -2 2 20 trans1)) + (define ys (nonlinear-seq -2 2 20 trans2)) + (plot (points (map vector xs ys)))))) + +(parameterize ([plot-x-transform (collapse-transform -1 1)]) + (plot (function values 0 2))) + +(parameterize ([plot-x-transform (collapse-transform -1 1)]) + (plot (function values -2 0))) + +(parameterize ([plot-x-transform (axis-transform-append id-transform log-transform 0.1)]) + (plot (function sin -4 4))) + +(let () + (define trans (axis-transform-append id-transform log-transform 2)) + (define ticks (log-ticks #:base 10)) + (values + (parameterize ([plot-x-transform trans] + [plot-x-ticks ticks]) + (plot (list (function values 1 15) + (function cos 1 15 #:color 3)))) + (parameterize ([plot-x-transform trans] + [plot-y-transform trans]) + (define xs (nonlinear-seq 1 15 20 trans)) + (plot (points (map vector xs xs)))))) + +(let () + (define t1 (stretch-transform 2 3 4)) + (define t2 (stretch-transform 7 8 4)) + (define trans1 (axis-transform-compose (axis-transform-append t1 t2 5) log-transform)) + (define trans2 (axis-transform-compose log-transform (axis-transform-append t1 t2 5))) + (values + (parameterize ([plot-x-transform trans1]) + (plot (list (for/list ([x (in-list '(2 3 7 8))]) (y-axis x)) + (function values 1 9)))) + (parameterize ([plot-x-transform trans2]) + (plot (list (for/list ([x (in-list '(2 3 7 8))]) (y-axis x)) + (function values 1 9)))) + (parameterize ([plot-x-transform trans1] + [plot-y-transform trans2]) + (define xs (nonlinear-seq 1 9 50 trans1)) + (define ys (nonlinear-seq 1 9 50 trans2)) + (plot (points (map vector xs ys)))))) + +(let () + (define trans1 (axis-transform-append log-transform id-transform 5)) + (define trans2 (axis-transform-append id-transform log-transform 5)) + (values + (parameterize ([plot-x-transform trans1]) + (plot (list (y-axis 5) + (function values 6 10) + (function cos 6 10 #:color 3)))) + (parameterize ([plot-x-transform trans2]) + (plot (list (y-axis 5) + (function values 6 10) + (function cos 6 10 #:color 3)))) + (parameterize ([plot-x-transform trans1] + [plot-y-transform trans2]) + (define xs (nonlinear-seq 6 10 20 trans1)) + (define ys (nonlinear-seq 6 10 20 trans2)) + (plot (points (map vector xs ys)))) + (parameterize ([plot-x-transform trans1]) + (plot (list (y-axis 5) + (function values 1 4) + (function cos 1 4 #:color 3)))) + (parameterize ([plot-x-transform trans2]) + (plot (list (y-axis 5) + (function values 1 4) + (function cos 1 4 #:color 3)))) + (parameterize ([plot-x-transform trans1] + [plot-y-transform trans2]) + (define xs (nonlinear-seq 1 4 20 trans1)) + (define ys (nonlinear-seq 1 4 20 trans2)) + (plot (points (map vector xs ys)))))) + +(parameterize ([plot-x-transform (axis-transform-compose (collapse-transform 2 6) + log-transform)] + [plot-x-ticks (log-ticks)]) + (plot (list (y-axis 2 #t) (y-axis 6 #t) + (function values 1 10)))) + +(let () + (define trans1 (axis-transform-bound log-transform 0.1 5)) + (define trans2 (axis-transform-bound (stretch-transform 1 2 4) 1 2)) + (values + (parameterize ([plot-x-transform trans1]) + (plot (list (y-axis 0.1) (y-axis 5) + (function values -3 9)))) + (parameterize ([plot-x-transform trans2]) + (plot (list (y-axis 1) (y-axis 2) + (function values 0 3)))) + (parameterize ([plot-x-transform trans1] + [plot-y-transform trans2]) + (define xs (nonlinear-seq -3 9 20 trans1)) + (define ys (nonlinear-seq 0 3 20 trans2)) + (plot (points (map vector xs ys)))))) diff --git a/collects/plot/tests/plot2d-tests.rkt b/collects/plot/tests/plot2d-tests.rkt index ee1ad33296..de14312afd 100644 --- a/collects/plot/tests/plot2d-tests.rkt +++ b/collects/plot/tests/plot2d-tests.rkt @@ -10,10 +10,17 @@ (plot empty #:x-min -1 #:x-max 1 #:y-min -1 #:y-max 1) -(plot (list (axes 1 2) (function values -4 4))) +(plot (list (function values -4 4) (axes 1 2 #t #t))) (time (plot (function values 0 1000))) +(parameterize ([plot-x-ticks (log-ticks #:base 4)] + [plot-x-transform log-transform] + [plot-y-max-ticks 10] + [plot-y-ticks (linear-ticks)] + [plot-y-transform log-transform]) + (plot (function values 1 243))) + (parameterize ([plot-background "black"] [plot-foreground "white"] [plot-background-alpha 1/2] @@ -403,3 +410,14 @@ 13 (λ (n) (function (make-fun n) 0 2 #:color n #:width 2 #:style n)))) #:x-min -2 #:x-max 2))) + +(let () + (define (f x) (/ (sin x) x)) + (parameterize ([plot-x-transform (stretch-transform -1 1 10)] + [plot-y-ticks (fraction-ticks)]) + (plot (list (y-axis -1 #t #:ticks? #f) (y-axis 1 #t #:ticks? #f) + (function f -1 1 #:width 2 #:color 4) + (function f -14 -1 #:color 4 #:label "y = sin(x)/x") + (function f 1 14 #:color 4) + (point-label (vector 0 1) "y → 1 as x → 0" #:anchor 'bottom-right)) + #:y-max 1.2))) diff --git a/collects/plot/tests/tick-tests.rkt b/collects/plot/tests/tick-tests.rkt new file mode 100644 index 0000000000..7281d88b80 --- /dev/null +++ b/collects/plot/tests/tick-tests.rkt @@ -0,0 +1,82 @@ +#lang racket + +(require plot (only-in plot/common/math floor-log/base real-modulo)) + +(plot-font-family 'swiss) + +(plot (function (λ (x) (count pre-tick-major? ((linear-ticks) 0 x 8 id-transform))) + 0.1 10)) + +(plot (function (λ (x) (count pre-tick-major? ((linear-ticks) 0 x 40 id-transform))) + 1 100)) + +(parameterize ([plot-x-ticks (linear-ticks #:base 2 #:divisors '(1 2))] + #;[plot-y-ticks (linear-ticks #:base (* 1 2 3 4 5) #:divisors '(1 2 3 4 5))]) + (plot (function cos 0.013 2.1176))) + +(parameterize ([plot-x-transform log-transform] + [plot-x-ticks (ticks (log-ticks-layout) + (fraction-ticks-format))] + [plot-y-ticks (fraction-ticks)]) + (plot (function (λ (x) (+ 1 (cos x))) 0.0001 12))) + +(parameterize ([plot-x-ticks (date-ticks)] + [plot-x-max-ticks 3] + [plot-y-ticks (currency-ticks)]) + (plot (function values -1 1))) + +(parameterize ([plot-x-ticks (date-ticks)] + [currency-format-strings uk-currency-format-strings] + [currency-scale-suffixes uk-currency-scale-suffixes] + [plot-y-ticks (currency-ticks #:kind 'GBP)]) + (plot (function values 101232512 2321236192))) + +(parameterize ([currency-format-strings eu-currency-format-strings] + [currency-scale-suffixes eu-currency-scale-suffixes] + [plot-x-ticks (currency-ticks #:kind 'EUR)] + [plot-y-ticks (currency-ticks)]) + (plot (function (λ (x) (* x 1.377)) 8000000 10000000) + #:title "EUR-USD Conversion, 2011-10-13" + #:x-label "Euros" + #:y-label "Dollars")) + +(parameterize ([plot-x-ticks no-ticks]) + (plot (function sin -1 4))) + +(parameterize ([plot-x-transform log-transform] + [plot-y-transform log-transform] + [plot-x-ticks (log-ticks #:base 10)] + [plot-y-ticks (log-ticks #:base 2)]) + (plot (function values 0.1 10))) + +(parameterize ([plot-x-transform log-transform] + [plot-y-transform (stretch-transform -1 1 4)] + [plot-x-ticks (ticks (uniform-ticks-layout) + (log-ticks-format #:base 10))] + [plot-y-ticks (ticks (uniform-ticks-layout) + (currency-ticks-format #:kind 'USD))]) + (plot (function log 0.1 10))) + +(parameterize ([plot-x-transform log-transform] + [plot-x-ticks (log-ticks #:base 10)]) + (plot (function values 10000000000000 1000000000000000))) + +(plot (polar-axes) #:x-min -1 #:x-max 1 #:y-min -1 #:y-max 1) + +(plot (polar-axes) #:x-min 0 #:x-max 3 #:y-min 0 #:y-max 3) + +(plot (polar-axes) #:x-min 1 #:x-max 4 #:y-min 1 #:y-max 4) + +(plot (polar-axes #:number 12) #:x-min 10 #:x-max 12 #:y-min 10 #:y-max 12) + +(parameterize ([plot-z-transform log-transform] + [plot-z-ticks (log-ticks)] + [contour-samples (plot3d-samples)]) + (values + (plot (contours (λ (x y) (exp (- (+ (sqr x) (sqr y))))) -2 2 -2 2 #:label "z")) + (plot (contour-intervals (λ (x y) (exp (- (+ (sqr x) (sqr y))))) -2 2 -2 2 #:label "z")) + (plot3d (contours3d (λ (x y) (exp (- (+ (sqr x) (sqr y))))) -2 2 -2 2 #:label "z")) + (plot3d (contour-intervals3d (λ (x y) (exp (- (+ (sqr x) (sqr y))))) -2 2 -2 2 #:label "z")))) + +(plot (contours (λ (x y) (* 1/2 (+ (sqr x) (sqr y)))) -1 1 -1 1 #:label "z")) +(plot3d (contours3d (λ (x y) (* 1/2 (+ (sqr x) (sqr y)))) -1 1 -1 1 #:label "z")) diff --git a/collects/tests/plot/run-tests.rkt b/collects/tests/plot/run-tests.rkt index ecf5bde13b..55ec13eb06 100755 --- a/collects/tests/plot/run-tests.rkt +++ b/collects/tests/plot/run-tests.rkt @@ -4,7 +4,8 @@ exec gracket "$0" "$@" |# #lang racket -(require rackunit plot plot/utils) +(require rackunit racket/date + plot plot/utils plot/common/date-time) (check-equal? (linear-seq 0 1 2 #:start? #t #:end? #t) '(0 1)) (check-equal? (linear-seq 0 1 2 #:start? #t #:end? #f) '(0 2/3)) @@ -14,3 +15,60 @@ exec gracket "$0" "$@" (check-exn exn:fail:contract? (λ () (vector-field (λ (v [z 0]) v) -4 4 -4 4)) "Exception should be 'two of the clauses in the or/c might both match' or similar") + +;; =================================================================================================== +;; Date rounding + +(check-equal? (utc-seconds-round-year (find-seconds 0 0 12 2 7 1970 #f)) + (find-seconds 0 0 0 1 1 1970 #f)) +(check-equal? (utc-seconds-round-year (find-seconds 0 0 13 2 7 1970 #f)) + (find-seconds 0 0 0 1 1 1971 #f)) +;; A leap year's middle is a half day earlier on the calendar: +(check-equal? (utc-seconds-round-year (find-seconds 0 0 0 2 7 1976 #f)) + (find-seconds 0 0 0 1 1 1976 #f)) +(check-equal? (utc-seconds-round-year (find-seconds 0 0 1 2 7 1976 #f)) + (find-seconds 0 0 0 1 1 1977 #f)) + +(check-equal? (utc-seconds-round-month (find-seconds 0 0 0 16 1 2010 #f)) + (find-seconds 0 0 0 1 1 2010 #f)) +(check-equal? (utc-seconds-round-month (find-seconds 0 0 0 17 1 2010 #f)) + (find-seconds 0 0 0 1 2 2010 #f)) +(check-equal? (utc-seconds-round-month (find-seconds 0 0 12 16 1 2010 #f)) + (find-seconds 0 0 0 1 1 2010 #f)) +(check-equal? (utc-seconds-round-month (find-seconds 0 0 13 16 1 2010 #f)) + (find-seconds 0 0 0 1 2 2010 #f)) +(check-equal? (utc-seconds-round-month (find-seconds 0 0 0 16 12 2010 #f)) + (find-seconds 0 0 0 1 12 2010 #f)) +(check-equal? (utc-seconds-round-month (find-seconds 0 0 0 17 12 2010 #f)) + (find-seconds 0 0 0 1 1 2011 #f)) + +;; =================================================================================================== +;; Time conversion + +(check-equal? (seconds->plot-time 0) (plot-time 0 0 0 0)) +(check-equal? (seconds->plot-time #e59.999999) (plot-time #e59.999999 0 0 0)) +(check-equal? (seconds->plot-time 60) (plot-time 0 1 0 0)) +(check-equal? (seconds->plot-time #e60.000001) (plot-time #e0.000001 1 0 0)) +(check-equal? (seconds->plot-time #e119.999999) (plot-time #e59.999999 1 0 0)) +(check-equal? (seconds->plot-time 120) (plot-time 0 2 0 0)) +(check-equal? (seconds->plot-time #e120.000001) (plot-time #e0.000001 2 0 0)) +(check-equal? (seconds->plot-time 3599) (plot-time 59 59 0 0)) +(check-equal? (seconds->plot-time 3600) (plot-time 0 0 1 0)) +(check-equal? (seconds->plot-time 3601) (plot-time 1 0 1 0)) +(check-equal? (seconds->plot-time (- seconds-per-day 1)) (plot-time 59 59 23 0)) +(check-equal? (seconds->plot-time seconds-per-day) (plot-time 0 0 0 1)) +(check-equal? (seconds->plot-time (- seconds-per-day)) (plot-time 0 0 0 -1)) +(check-equal? (seconds->plot-time (- (- seconds-per-day) 1)) (plot-time 59 59 23 -2)) + +(define sec-secs (sequence->list (in-range -60 61 #e0.571123))) +(define min-secs (sequence->list (in-range (- seconds-per-hour) (+ seconds-per-hour 1) + (* #e0.571123 seconds-per-minute)))) +(define hour-secs (sequence->list (in-range (- seconds-per-day) (+ seconds-per-day 1) + (* #e0.571123 seconds-per-hour)))) +(define day-secs (sequence->list (in-range (- seconds-per-week) (+ seconds-per-week 1) + (* #e0.571123 seconds-per-day)))) +(check-equal? (map (compose plot-time->seconds seconds->plot-time) sec-secs) sec-secs) +(check-equal? (map (compose plot-time->seconds seconds->plot-time) min-secs) min-secs) +(check-equal? (map (compose plot-time->seconds seconds->plot-time) hour-secs) hour-secs) +(check-equal? (map (compose plot-time->seconds seconds->plot-time) day-secs) day-secs) +