Multi-line, multi-column legend layout (#81, #49)

A new parameter, `plot-legend-layout`, allows placing legend entries into
multiple rows or columns.  This allows, for example, using a horizontal layout
when the legend is placed at the top or bottom of the plot.

Author: bdeket

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.

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

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)
 

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)

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<%>)]

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

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))