Coverage report: /home/ellis/comp/core/lib/cli/spark.lisp

KindCoveredAll%
expression329392 83.9
branch3542 83.3
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; lib/cli/spark.lisp --- Sparklines
2
 
3
 ;; based on: https://github.com/tkych/cl-spark
4
 
5
 ;; ref: https://www.edwardtufte.com/bboard/q-and-a-fetch-msg?msg_id=0001OR
6
 
7
 ;;; Code:
8
 (in-package :cli/spark)
9
 
10
 ;; util
11
 (defun string-concat (&rest strings)
12
   (with-output-to-string (s)
13
     (dolist (string strings)
14
       (princ string s))))
15
 
16
 (eval-when (:compile-toplevel :load-toplevel :execute)
17
   (defun at-least-two-chars-p (x)
18
     (and (simple-vector-p x)
19
          (<= 2 (length x))
20
          (every #'characterp x))))
21
 
22
 (deftype %ticks ()
23
   '(and simple-vector (satisfies at-least-two-chars-p)))
24
 
25
 (declaim (type %ticks *ticks* *vticks*))
26
 
27
 ;;--------------------------------------------------------------------
28
 ;; Spark
29
 ;;--------------------------------------------------------------------
30
 ;; (vector #\▁ #\▂ #\▃ #\▄ #\▅ #\▆ #\▇ #\█)
31
 
32
 ;; (code-char 9600) => #\UPPER_HALF_BLOCK           <=> #\▀
33
 ;; (code-char 9620) => #\UPPER_ONE_EIGHTH_BLOCK     <=> #\▔
34
 ;; (code-char 9601) => #\LOWER_ONE_EIGHTH_BLOCK     <=> #\▁
35
 ;; (code-char 9602) => #\LOWER_ONE_QUARTER_BLOCK    <=> #\▂
36
 ;; (code-char 9603) => #\LOWER_THREE_EIGHTHS_BLOCK  <=> #\▃
37
 ;; (code-char 9604) => #\LOWER_HALF_BLOCK           <=> #\▄
38
 ;; (code-char 9605) => #\LOWER_FIVE_EIGHTHS_BLOCK   <=> #\▅
39
 ;; (code-char 9606) => #\LOWER_THREE_QUARTERS_BLOCK <=> #\▆
40
 ;; (code-char 9607) => #\LOWER_SEVEN_EIGHTHS_BLOCK  <=> #\▇
41
 ;; (code-char 9608) => #\FULL_BLOCK                 <=> #\█
42
 ;; (code-char 9135) => #\HORIZONTAL_LINE_EXTENSION  <=> #\⎯
43
 
44
 (defvar *ticks*
45
   (vector (code-char 9601) (code-char 9602) (code-char 9603)
46
           (code-char 9604) (code-char 9605) (code-char 9606)
47
           (code-char 9607) (code-char 9608))
48
   "
49
 A simple-vector of characters for representation of sparklines.
50
 Default is #(#\▁ #\▂ #\▃ #\▄ #\▅ #\▆ #\▇ #\█).
51
 
52
 Examples:
53
 
54
   (defvar ternary '(-1 0 1 -1 1 0 -1 1 -1))
55
 
56
   (spark ternary)              => \"▁▄█▁█▄▁█▁\"
57
 
58
   (let ((*ticks* #(#\_ #\- #\¯)))
59
     (spark ternary))           => \"_-¯_¯-_¯_\"
60
 
61
   (let ((*ticks* #(#\▄ #\⎯ #\▀)))
62
     (spark ternary))           => \"▄⎯▀▄▀⎯▄▀▄\"
63
 ")
64
 
65
 
66
 (defun spark (numbers &key min max key)
67
   (check-type numbers list)
68
   (check-type min     (or null real))
69
   (check-type max     (or null real))
70
   (check-type key     (or symbol function))
71
   (when key (setf numbers (mapcar key numbers)))
72
 
73
   ;; Empty data case:
74
   (when (null numbers)
75
     (RETURN-FROM spark ""))
76
 
77
   ;; Ensure min is the minimum number.
78
   (if (null min)
79
       (setf min (reduce #'min numbers))
80
       (setf numbers (mapcar (lambda (n) (max n min)) numbers)))
81
 
82
   ;; Ensure max is the maximum number.
83
   (if (null max)
84
       (setf max (reduce #'max numbers))
85
       (setf numbers (mapcar (lambda (n) (min n max)) numbers)))
86
 
87
   (when (< max min)
88
     (error "max ~S < min ~S." max min))
89
 
90
   (let ((unit (/ (- max min) (1- (length *ticks*)))))
91
     (when (zerop unit) (setf unit 1))
92
     (with-output-to-string (s)
93
       (loop :for n :in numbers
94
             :for nth := (floor (- n min) unit)
95
             :do (princ (svref *ticks* nth) s)))))
96
 
97
 
98
 (setf (documentation 'spark 'function) "
99
 Generates a sparkline string for a list of real numbers.
100
 
101
 Usage: SPARK <numbers> &key <min> <max> <key>
102
 
103
   * <numbers> ::= <list> of <real-number>
104
   * <min>     ::= { <null> | <real-number> }, default is NIL
105
   * <max>     ::= { <null> | <real-number> }, default is NIL
106
   * <key>     ::= <function>
107
 
108
   * <numbers> ~ data.
109
   * <min>    ~ lower bound of output.
110
                NIL means the minimum value of the data.
111
   * <max>    ~ upper bound of output.
112
                NIL means the maximum value of the data.
113
   * <key>    ~ function for preparing data.
114
 
115
 Examples:
116
 
117
   (spark '(1 0 1 0))     => \"█▁█▁\"
118
   (spark '(1 0 1 0 0.5)) => \"█▁█▁▄\"
119
   (spark '(1 0 1 0 -1))  => \"█▄█▄▁\"
120
 
121
   (spark '(0 30 55 80 33 150))                 => \"▁▂▃▅▂█\"
122
   (spark '(0 30 55 80 33 150) :min -100)       => \"▃▄▅▆▄█\"
123
   (spark '(0 30 55 80 33 150) :max 50)         => \"▁▅██▅█\"
124
   (spark '(0 30 55 80 33 150) :min 30 :max 80) => \"▁▁▄█▁█\"
125
 
126
   (spark '(0 1 2 3 4 5 6 7 8) :key (lambda (x) (sin (* x pi 1/4))))
127
   => \"▄▆█▆▄▂▁▂▄\"
128
   (spark '(0 1 2 3 4 5 6 7 8) :key (lambda (x) (cos (* x pi 1/4))))
129
   => \"█▆▄▂▁▂▄▆█\"
130
 
131
  For more examples, see cl-spark/spark-test.lisp
132
 ")
133
 
134
 
135
 ;;--------------------------------------------------------------------
136
 ;; Vspark
137
 ;;--------------------------------------------------------------------
138
 ;; #(#\▏ #\▎ #\▍ #\▌ #\▋ #\▊ #\▉ #\█)
139
 
140
 ;; (code-char 9615) => #\LEFT_ONE_EIGHTH_BLOCK     <=> #\▏
141
 ;; (code-char 9614) => #\LEFT_ONE_QUARTER_BLOCK    <=> #\▎
142
 ;; (code-char 9613) => #\LEFT_THREE_EIGHTHS_BLOCK  <=> #\▍
143
 ;; (code-char 9612) => #\LEFT_HALF_BLOCK           <=> #\▌
144
 ;; (code-char 9611) => #\LEFT_FIVE_EIGHTHS_BLOCK   <=> #\▋
145
 ;; (code-char 9610) => #\LEFT_THREE_QUARTERS_BLOCK <=> #\▊
146
 ;; (code-char 9609) => #\LEFT_SEVEN_EIGHTHS_BLOCK  <=> #\▉
147
 ;; (code-char 9608) => #\FULL_BLOCK                <=> #\█
148
 ;; (code-char 9616) => #\RIGHT_HALF_BLOCK          <=> #\▐
149
 ;; (code-char 9621) => #\RIGHT_ONE_EIGHTH_BLOCK    <=> #\▕
150
 
151
 (defvar *vticks*
152
   (vector (code-char 9615) (code-char 9614) (code-char 9613)
153
           (code-char 9612) (code-char 9611) (code-char 9610)
154
           (code-char 9609) (code-char 9608))
155
   "
156
 A simple-vector of characters for representation of vartical
157
 sparklines. Default is #(#\▏ #\▎ #\▍ #\▌ #\▋ #\▊ #\▉ #\█).
158
 
159
 Examples:
160
 
161
   ;; Japan GDP growth rate, annal
162
   ;; see. http://data.worldbank.org/indicator/NY.GDP.MKTP.KD.ZG
163
   (defparameter growth-rate
164
    '((2007 . 2.192186) (2008 . -1.041636) (2009 . -5.5269766)
165
      (2010 . 4.652112) (2011 . -0.57031655) (2012 . 1.945)))
166
 
167
   (vspark growth-rate :key #'cdr :labels (mapcar #'car growth-rate))
168
   =>
169
   \"
170
        -5.5269766        -0.4374323         4.652112
171
        ˫---------------------+---------------------˧
172
   2007 ██████████████████████████████████▏
173
   2008 ███████████████████▊
174
   2009 ▏
175
   2010 ████████████████████████████████████████████
176
   2011 █████████████████████▉
177
   2012 █████████████████████████████████▏
178
   \"
179
 
180
   (let ((*vticks* #(#\- #\0 #\+)))
181
     (vspark growth-rate :key (lambda (y-r) (float-sign (cdr y-r)))
182
                         :labels (mapcar #'car growth-rate)
183
                         :size 1))
184
   =>
185
   \"
186
   2007 +
187
   2008 -
188
   2009 -
189
   2010 +
190
   2011 -
191
   2012 +
192
   \"
193
 ")
194
 
195
 (defun vspark (numbers &key min max key (size 50) labels title (scale? t) (newline? t))
196
   (check-type numbers  list)
197
   (check-type min      (or null real))
198
   (check-type max      (or null real))
199
   (check-type key      (or symbol function))
200
   (check-type size     (integer 1 *))
201
   (check-type labels   list)
202
 
203
   (when key (setf numbers (mapcar key numbers)))
204
 
205
   ;; Empty data case:
206
   (when (null numbers)
207
     (RETURN-FROM vspark ""))
208
 
209
   ;; Ensure min is the minimum number.
210
   (if (null min)
211
       (setf min (reduce #'min numbers))
212
       (setf numbers (mapcar (lambda (n) (max n min)) numbers)))
213
 
214
   ;; Ensure max is the maximum number.
215
   (if (null max)
216
       (setf max (reduce #'max numbers))
217
       (setf numbers (mapcar (lambda (n) (min n max)) numbers)))
218
 
219
   ;; Check max ~ min.
220
   (cond ((< max min) (error "max ~S < min ~S." max min))
221
         ((= max min) (incf max))        ; ensure all bars are in min.
222
         (t nil))
223
 
224
   (let ((max-lengeth-label nil))
225
     (when labels
226
       ;; Ensure num labels equals to num numbers.
227
       (let ((diff (- (length numbers) (length labels))))
228
         (cond ((plusp diff)
229
                ;; Add padding lacking labels not to miss data.
230
                (setf labels (append labels (loop :repeat diff :collect ""))))
231
               ((minusp diff)
232
                ;; Remove superfluous labels to remove redundant spaces.
233
                (setf labels (butlast labels (abs diff))))
234
               (t nil)))
235
       ;; Find max-lengeth-label.
236
       (setf max-lengeth-label
237
             (reduce #'max labels
238
                     :key (lambda (label)
239
                            (if (stringp label)
240
                                (length label)
241
                                (length (format nil "~A" label))))))
242
       ;; Canonicalize labels.
243
       (let* ((control-string (format nil "~~~D,,@A " max-lengeth-label)))
244
         (setf labels
245
               (mapcar (lambda (label) (format nil control-string label))
246
                       labels)))
247
       ;; Reduce size for max-lengeth-label.
248
       ;;  * 1 is space between label and bar
249
       ;;  * ensure minimum size 1
250
       (setf size (max 1 (- size 1 max-lengeth-label))))
251
 
252
     (let* ((num-content-ticks (1- (length *vticks*)))
253
            (unit (/ (- max min) (* size num-content-ticks)))
254
            (result '()))
255
       (when (zerop unit) (setf unit 1))
256
 
257
       (loop :for n :in numbers
258
             :for i :from 0
259
             :do (when labels (push (nth i labels) result))
260
                 (push (generate-bar n unit min max num-content-ticks)
261
                       result)
262
             :finally (setf result (nreverse result)))
263
 
264
       (when scale?
265
         (awhen (generate-scale min max size max-lengeth-label)
266
           (push it result)))
267
 
268
       (when title
269
         (awhen (generate-title title size max-lengeth-label)
270
           (push it result)))
271
 
272
       (if newline?
273
           (apply #'string-concat (push #.(format nil "~%") result))
274
           (string-right-trim '(#\Newline)
275
                              (apply #'string-concat result))))))
276
 
277
 
278
 (setf (documentation 'vspark 'function) "
279
 Generates a vartical sparkline string for a list of real numbers.
280
 
281
 Usage: VSPARK <numbers> &key <min> <max> <key> <size>
282
                              <labels> <title> <scale?> <newline?>
283
 
284
   * <numbers>  ::= <list> of <real-number>
285
   * <min>      ::= { <null> | <real-number> }, default is NIL
286
   * <max>      ::= { <null> | <real-number> }, default is NIL
287
   * <key>      ::= <function>
288
   * <size>     ::= <integer 1 *>, default is 50
289
   * <labels>   ::= <list>
290
   * <title>    ::= <object>, default is NIL
291
   * <scale?>   ::= <generalized-boolean>, default is T
292
   * <newline?> ::= <generalized-boolean>, default is T
293
 
294
   * <numbers>  ~ data.
295
   * <min>      ~ lower bound of output.
296
                  NIL means the minimum value of the data.
297
   * <max>      ~ upper bound of output.
298
                  NIL means the maximum value of the data.
299
   * <key>      ~ function for preparing data.
300
   * <size>     ~ maximum number of output columns (contains label).
301
   * <labels>   ~ labels for data.
302
   * <title>    ~ If title is too big for size, it is not printed.
303
   * <scale?>   ~ If T, output graph with scale for easy to see.
304
                  If string length of min and max is too big for size,
305
                  the scale is not printed.
306
   * <newline?> ~ If T, output graph with newlines for easy to see.
307
 
308
 
309
 Examples:
310
 
311
   ;; Life expectancy by WHO region, 2011, bothsexes
312
   ;; see. http://apps.who.int/gho/data/view.main.690
313
   (defvar life-expectancies '((\"Africa\" 56)
314
                               (\"Americans\" 76)
315
                               (\"South-East Asia\" 67)
316
                               (\"Europe\" 76)
317
                               (\"Eastern Mediterranean\" 68)
318
                               (\"Western Pacific\" 76)
319
                               (\"Global\" 70)))
320
 
321
   (vspark life-expectancies :key #'second :scale? nil :newline? nil)
322
   =>
323
   \"▏
324
   ██████████████████████████████████████████████████
325
   ███████████████████████████▌
326
   ██████████████████████████████████████████████████
327
   ██████████████████████████████▏
328
   ██████████████████████████████████████████████████
329
   ███████████████████████████████████▏\"
330
 
331
   (vspark life-expectancies :min 50 :max 80
332
                             :key    #'second
333
                             :labels (mapcar #'first life-expectancies)
334
                             :title \"Life Expectancy\")
335
   =>
336
   \"
337
                    Life Expectancy                  
338
                         50           65           80
339
                         ˫------------+-------------˧
340
                  Africa █████▋
341
               Americans ████████████████████████▎
342
         South-East Asia ███████████████▉
343
                  Europe ████████████████████████▎
344
   Eastern Mediterranean ████████████████▊
345
         Western Pacific ████████████████████████▎
346
                  Global ██████████████████▋
347
   \"
348
 
349
   (vspark '(0 1 2 3 4 5 6 7 8) :key (lambda (x) (sin (* x pi 1/4)))
350
                                :size 20)
351
   \"
352
   -1.0     0.0     1.0
353
   ˫--------+---------˧
354
   ██████████▏
355
   █████████████████▏
356
   ████████████████████
357
   █████████████████▏
358
   ██████████▏
359
   ██▉
360
   ▏
361
   ██▉
362
   █████████▉
363
   \"
364
 
365
   (vspark '(0 1 2 3 4 5 6 7 8) :key (lambda (x) (sin (* x pi 1/4)))
366
                                :size 10)
367
   =>
368
   \"
369
   -1.0   1.0
370
   ˫--------˧
371
   █████▏
372
   ████████▏
373
   ██████████
374
   ████████▏
375
   █████▏
376
   █▏
377
   ▏
378
   █▏
379
   ████▏
380
   \"
381
 
382
   (vspark '(0 1 2 3 4 5 6 7 8) :key (lambda (x) (sin (* x pi 1/4)))
383
                                :size 1)
384
   =>
385
   \"
386
   ▌
387
   ▊
388
   █
389
   ▊
390
   ▌
391
   ▎
392
   ▏
393
   ▎
394
   ▌
395
   \"
396
 
397
   For more examples, see cl-spark/spark-test.lisp
398
 ")
399
 
400
 (defun generate-bar (number unit min max num-content-ticks)
401
   (multiple-value-bind
402
         (units frac) (floor (- number min) (* unit num-content-ticks))
403
     (with-output-to-string (s)
404
       (let ((most-tick (svref *vticks* num-content-ticks)))
405
         (dotimes (i units) (princ most-tick s))
406
         (unless (= number max)
407
           ;; max number need not frac.
408
           ;; if number = max, then always frac = 0.
409
           (princ (svref *vticks* (floor frac unit))
410
                  s))
411
         (terpri s)))))
412
 
413
 (defun generate-title (title size max-lengeth-label)
414
   (let* ((title-string (princ-to-string title))
415
          (mid (floor (- (if max-lengeth-label
416
                             (+ 1 size max-lengeth-label)
417
                             size)
418
                         (length title-string)) 2)))
419
     (when (plusp mid)
420
       (format nil "~A~%"
421
               (replace (make-string (if max-lengeth-label
422
                                         (+ 1 size max-lengeth-label)
423
                                         size)
424
                                     :initial-element #\Space)
425
                        title-string :start1 mid)))))
426
 
427
 (defun ensure-non-double-float (x)
428
   (if (integerp x) x (float x 0.0)))
429
 
430
 (defun to-string (n)
431
   (princ-to-string (ensure-non-double-float n)))
432
 
433
 ;; (code-char 743) => #\MODIFIER_LETTER_MID_TONE_BAR              <=> #\˧
434
 ;; (code-char 746) => #\MODIFIER_LETTER_YANG_DEPARTING_TONE_MARK  <=> #\˫
435
 (defun generate-scale (min max size max-lengeth-label)
436
   (let* ((min-string  (to-string min))
437
          (max-string  (to-string max))
438
          (num-padding (- size (length min-string) (length max-string))))
439
     (when (plusp num-padding)
440
       (let* ((mid        (/ (+ max min) 2))
441
              (mid-string (to-string mid))
442
              (num-indent (aif max-lengeth-label (1+ it) 0)))
443
         (if (and (< (length mid-string) num-padding)
444
                  (/= min mid)
445
                  (/= mid max))
446
             ;; A. mid exist case:
447
             (format nil "~V,0T~V<~A~;~A~;~A~>~
448
                        ~%~V,0T~V,,,'-<~A~;~A~;~A~>~%"
449
                     num-indent size min-string mid-string max-string
450
                     num-indent size #.(code-char 747) #\+ #.(code-char 743))
451
             ;; B. no mid exist case:
452
             (format nil "~V,0T~V<~A~;~A~>~
453
                        ~%~V,0T~V,,,'-<~A~;~A~>~%"
454
                     num-indent size min-string max-string
455
                     num-indent size #.(code-char 747) #.(code-char 743)))))))
456
 ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������