diff --git a/plot-doc/plot/scribblings/params.scrbl b/plot-doc/plot/scribblings/params.scrbl index af26481a..1edf974c 100644 --- a/plot-doc/plot/scribblings/params.scrbl +++ b/plot-doc/plot/scribblings/params.scrbl @@ -105,6 +105,21 @@ The font size (in drawing units), face, and family to prefer for the legend text (defparam plot-legend-box-alpha alpha (real-in 0 1) #:value 2/3))]{ The placement of the legend and the opacity of its background. } +@defparam[plot-legend-layout layout (list/c (or/c 'columns 'rows) positive-integer? (or/c 'equal-size 'compact)) #:value '(columns 1 equal-size)]{ +Defines the way in which individual entries are placed in the legend. This is a list of three + elements: +@itemlist[@item{the placement direction (@racket['columns] or @racket['rows])} + @item{the number of columns or rows} + @item{whether all the entries will have the same size (@racket['equal-size]), + or the entries will only occupy the minimum size (@racket['compact])}] + +For example, the value @racket['(columns 1 equal-size)] will place the legend entries vertically from + top to bottom and all entries will have the same height. A value of @racket['(rows 2 'compact)] will + place legend entries horizontally on two rows -- this type of layout is useful when the legend is + placed at the top or bottom of the plot. + +@history[#:added "7.9"] +} @defparam[plot-tick-size size (>=/c 0) #:value 10]{ The length of tick lines, in drawing units. diff --git a/plot-lib/plot/private/common/parameter-groups.rkt b/plot-lib/plot/private/common/parameter-groups.rkt index 8713fa17..f793c12f 100644 --- a/plot-lib/plot/private/common/parameter-groups.rkt +++ b/plot-lib/plot/private/common/parameter-groups.rkt @@ -33,7 +33,7 @@ plot-line-width plot-tick-size plot-font-size plot-font-face plot-font-family plot-legend-font-size plot-legend-font-face plot-legend-font-family - plot-legend-anchor plot-legend-box-alpha + plot-legend-anchor plot-legend-box-alpha plot-legend-layout plot-axes? plot-tick-labels plot-decorations? plot-animating? @@ -102,6 +102,7 @@ (U False Font-Family) Legend-Anchor Nonnegative-Real + Legend-Layout (List Boolean Boolean Boolean Boolean Boolean Boolean) (List Boolean Anchor Real (U Boolean 'auto) Anchor Real Boolean Anchor Real (U Boolean 'auto) Anchor Real) Boolean diff --git a/plot-lib/plot/private/common/parameters.rkt b/plot-lib/plot/private/common/parameters.rkt index 7c0eb3f8..4075f70e 100644 --- a/plot-lib/plot/private/common/parameters.rkt +++ b/plot-lib/plot/private/common/parameters.rkt @@ -76,6 +76,7 @@ (defparam plot-legend-font-face face (U String #f) #f) (defparam plot-legend-font-family family (U Font-Family #f) #f) (defparam plot-legend-anchor anchor Legend-Anchor 'top-left) +(defparam plot-legend-layout layout Legend-Layout '(columns 1 equal-size)) (defparam2 plot-legend-box-alpha alpha Real Nonnegative-Real 2/3 (unit-ivl 'plot-legend-box-alpha)) (defparam plot-animating? Boolean #f) diff --git a/plot-lib/plot/private/common/plot-device.rkt b/plot-lib/plot/private/common/plot-device.rkt index dfe864d5..c692bf60 100644 --- a/plot-lib/plot/private/common/plot-device.rkt +++ b/plot-lib/plot/private/common/plot-device.rkt @@ -610,74 +610,127 @@ ;; =============================================================================================== ;; Legend - ;; the folowing functions take a (Listof legend-entry) and a Rect as argument. + ;; the folowing functions take a (Listof legend-entry), a Rect and Anchor as argument. ;; the understanding is that Rect will be the complete dc for a legend outside the plot-area ;; and the plot-area otherwise (: calculate-legend-parameters (-> (Listof legend-entry) Rect Anchor - (Values Rect Exact-Rational Exact-Rational Exact-Rational - Nonnegative-Exact-Rational Real Real - Nonnegative-Exact-Rational Real))) + (Values Rect (Listof Exact-Rational) + Nonnegative-Exact-Rational (Listof Real) (Listof Real) + Nonnegative-Exact-Rational (Listof Real) + Boolean Nonnegative-Integer))) (define/private (calculate-legend-parameters legend-entries rect legend-anchor) (define n (length legend-entries)) (define labels (map legend-entry-label legend-entries)) (match-define (vector (ivl x-min x-max) (ivl y-min y-max)) rect) - - (define-values (max-label-width max-label-height) - (for/fold ([width : Exact-Rational 0] - [max-height : Exact-Rational 0]) - ([label (in-list labels)]) - (define-values (w h b a) (get-text-extent label)) - (values (max w width) (max h max-height)))) - - (define-values (horiz-gap min-label-height baseline _1) - (get-text-extent " ")) + (cond + [(and x-min x-max y-min y-max) + (define-values (cols? rows cols compact?) + (match (plot-legend-layout) + [(list 'rows i compact) + (values #f (min n i) (ceiling (/ n i)) (equal? compact 'compact))] + [(list 'columns i compact) + (values #t (ceiling (/ n i)) (min n i) (equal? compact 'compact))])) + (define div (if cols? rows cols)) + + ;; get max widths and heights per row/column + (define-values (max-label-widths max-label-heights) + (let-values ([(width height) + (for/fold ([width : (HashTable Integer Exact-Rational) #hash()] + [height : (HashTable Integer Exact-Rational) #hash()]) + ([label (in-list labels)] + [k (in-naturals)]) + (define-values (i j) + (let-values ([(i j) (quotient/remainder k div)]) + (if cols? (values j i) (values i j)))) + (define-values (w h b a) (get-text-extent label)) + (values + (hash-update width j (λ ([v : Exact-Rational]) (max w v)) (λ () 0)) + (hash-update height i (λ ([v : Exact-Rational]) (max h v)) (λ () 0))))]) + (define widths + ((inst map Exact-Rational (Pairof Integer Exact-Rational)) + cdr ((inst sort (Pairof Integer Exact-Rational)) + (hash->list width) < #:key car))) + (define heights + ((inst map Exact-Rational (Pairof Integer Exact-Rational)) + cdr ((inst sort (Pairof Integer Exact-Rational)) + (hash->list height) < #:key car))) + (cond + [compact? (values widths heights)] + [else + (define max-width (apply max widths)) + (define max-heights (apply max heights)) + (values (map (λ (_) max-width) widths) + (map (λ (_) max-heights) heights))]))) + + ;; different gaps + (define-values (horiz-gap min-label-height baseline _1) + (get-text-extent " ")) - (define top-gap baseline) - (define bottom-gap (* 1/2 baseline)) - (define baseline-skip (+ max-label-height baseline)) - - (define labels-x-size (+ max-label-width horiz-gap)) - - (define draw-y-size (max 0 (- min-label-height baseline))) - (define draw-x-size (* 4 draw-y-size)) - - (define legend-x-size (+ horiz-gap - labels-x-size (* 2 horiz-gap) - draw-x-size horiz-gap)) - (define legend-y-size (+ top-gap (* n baseline-skip) bottom-gap)) - - (define legend-x-min - (cond - [(and x-min x-max) + (define top-gap baseline) + (define bottom-gap (* 1/2 baseline)) + (define in-label-gap (* 3 horiz-gap)) + (define column-gap (* 3 in-label-gap)) + + ;; size of legend line/square + (define draw-y-size (max 0 (- min-label-height baseline))) + (define draw-x-size (* 4 draw-y-size)) + + ;; size of complete legend-entry + (define x-skips (for/list : (Listof Exact-Rational) + ([w (in-list max-label-widths)]) + (+ w in-label-gap draw-x-size column-gap))) + (define y-skips (for/list : (Listof Exact-Rational) + ([h (in-list max-label-heights)]) + (+ h baseline))) + + ;; size of complete legend + (define legend-x-size (+ horiz-gap (- column-gap) horiz-gap + (for/sum : Exact-Rational ([w (in-list x-skips)]) w))) + (define legend-y-size (+ top-gap bottom-gap + (for/sum : Exact-Rational ([h (in-list y-skips)]) h))) + + ;; top-left corner of legend + (define legend-x-min (case legend-anchor [(top-left left bottom-left auto) x-min] [(top-right right bottom-right) (- x-max legend-x-size)] [(center bottom top) (- (* 1/2 (+ x-min x-max)) - (* 1/2 legend-x-size))])] - [else - (raise-argument-error 'draw-legend "rect-known?" 1 legend-entries rect)])) + (* 1/2 legend-x-size))])) - (define legend-y-min - (cond - [(and y-min y-max) + (define legend-y-min (case legend-anchor [(top-left top top-right auto) y-min] [(bottom-left bottom bottom-right) (- y-max legend-y-size)] [(center left right) (- (* 1/2 (+ y-min y-max)) - (* 1/2 legend-y-size))])] - [else - (raise-argument-error 'draw-legend "rect-known?" 1 legend-entries rect)])) - - (define legend-rect (vector (ivl legend-x-min (+ legend-x-min legend-x-size)) - (ivl legend-y-min (+ legend-y-min legend-y-size)))) - - (define label-x-min (+ legend-x-min horiz-gap)) - (define draw-x-min (+ legend-x-min (* 2 horiz-gap) labels-x-size horiz-gap)) - - (values legend-rect top-gap baseline-skip max-label-height - draw-x-size label-x-min draw-x-min - draw-y-size legend-y-min)) + (* 1/2 legend-y-size))])) + + (define legend-rect (vector (ivl legend-x-min (+ legend-x-min legend-x-size)) + (ivl legend-y-min (+ legend-y-min legend-y-size)))) + + ;; per entry x/y left/top corners + (define label-x-mins (for/fold ([mins : (Listof Real) (list (+ legend-x-min horiz-gap))] + [prev : Real (+ legend-x-min horiz-gap)] + #:result (reverse mins)) + ([x (in-list x-skips)]) + (define nxt (+ prev x)) + (values (cons nxt mins) nxt))) + (define label-y-mins (for/fold ([mins : (Listof Real) (list (+ legend-y-min top-gap))] + [prev : Real (+ legend-y-min top-gap)] + #:result (reverse mins)) + ([y (in-list y-skips)]) + (define nxt (+ prev y)) + (values (cons nxt mins) nxt))) + (define draw-x-mins (for/list : (Listof Real) + ([x (in-list label-x-mins)] + [w (in-list max-label-widths)]) (+ x w in-label-gap))) + + (values legend-rect max-label-heights + draw-x-size label-x-mins draw-x-mins + draw-y-size label-y-mins + cols? div)] + [else + (raise-argument-error 'draw-legend "rect-known?" 1 legend-entries rect)])) (define/public (calculate-legend-rect legend-entries rect legend-anchor) ;; Change font for correct size calculation in calculate-legend-parameters @@ -689,9 +742,10 @@ (or (plot-legend-font-face) old-face) (or (plot-legend-font-family) old-family)) - (define-values (legend-rect top-gap baseline-skip max-label-height - draw-x-size label-x-min draw-x-min - draw-y-size legend-y-min) + (define-values (legend-rect max-label-heights + draw-x-size label-x-mins draw-x-mins + draw-y-size label-y-mins + cols? div) (calculate-legend-parameters legend-entries rect legend-anchor)) ;; Undo change font @@ -701,7 +755,7 @@ (define/public (draw-legend legend-entries rect) (define legend-anchor (plot-legend-anchor)) - (when legend-anchor + (when (not (eq? legend-anchor 'no-legend)) (match-define (list (legend-entry #{labels : (Listof (U String pict))} #{draw-procs : (Listof Legend-Draw-Proc)}) ...) @@ -716,9 +770,10 @@ (or (plot-legend-font-face) old-face) (or (plot-legend-font-family) old-family)) - (define-values (legend-rect top-gap baseline-skip max-label-height - draw-x-size label-x-min draw-x-min - draw-y-size legend-y-min) + (define-values (legend-rect max-label-heights + draw-x-size label-x-mins draw-x-mins + draw-y-size label-y-mins + cols? div) (calculate-legend-parameters legend-entries rect (legend-anchor->anchor legend-anchor))) ;; legend background @@ -735,15 +790,24 @@ (set-alpha (plot-foreground-alpha)) (set-clipping-rect legend-rect) - (for ([label (in-list labels)] [draw-proc (in-list draw-procs)] [i (in-naturals)]) + (for ([label (in-list labels)] [draw-proc (in-list draw-procs)] [k (in-naturals)]) + (define-values (i j) + (let-values ([(i j) (quotient/remainder k div)]) + (if cols? (values j i) (values i j)))) + (define-values (_1 label-height _2 _3) (get-text-extent label)) - (define legend-entry-y-min (+ legend-y-min top-gap (* i baseline-skip))) - (define label-y-min (+ legend-entry-y-min (* 1/2 (- max-label-height label-height)))) + (define label-x-min (list-ref label-x-mins j)) + (define legend-entry-y-min (list-ref label-y-mins i)) + (define max-label-height (list-ref max-label-heights i)) + (define label-y-min (+ legend-entry-y-min + (* 1/2 (- max-label-height label-height)))) + (if (pict? label) - (draw-pict label (vector (ann label-x-min Real) (ann label-y-min Real)) 'top-left 0) - (draw-text label (vector (ann label-x-min Real) (ann label-y-min Real)) 'top-left 0 0 #t)) + (draw-pict label (vector label-x-min label-y-min) 'top-left 0) + (draw-text label (vector label-x-min label-y-min) 'top-left 0 0 #t)) (define draw-y-min (+ legend-entry-y-min (* 1/2 (- max-label-height draw-y-size)))) + (define draw-x-min (list-ref draw-x-mins j)) (define entry-pd (make-object plot-device% dc draw-x-min draw-y-min draw-x-size draw-y-size)) (send entry-pd reset-drawing-params #f) diff --git a/plot-lib/plot/private/common/types.rkt b/plot-lib/plot/private/common/types.rkt index 9b6fb2ba..7e5da78e 100644 --- a/plot-lib/plot/private/common/types.rkt +++ b/plot-lib/plot/private/common/types.rkt @@ -117,6 +117,8 @@ [(outside-left) 'left] [else 'auto]))) +(deftype Legend-Layout (List (U 'rows 'columns) Positive-Integer (U 'equal-size 'compact))) + (define-type Plot-Device% (Class (init-field [dc (Instance DC<%>)] diff --git a/plot-lib/plot/private/utils-and-no-gui.rkt b/plot-lib/plot/private/utils-and-no-gui.rkt index e4253af2..4956ea4e 100644 --- a/plot-lib/plot/private/utils-and-no-gui.rkt +++ b/plot-lib/plot/private/utils-and-no-gui.rkt @@ -89,6 +89,7 @@ plot-legend-font-family plot-legend-anchor plot-legend-box-alpha + plot-legend-layout plot-decorations? plot-animating? plot-pen-color-map diff --git a/plot-test/plot/tests/PRs/81-legend-layout.rkt b/plot-test/plot/tests/PRs/81-legend-layout.rkt new file mode 100644 index 00000000..e8e4fde6 --- /dev/null +++ b/plot-test/plot/tests/PRs/81-legend-layout.rkt @@ -0,0 +1,51 @@ +#lang racket +(require rackunit + plot pict + racket/draw + racket/runtime-path + "../helpers.rkt") + +;; Tests for: https://github.com/racket/plot/pull/68 + +(define rendertree + (list (contour-intervals (λ (x y) (* x y)) 0 1 #:label "a") + (function values 0 1 #:label "b" #:color 1) + (function add1 0 1 #:label "a rather long one" #:color 2) + (function sub1 0 1 #:label (standard-fish 20 40) #:color 4))) + +(define (do-3row-equal output-fn) + (parameterize ([plot-legend-layout '(rows 3 equal-size)]) + (output-fn rendertree #:legend-anchor 'outside-top))) + +(define (do-3row-compact output-fn) + (parameterize ([plot-legend-layout '(rows 3 compact)]) + (output-fn rendertree #:legend-anchor 'outside-top))) + +(define (do-2col-equal output-fn) + (parameterize ([plot-legend-layout '(columns 2 equal-size)]) + (output-fn rendertree #:legend-anchor 'outside-left))) + +(define (do-2col-compact output-fn) + (parameterize ([plot-legend-layout '(columns 2 compact)]) + (output-fn rendertree #:legend-anchor 'outside-left))) + +(define-runtime-path pr81-data-1 "./test-data/pr81-1.dat") +(define-runtime-path pr81-data-2 "./test-data/pr81-2.dat") +(define-runtime-path pr81-data-3 "./test-data/pr81-3.dat") +(define-runtime-path pr81-data-4 "./test-data/pr81-4.dat") + +(define pr81-test-suite + (test-suite + "PR#81: horizontal layout for legend" + (test-case "pr81-3row-equal" + (check-draw-steps do-3row-equal pr81-data-1)) + (test-case "pr81-3row-compact" + (check-draw-steps do-3row-compact pr81-data-2)) + (test-case "pr81-2col-equal" + (check-draw-steps do-2col-equal pr81-data-3)) + (test-case "pr81-2col-compact" + (check-draw-steps do-2col-compact pr81-data-4)))) + +(module+ test + (require rackunit/text-ui) + (run-tests pr81-test-suite)) diff --git a/plot-test/plot/tests/PRs/test-data/pr81-1.dat b/plot-test/plot/tests/PRs/test-data/pr81-1.dat new file mode 100644 index 00000000..69e5e424 Binary files /dev/null and b/plot-test/plot/tests/PRs/test-data/pr81-1.dat differ diff --git a/plot-test/plot/tests/PRs/test-data/pr81-1.png b/plot-test/plot/tests/PRs/test-data/pr81-1.png new file mode 100644 index 00000000..99c28977 Binary files /dev/null and b/plot-test/plot/tests/PRs/test-data/pr81-1.png differ diff --git a/plot-test/plot/tests/PRs/test-data/pr81-2.dat b/plot-test/plot/tests/PRs/test-data/pr81-2.dat new file mode 100644 index 00000000..86e4abb7 Binary files /dev/null and b/plot-test/plot/tests/PRs/test-data/pr81-2.dat differ diff --git a/plot-test/plot/tests/PRs/test-data/pr81-2.png b/plot-test/plot/tests/PRs/test-data/pr81-2.png new file mode 100644 index 00000000..d0869ca0 Binary files /dev/null and b/plot-test/plot/tests/PRs/test-data/pr81-2.png differ diff --git a/plot-test/plot/tests/PRs/test-data/pr81-3.dat b/plot-test/plot/tests/PRs/test-data/pr81-3.dat new file mode 100644 index 00000000..460b91be Binary files /dev/null and b/plot-test/plot/tests/PRs/test-data/pr81-3.dat differ diff --git a/plot-test/plot/tests/PRs/test-data/pr81-3.png b/plot-test/plot/tests/PRs/test-data/pr81-3.png new file mode 100644 index 00000000..6b075add Binary files /dev/null and b/plot-test/plot/tests/PRs/test-data/pr81-3.png differ diff --git a/plot-test/plot/tests/PRs/test-data/pr81-4.dat b/plot-test/plot/tests/PRs/test-data/pr81-4.dat new file mode 100644 index 00000000..007e0ecf Binary files /dev/null and b/plot-test/plot/tests/PRs/test-data/pr81-4.dat differ diff --git a/plot-test/plot/tests/PRs/test-data/pr81-4.png b/plot-test/plot/tests/PRs/test-data/pr81-4.png new file mode 100644 index 00000000..f42eaeb3 Binary files /dev/null and b/plot-test/plot/tests/PRs/test-data/pr81-4.png differ