From 6082cd0f941819236d28c44c4cea37ecfa422f8d Mon Sep 17 00:00:00 2001
From: Bob Rogers
Date: Sat, 17 Feb 2024 12:13:24 -0800
Subject: [PATCH] Add a pumpernickel histogram and make all predictions >=20%
* rgr-pumpernickel.el:
+ (rgr-pump--draw-histogram): New ASCII-art hack.
+ (rgr-pump--make-prediction): Split this out, show all weeks with
at least 20% probability.
---
rgr-pumpernickel.el | 73 +++++++++++++++++++++++++++++++++++++++------
1 file changed, 64 insertions(+), 9 deletions(-)
diff --git a/rgr-pumpernickel.el b/rgr-pumpernickel.el
index fdea453..2b5481f 100644
--- a/rgr-pumpernickel.el
+++ b/rgr-pumpernickel.el
@@ -27,6 +27,66 @@
(days-to-time (- days (time-to-days 0)))))
(format-time-string "%Y-%m-%d" time)))
+(defun rgr-pump--draw-histogram (hist)
+ ;; hist is an alist of (days . count) sorted in descending order of count. We
+ ;; rely on the fact that days are all divisible by 7, the days are mostly on
+ ;; the order of 3-16 weeks, and we're interested in probabilities rather than
+ ;; raw counts so we can hardwire the geometry. Note that we skip (0,0).
+ (let ((total 0)
+ (max-count 0) (max-days 0)
+ (chars-per-count 0)
+ (histogram nil))
+ ;; Find total, max-count, and max-days.
+ (dolist (pair hist)
+ (let ((days (car pair)) (count (cdr pair)))
+ (cl-incf total count)
+ (when (< max-count count)
+ (setq max-count count))
+ (when (< max-days days)
+ (setq max-days days))))
+ ;; Make the histogram ten characters high.
+ (setq chars-per-count (/ 10.0 max-count))
+ ;; Build a histogram of weeks as a vector.
+ (unless (zerop (mod max-days 7))
+ (error "the fundamental assumption of weeks is broken"))
+ (setq histogram (make-vector (1+ (floor max-days 7)) 0))
+ (dolist (pair hist)
+ (let ((days (car pair)) (count (cdr pair)))
+ (setf (aref histogram (floor days 7)) count)))
+ ;; Allocate three characters to each week.
+ (cl-do ((height 9 (1- height))
+ (str (make-string (* (length histogram) 3) ?\ )
+ (make-string (* (length histogram) 3) ?\ )))
+ ((<= height 0))
+ (dotimes (idx (length histogram))
+ (when (and (> idx 0)
+ (>= (* (aref histogram idx) chars-per-count) height))
+ (setf (aref str (+ 2 (* idx 3))) ?\*)))
+ (insert (replace-regexp-in-string " +$" "" str) "\n"))
+ (insert " ") ;; the missing zero.
+ (dotimes (idx (length histogram))
+ (when (> idx 0)
+ (insert (format "%3d" idx))))
+ (insert " weeks\n")))
+
+(defun rgr-pump--make-prediction (last-day n hist)
+ ;; last-day is the rgr-date-to-day of the most recent pumpernickel week for
+ ;; basing predictions, hist is an alist of (days . count) sorted in descending
+ ;; order of count, and n is the total count. Show all predicted dates with
+ ;; more than 20% of the total probability.
+ (insert "\nNext week is estimated to start ")
+ (let ((need-comma nil))
+ (dolist (pair hist)
+ (let ((prob (/ (* (cdr pair) 100.0) n)))
+ (when (>= prob 20)
+ (insert (if need-comma ", or " "")
+ (format "%s (%d%%)"
+ (rgr-format-days (+ last-day (car pair)))
+ prob))
+ (setq need-comma t)))))
+ (insert ".\n")
+ (fill-paragraph))
+
;;;###autoload
(defun rgr-show-pumpernickel-intervals ()
"Print a table of intervals between known pumpernickel weeks.
@@ -66,15 +126,10 @@ The dominant intervals correspond (so far) to 6 or 5 weeks."
(cl-incf n count)
(push (cons i count) hist))))
(setq hist (sort hist #'(lambda (a b) (> (cdr a) (cdr b)))))
- (insert
- (apply #'format
- "\nNext week is estimated to start %s or %s.\n"
- (mapcar #'(lambda (pair)
- (when pair
- (format "%s (%d%%)"
- (rgr-format-days (+ last-day (car pair)))
- (/ (* (cdr pair) 100.0) n))))
- (list (car hist) (car (cdr hist))))))))))
+ ;; (insert (prin1-to-string hist))
+ (insert "\n")
+ (rgr-pump--draw-histogram hist)
+ (rgr-pump--make-prediction last-day n hist)))))
;; (/ (rgr-days-between "2023 Dec 13" "2023 Oct 18") 7) 8
--
2.43.4