Categories: geek » emacs

RSS - Atom - Subscribe via email

Using bug-hunter to quickly find a problem in my long Emacs configuration

| emacs

I noticed that author names in my mastodon.el timeline were no longer getting highlighted. Since it behaved correctly when I used emacs -Q, I knew the problem was somewhere in my configuration. Problem: my configuration is very long. (Uh, my .el seems to have grown to be about 460KB…) I started writing some code to help me bisect it, but fortunately I remembered using a package to do that a long time ago. After a little digging around, I found bug-hunter again. I patched it to allow me to specify a header and footer: 

(defvar bug-hunter-header nil "Emacs Lisp sexp to add at the beginning of the file.")
(defvar bug-hunter-footer nil "Emacs Lisp sexp to add at the end of the file.")

(defun bug-hunter--print-to-temp (sexp)
  "Print SEXP to a temp file and return the file name."
  (let ((print-length nil)
        (print-level nil)
        (file (make-temp-file "bug-hunter")))
    (with-temp-file file
      (when bug-hunter-header (print bug-hunter-header (current-buffer)))
      (print sexp (current-buffer))
      (when bug-hunter-footer (print bug-hunter-footer (current-buffer))))
    file))

That allowed me to set up this header and footer: 

(setq bug-hunter-header
      '(progn
         (package-initialize)
         (use-package quelpa)
         (use-package quelpa-use-package)
         (use-package hydra :commands defhydra)
         (use-package use-package-hydra)))
(setq bug-hunter-footer '(load-file "/tmp/mastodon-test.el"))

where mastodon-test.el was this file: 

(package-initialize)
(add-to-list 'load-path "~/vendor/mastodon.el/lisp")
(require 'mastodon)
(setq mastodon-active-user "sachac"
      mastodon-instance-url "https://emacs.ch")
(mastodon)

I wasn't sure how to use bug-hunter's support for assertions because of the asynchronous retrieval of the Mastodon timeline, but at least I could use that code to set things up.

Then I used bug-hunter-file to split up the Emacs Lisp file tangled out of my literate configuration. All I had to do was wait for the Mastodon timeline to show up, quit Emacs, and answer y if I saw the bug or n if I didn't.

Here's what the result was: 

You have asked to do an interactive hunt, here's how it goes.
1) I will start a new Emacs instance, which opens a new frame.
2) You will try to reproduce your problem on the new frame.
3) When you’re done, close that frame.
4) I will ask you if you managed to reproduce the problem.
5) We will repeat steps up to 13 times, so hang tight!
Doing some initial tests...
Initial tests done. Hunting for the cause...
"~/sync/emacs/Sacha.el", line 6893 pos 0:
  The assertion returned the following value here:
    t
  Caused by the following expression:
    (use-package highlight-defined :ensure t :custom
      (highlight-defined-face-use-itself t)
      :hook
      (help-mode . highlight-defined-mode)
      (emacs-lisp-mode . highlight-defined-mode))

That's weird, since highlight-defined shouldn't have affected mastodon, but okay. I'm going to skip using highlight-defined for now.

If you're tracking down a weird change in your Emacs configuration file, you might find bug-hunter useful too. It's available on ELPA, or you can get it from Github.

View org source for this post
View or add comments (Disqus), or e-mail me at sacha@sachachua.com

Fixing my old ambiguous sketch references

| blogging, 11ty, emacs

At some point during the conversion of my blog from Wordpress to 11ty, I wanted to change my sketch links to use a custom shortcode instead of referring to the sketch in my old wp-uploads directory. Because Wordpress changed the filenames a little, I used the ID at the start of the filename. I forgot that many of my filenames from 2013 to 2015 just had the date without a uniquely identifying letter or number suffix, so many old references were ambiguous and my static site generator just linked to the first matching file. When I was listening to my old monthly reviews as part of my upcoming 10-year review, I noticed the repeated links. So I wrote these functions to help me find and replace markup of the form sketchLink "2013-10-06" with sketchLink "2013-10-06 Daily drawing - thinking on paper #drawing", replacing references to the same date with the next sketch in the list. I figured that would be enough to get the basic use case sorted out (usually a list of sketches in my monthly/weekly reviews), taking advantage of the my-list-sketches function I defined in my Emacs config. 

(defun my-replace-duplicate-sketch-list-references ()
  (interactive)
  (goto-char (point-min))
  (let (seen)
    (while (re-search-forward "sketchLink \\\"\\([0-9][0-9][0-9][0-9]-[0-9][0-9]-[0-9][0-9]\\)\\\""
                              nil t)
      (if (assoc (match-string 1) seen)
          (setcdr (assoc (match-string 1) seen) (1+ (assoc-default (match-string 1) seen)))
        (setq seen (cons (cons (match-string 1) 1) seen))))
    (mapc (lambda (entry)
            (goto-char (point-min))
            (mapc (lambda (sketch)
                    (if (re-search-forward (format "sketchLink \\\"\\(%s\\)\\\""
                                                   (regexp-quote (car entry))) nil t)
                        (replace-match (save-match-data (file-name-sans-extension sketch))
                                       nil t nil 1)
                      (message "Skipping %s possible ref to %s"
                               (buffer-file-name)
                               sketch)))
                  (my-list-sketches (concat "^" (regexp-quote (car entry))) nil '("~/sync/sketches"))))
          seen)))

Sometimes I needed to delete the whole list and start again: 

(defun my-insert-sketch-list-between (start-date end-date)
  (insert
   (mapconcat
    (lambda (f)
      (format "<li>%s sketchLink \"%s\" %s</li>\n"
              (concat "{" "%")  ; avoid confusing 11ty when I export this
              (file-name-sans-extension f)
              (concat "%" "}")))
    (sort (seq-filter
           (lambda (f) (and (string< f end-date) (not (string< f start-date))))
           (my-list-sketches nil nil '("~/sync/sketches")))
          'string<)
    "")))

I used find-grep-dired to search for sketchLink \"[0-9][0-9][0-9][0-9]-[0-9][0-9]-[0-9][0-9]\" and then I just used a keyboard macro to process each file.

Anyway, really old monthly reviews like this one for October 2013 should mostly make sense again. I could probably pull out the correct references from the Wordpress database backup, but what I've got is probably okay. I would probably have gotten much grumpier trying to do this without Emacs Lisp. Yay Emacs!

View org source for this post
View or add comments (Disqus), or e-mail me at sacha@sachachua.com

2023-01-09 Emacs news

| emacs, emacs-news

Links from reddit.com/r/emacs, r/orgmode, r/spacemacs, r/planetemacs, Hacker News, lobste.rs, planet.emacslife.com, YouTube, the Emacs NEWS file, Emacs Calendar, emacs-devel, and lemmy/c/emacs. Thanks to Andrés Ramírez for emacs-devel links. Do you have an Emacs-related link or announcement? Please e-mail me at sacha@sachachua.com. Thank you!

View or add comments (Disqus), or e-mail me at sacha@sachachua.com

Moving my Org post subtree to the 11ty directory

| 11ty, org, emacs, blogging

I sometimes want to move the Org source for my blog posts to the same directory as the 11ty-exported HTML. This should make it easier to update and reexport blog posts in the future. The following code copies or moves the subtree to the 11ty export directory. 

(defun my-org-11ty-copy-subtree (&optional do-cut)
  "Copy the subtree for the current post to the 11ty export directory.
With prefix arg, move the subtree."
  (interactive (list current-prefix-arg))
  (let* ((file-properties
          (org-element-map
              (org-element-parse-buffer)
              'keyword
            (lambda (el)
              (list
               (org-element-property :key el)
               (org-element-property :value el)
               (buffer-substring-no-properties
                (org-element-property :begin el)
                (org-element-property :end el))))))
         (entry-properties (org-entry-properties))
         (filename (expand-file-name
                    "index.org"
                    (expand-file-name
                     (assoc-default "EXPORT_ELEVENTY_FILE_NAME" entry-properties) 
                     (car (assoc-default "ELEVENTY_BASE_DIR" file-properties))))))
    (unless (file-directory-p (file-name-directory filename))
      (make-directory (file-name-directory filename) t))
    ;; find the heading that sets the current EXPORT_ELEVENTY_FILE_NAME
    (goto-char
     (org-find-property "EXPORT_ELEVENTY_FILE_NAME" (org-entry-get-with-inheritance "EXPORT_ELEVENTY_FILE_NAME")))
    (org-copy-subtree 1 (if do-cut 'cut))
    (with-temp-file filename
      (org-mode)
      (insert (or
               (mapconcat (lambda (file-prop) (elt file-prop 2))
                          file-properties
                          "")
               "")
              "\n")
      (org-yank))
    (find-file filename)
    (goto-char (point-min))))

Then this adds a link to it: 

(defun my-org-export-filter-body-add-index-link (string backend info)
  (if (and
       (member backend '(11ty html))
       (plist-get info :file-name)
       (plist-get info :base-dir)
       (file-exists-p (expand-file-name
                       "index.org"
                       (expand-file-name
                        (plist-get info :file-name)
                        (plist-get info :base-dir)))))
      (concat string
              (format "<div><a href=\"%sindex.org\">View org source for this post</a></div>"
                      (plist-get info :permalink)))
    string))

(with-eval-after-load 'ox
  (add-to-list 'org-export-filter-body-functions #'my-org-export-filter-body-add-index-link))

Then I want to wrap the whole thing up in an export function: 

(defun my-org-11ty-export (&optional async subtreep visible-only body-only ext-plist)
  (let* ((info (org-11ty--get-info subtreep visible-only))
         (file (org-11ty--base-file-name subtreep visible-only)))
    (unless (string= (plist-get info :input-file)
                     (expand-file-name
                      "index.org"
                      (expand-file-name
                       (plist-get info :file-name)
                       (plist-get info :base-dir))))
      (save-window-excursion
        (my-org-11ty-copy-subtree)))
    (org-11ty-export-to-11tydata-and-html async subtreep visible-only body-only ext-plist)
    (my-org-11ty-find-file)))

Now to figure out how to override the export menu. Totally messy hack! 

(with-eval-after-load 'ox-11ty
  (map-put (caddr (org-export-backend-menu (org-export-get-backend '11ty)))
           ?o (list "To Org, JSON, HTML" 'my-org-11ty-export)))
View org source for this post
View or add comments (Disqus), or e-mail me at sacha@sachachua.com

Org Mode: Including portions of files between two regular expressions

| org, emacs

I'd like to refer to snippets of code, but lines are too fragile to use as references for code and posts that I want to easily update. I'd like to specify a from-regexp and a to-regexp instead in order to collect the lines between those regexps (including the ones with the regexps themselves). org-export-expand-include-keyword looked a bit hairy to extend since it uses regular expressions to match parameter values. For this quick experiment, I decided to make a custom link type instead. This allows me to refer to parts of code with a link like this:

[[my-include:~/proj/static-blog/assets/css/style.css::from-regexp=Start of copy code&to-regexp=End of copy code&wrap=src js]]

which will turn into this snippet from my stylesheet: 

/* Start of copy code */
pre.src { margin: 0 }
.org-src-container {
    position: relative;
    margin: 0 0;
    padding: 1.75rem 0 1.75rem 1rem;
}
summary { position: relative; }
summary .org-src-container { padding: 0 }
summary .org-src-container pre.src { margin: 0 }
.org-src-container button.copy-code, summary button.copy-code {
    position: absolute;
    top: 0px;
    right: 0px;
}
/* End of copy code */

Here's the Emacs Lisp code to do that. my-include-complete function reuses my-include-open to narrow to the file, and my-include-complete uses consult--line so that we can specify the prompt. 

(org-link-set-parameters
 "my-include"
 :follow #'my-include-open
 :export #'my-include-export
 :complete #'my-include-complete)

(defun my-include-open (path &optional _)
  "Narrow to the region specified in PATH."
  (let (params start end)
    (if (string-match "^\\(.*+?\\)::\\(.*+\\)" path)
        (setq params (save-match-data (org-protocol-convert-query-to-plist (match-string 2 path)))
              path (match-string 1 path)))
    (find-file path)
    (setq start
          (or
           (and
            (plist-get params :from-regexp)
            (progn
              (goto-char (point-min))
              (when (re-search-forward (url-unhex-string (plist-get params :from-regexp)))
                (line-beginning-position))))
           (progn
             (goto-char (point-min))
             (point))))
    (setq end
          (or
           (and
            (plist-get params :to-regexp)
            (progn
              (when (re-search-forward (url-unhex-string (plist-get params :to-regexp)))
                (line-end-position))))
           (progn
             (goto-char (point-max))
             (point))))
    (when (or (not (= start (point-min)))
              (not (= end (point-max))))
      (narrow-to-region start end))))
    
(defun my-include-export (path _ format _)
  "Export PATH to FORMAT using the specified wrap parameter."
  (let (params body start end)
    (when (string-match "^\\(.*+?\\)::\\(.*+\\)" path)
      (setq params (save-match-data (org-protocol-convert-query-to-plist (match-string 2 path)))))
    (save-window-excursion
      (my-include-open path)
      (setq body (buffer-substring (point-min) (point-max))))
    (with-temp-buffer
      (when (plist-get params :wrap)
        (let* ((wrap (plist-get params :wrap))
               block args)
          (when (string-match "\\<\\(\\S-+\\)\\( +.*\\)?" wrap)
            (setq block (match-string 1 wrap))
            (setq args (match-string 2 wrap)) 
            (setq body (format "#+BEGIN_%s%s\n%s\n#+END_%s\n"
                               block (or args "")
                               body
                               block)))))
      (insert body)
      (org-export-as format nil nil t))))

(defun my-include-complete ()
  "Include a section of a file from one line to another, specified with regexps."
  (interactive)
  (require 'consult)
  (let ((file (read-file-name "File: ")))
    (save-window-excursion
      (find-file file)
      (concat "my-include:"
              file
              "::from-regexp="
              (let ((curr-line (line-number-at-pos
                                (point)
                                consult-line-numbers-widen))
                    (prompt "From line: "))
                (goto-char (point-min))
                (consult--line
                 (or (consult--with-increased-gc
                      (consult--line-candidates
                       nil
                       curr-line))
                     (user-error "No lines"))
                 :curr-line curr-line
                 :prompt prompt)        
                (url-hexify-string
                 (regexp-quote (buffer-substring (line-beginning-position) (line-end-position)))))
              "&to-regexp="
              (let ((curr-line (line-number-at-pos
                                (point)
                                consult-line-numbers-widen))
                    (prompt "To line: "))
                (goto-char (point-min))
                (consult--line
                 (or (consult--with-increased-gc
                      (consult--line-candidates
                       nil
                       curr-line))
                     (user-error "No lines"))
                 :curr-line curr-line
                 :prompt prompt)        
                (url-hexify-string
                 (regexp-quote (buffer-substring (line-beginning-position) (line-end-position)))))
              "&wrap=src " (replace-regexp-in-string "-mode$" "" (symbol-name major-mode))))))
This is part of my Emacs configuration.
View or add comments (Disqus), or e-mail me at sacha@sachachua.com

Using the calendar-date-echo-text variable to help plot a heatmap on a year-long calendar in Emacs

| emacs
output-2023-01-06-10-26-49.gif
Figure 1: Sketch heatmap from 2008-2023

Building on Display a calendar heat map using Emacs Lisp, I figured out how to use calendar-date-echo-text to store the date so that I can pick it up when plotting the heatmap: 

;; This seems to be the only way we can hack the date in for now
(setq calendar-date-echo-text '(apply #'format (list "%04d-%02d-%02d" year month day)))

(defun my-calendar-heat-map-using-echo-text (&rest _)
  (when my-calendar-count-scaled
    (save-excursion
      (goto-char (point-min))
      (while (not (eobp))
        (let* ((help (get-text-property (point) 'help-echo))
               (next-change
                (or (next-single-property-change (point) 'help-echo)
                    (point-max)))
               (inhibit-read-only t)
               (count-scaled (and help
                                  (assoc-default
                                   help
                                   my-calendar-count-scaled))))
          (when (and help
                     (string-match "[0-9][0-9][0-9][0-9]-[0-9][0-9]-[0-9][0-9]" help)
                     count-scaled)
            (put-text-property
             (point) (+ 2 (point))
             'face (intern (format "calendar-scale-%d" count-scaled))))
          (goto-char next-change))))))

(advice-add #'calendar :after #'my-calendar-heat-map-using-echo-text)
(advice-add #'calendar-redraw :after #'my-calendar-heat-map-using-echo-text)
(advice-add #'year-calendar :after #'my-calendar-heat-map-using-echo-text)
(add-hook 'calendar-move-hook #'my-calendar-heat-map-using-echo-text)

So now I don't need the advice around calendar-generate-month, just the code that sets up the faces, loads the values, and figures out the data.

Previous source code (tweaked foreground colours) 
(defface calendar-scale-1  '((((background light)) :foreground "black" :background "#eceff1")
                             (((background dark))  :foreground "white" :background "#263238")) "")
(defface calendar-scale-2  '((((background light)) :foreground "black" :background "#cfd8dc")
                             (((background dark))  :foreground "white" :background "#37474f")) "")
(defface calendar-scale-3  '((((background light)) :foreground "black" :background "#b0bec5")
                             (((background dark))  :foreground "white" :background "#455a64")) "")
(defface calendar-scale-4  '((((background light)) :foreground "black" :background "#90a4ae")
                             (((background dark))  :foreground "white" :background "#546e7a")) "")
(defface calendar-scale-5  '((((background light)) :foreground "black" :background "#78909c")
                             (((background dark))  :foreground "white" :background "#607d8b")) "")
(defface calendar-scale-6  '((((background light)) :foreground "white" :background "#607d8b")
                             (((background dark))  :foreground "black" :background "#78909c")) "")
(defface calendar-scale-7  '((((background light)) :foreground "white" :background "#546e7a")
                             (((background dark))  :foreground "black" :background "#90a4ae")) "")
(defface calendar-scale-8  '((((background light)) :foreground "white" :background "#455a64")
                             (((background dark))  :foreground "black" :background "#b0bec5")) "")
(defface calendar-scale-9  '((((background light)) :foreground "white" :background "#37474f")
                             (((background dark))  :foreground "black" :background "#cfd8dc")) "")
(defun my-count-calendar-entries (grouped-entries)
  (mapcar (lambda (entry) (cons (car entry) (length (cdr entry)))) grouped-entries))

(defface calendar-scale-10 '((((background light)) :foreground "white" :background "#263238")
                             (((background dark))  :foreground "black" :background "#eceff1")) "")

(defun my-scale-calendar-entries (grouped-entries &optional scale-max)
  (let* ((count (my-count-calendar-entries grouped-entries))
         (count-max (apply #'max (mapcar (lambda (o) (if (car o) (cdr o) 0)) count))))
    (mapcar (lambda (entry)
              (cons (car entry)
                    (/ (* 1.0 (or scale-max 1.0) (cdr entry)) count-max)))
            count)))

(defun my-scale-calendar-entries-logarithmically (grouped-entries &optional scale-max)
  (let* ((count (my-count-calendar-entries grouped-entries))
         (count-max (apply #'max (mapcar (lambda (o) (if (car o) (cdr o) 0)) count))))
    (mapcar (lambda (entry)
              (cons (car entry)
                    (/ (* 1.0 (or scale-max 1.0) (log (cdr entry))) (log count-max))))
            count)))

(defvar my-calendar-count-scaled nil "Values to display.")

Now I can have it display the last year of data or so. 

(defun my-calendar-visualize (values)
  (setq my-calendar-count-scaled values)
  (let* ((date (calendar-current-date))
         (month (calendar-extract-month date))
         (year (calendar-extract-year date)))
    (year-calendar month (1- year))))

The code to load the data stays the same.

Loading the data 
(defun my-calendar-visualize-journal-entries ()
  (interactive)
  (my-calendar-visualize
   (mapcar
    (lambda (o)
      (cons
       (car o)
       (ceiling (+ 1 (* 7.0 (cdr o))))))
    (my-scale-calendar-entries
     (seq-group-by #'my-journal-date
                   (cdr (pcsv-parse-file "~/Downloads/entries.csv")))))))

(defun my-calendar-visualize-sketches ()
  (interactive)
  (let ((my-calendar-sketches
         (assoc-delete-all
          nil
          (seq-group-by
           (lambda (o)
             (when (string-match "^\\([0-9][0-9][0-9][0-9]\\)[-_]?\\([0-9][0-9]\\)[-_]?\\([0-9][0-9]\\)" o)
               (format "%s-%s-%s"
                       (match-string 1 o)
                       (match-string 2 o)
                       (match-string 3 o))))
           (append
            (directory-files "~/sync/sketches" nil "\\.\\(png\\|jpg\\)\\'")
            (directory-files "~/sync/private-sketches" nil "\\.\\(png\\|jpg\\)\\'"))))))
    (my-calendar-visualize
     (mapcar
      (lambda (o)
        (cons (car o)
              ;; many days have just 1 sketch, so I set the low end of the scale
              ;; to make them visible, and use a logarithmic scale for the rest
              (ceiling (+ 3 (* 7.0 (cdr o))))))
      (my-scale-calendar-entries-logarithmically my-calendar-sketches)))))

(defun my-calendar-visualize-tantrums ()
  (interactive)
  (my-calendar-visualize
   (mapcar
    (lambda (o)
      (cons
       (car o)
       (ceiling (* 10.0 (cdr o)))))
    (my-scale-calendar-entries
     (seq-group-by #'my-journal-date
                   (seq-filter (lambda (o) (string-match "tantrum\\|grump\\|angry\\|meltdown"
                                                           (my-journal-note o)))
                               (cdr (pcsv-parse-file "~/Downloads/entries.csv"))))))))

Here's the code from lawlist's StackOverflow answer that displays the Emacs calendar for a year:

Source code for showing an Emacs calendar year 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                            ;;;
;;; Scroll a yearly calendar by month -- in a forwards or backwards direction. ;;;
;;;                                                                            ;;;
;;; To try out this example, evaluate the entire code snippet and type:        ;;;
;;;                                                                            ;;;
;;;     M-x year-calendar                                                      ;;;
;;;                                                                            ;;;
;;; To scroll forward by month, type the key:  >                               ;;;
;;;                                                                            ;;;
;;; To scroll backward by month, type the key:  <                              ;;;
;;;                                                                            ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(eval-after-load "calendar" '(progn
  (define-key calendar-mode-map "<" 'lawlist-scroll-year-calendar-backward)
  (define-key calendar-mode-map ">" 'lawlist-scroll-year-calendar-forward) ))

(defmacro lawlist-calendar-for-loop (var from init to final do &rest body)
  "Execute a for loop.
Evaluate BODY with VAR bound to successive integers from INIT to FINAL,
inclusive.  The standard macro `dotimes' is preferable in most cases."
  `(let ((,var (1- ,init)))
    (while (>= ,final (setq ,var (1+ ,var)))
      ,@body)))

(defun year-calendar (&optional month year)
  "Generate a one (1) year calendar that can be scrolled by month in each direction.
This is a modification of:  http://homepage3.nifty.com/oatu/emacs/calendar.html
See also:  http://ivan.kanis.fr/caly.el"
(interactive)
  (require 'calendar)
  (let* ((current-year (number-to-string (nth 5 (decode-time (current-time)))))
         (month (if month month
           (string-to-number
             (read-string "Please enter a month number (e.g., 1):  " nil nil "1"))))
         (year (if year year
           (string-to-number
             (read-string "Please enter a year (e.g., 2014):  "
               nil nil current-year)))))
    (switch-to-buffer (get-buffer-create calendar-buffer))
    (when (not (eq major-mode 'calendar-mode))
      (calendar-mode))
    (setq displayed-month month)
    (setq displayed-year year)
    (setq buffer-read-only nil)
    (erase-buffer)
    ;; horizontal rows
    (lawlist-calendar-for-loop j from 0 to 3 do
      ;; vertical columns
      (lawlist-calendar-for-loop i from 0 to 2 do
        (calendar-generate-month
          ;; month
          (cond
            ((> (+ (* j 3) i month) 12)
              (- (+ (* j 3) i month) 12))
            (t
              (+ (* j 3) i month)))
          ;; year
          (cond
            ((> (+ (* j 3) i month) 12)
             (+ year 1))
            (t
              year))
          ;; indentation / spacing between months
          (+ 5 (* 25 i))))
      (goto-char (point-max))
      (insert (make-string (- 10 (count-lines (point-min) (point-max))) ?\n))
      (widen)
      (goto-char (point-max))
      (narrow-to-region (point-max) (point-max)))
    (widen)
    (goto-char (point-min))
    (setq buffer-read-only t)))

(defun lawlist-scroll-year-calendar-forward (&optional arg event)
  "Scroll the yearly calendar by month in a forward direction."
  (interactive (list (prefix-numeric-value current-prefix-arg)
                     last-nonmenu-event))
  (unless arg (setq arg 1))
  (save-selected-window
    (if (setq event (event-start event)) (select-window (posn-window event)))
    (unless (zerop arg)
      (let ((month displayed-month)
            (year displayed-year))
        (calendar-increment-month month year arg)
        (year-calendar month year)))
    (goto-char (point-min))
    (run-hooks 'calendar-move-hook)))

(defun lawlist-scroll-year-calendar-backward (&optional arg event)
  "Scroll the yearly calendar by month in a backward direction."
  (interactive (list (prefix-numeric-value current-prefix-arg)
                     last-nonmenu-event))
  (lawlist-scroll-year-calendar-forward (- (or arg 1)) event))

It might be fun to scroll by year: 

(defun my-scroll-year-calendar-forward-year (&optional arg event)
  "Scroll the yearly calendar by year in a forward direction."
  (interactive (list (prefix-numeric-value current-prefix-arg)
                     last-nonmenu-event))
  (unless arg (setq arg 1))
  (save-selected-window
    (if (setq event (event-start event)) (select-window (posn-window event)))
    (unless (zerop arg)
      (setq displayed-year (+ (or arg 1) displayed-year))
      (year-calendar displayed-month displayed-year))
    (goto-char (point-min))
    (run-hooks 'calendar-move-hook)))

(defun my-scroll-year-calendar-backward-year (&optional arg event)
  "Scroll the yearly calendar by month in a backward direction."
  (interactive (list (prefix-numeric-value current-prefix-arg)
                     last-nonmenu-event))
  (my-scroll-year-calendar-forward-year (- (or arg 1)) event))
(eval-after-load "calendar" '(progn
  (define-key calendar-mode-map "{" 'my-scroll-year-calendar-backward-year)
  (define-key calendar-mode-map "}" 'my-scroll-year-calendar-forward-year)))

I used M-x gif-screencast to make the animated GIF. Yay Emacs!

View or add comments (Disqus), or e-mail me at sacha@sachachua.com

Display a calendar heat map using Emacs Lisp

| emacs

I was curious about how to quickly visualize my date-related data in Emacs, such as when I sketched my thoughts or which days had journal entries or how often A- had tantrums. (It's hard to be 6 years old.) I wrote this code based on nrougier's code for colouring calendar days using advice around calendar-generate-entries: 

(defface calendar-scale-1  '((((background light)) :foreground "black" :background "#eceff1")
                             (((background dark))  :foreground "white" :background "#263238")) "")
(defface calendar-scale-2  '((((background light)) :foreground "black" :background "#cfd8dc")
                             (((background dark))  :foreground "white" :background "#37474f")) "")
(defface calendar-scale-3  '((((background light)) :foreground "black" :background "#b0bec5")
                             (((background dark))  :foreground "white" :background "#455a64")) "")
(defface calendar-scale-4  '((((background light)) :foreground "black" :background "#90a4ae")
                             (((background dark))  :foreground "white" :background "#546e7a")) "")
(defface calendar-scale-5  '((((background light)) :foreground "black" :background "#78909c")
                             (((background dark))  :foreground "white" :background "#607d8b")) "")
(defface calendar-scale-6  '((((background light)) :foreground "black" :background "#607d8b")
                             (((background dark))  :foreground "white" :background "#78909c")) "")
(defface calendar-scale-7  '((((background light)) :foreground "black" :background "#546e7a")
                             (((background dark))  :foreground "white" :background "#90a4ae")) "")
(defface calendar-scale-8  '((((background light)) :foreground "black" :background "#455a64")
                             (((background dark))  :foreground "white" :background "#b0bec5")) "")
(defface calendar-scale-9  '((((background light)) :foreground "black" :background "#37474f")
                             (((background dark))  :foreground "white" :background "#cfd8dc")) "")
(defface calendar-scale-10 '((((background light)) :foreground "black" :background "#263238")
                             (((background dark))  :foreground "white" :background "#eceff1")) "")

(defun my-count-calendar-entries (grouped-entries)
  (mapcar (lambda (entry) (cons (car entry) (length (cdr entry)))) grouped-entries))

(defun my-scale-calendar-entries (grouped-entries &optional scale-max)
  (let* ((count (my-count-calendar-entries grouped-entries))
         (count-max (apply #'max (mapcar (lambda (o) (if (car o) (cdr o) 0)) count))))
    (mapcar (lambda (entry)
              (cons (car entry)
                    (/ (* 1.0 (or scale-max 1.0) (cdr entry)) count-max)))
            count)))

(defun my-scale-calendar-entries-logarithmically (grouped-entries &optional scale-max)
  (let* ((count (my-count-calendar-entries grouped-entries))
         (count-max (apply #'max (mapcar (lambda (o) (if (car o) (cdr o) 0)) count))))
    (mapcar (lambda (entry)
              (cons (car entry)
                    (/ (* 1.0 (or scale-max 1.0) (log (cdr entry))) (log count-max))))
            count)))

(defvar my-calendar-count-scaled nil "Values to display.")

(defun my-calendar-heat-map (month year indent)
  (when my-calendar-count-scaled
    (dotimes (i 31)
      (let ((date (list month (1+ i) year))
            (count-scaled (assoc-default (format "%04d-%02d-%02d" year month (1+ i))
                                         my-calendar-count-scaled)))
        (when count-scaled
          (calendar-mark-visible-date
           date
           (intern (format "calendar-scale-%d" count-scaled))))))))

(advice-add #'calendar-generate-month :after #'my-calendar-heat-map)
;(advice-remove #'calendar-generate-month #'my-calendar-heat-map)

(defun my-calendar-visualize (values)
  (setq my-calendar-count-scaled values)
  (calendar))

Journal entries

So if I want to visualize the days with journal entries, I can use this code: 

(defun my-calendar-visualize-journal-entries ()
  (interactive)
  (my-calendar-visualize
   (mapcar
    (lambda (o)
      (cons
       (car o)
       (ceiling (+ 1 (* 7.0 (cdr o))))))
    (my-scale-calendar-entries
     (seq-group-by #'my-journal-date
                   (cdr (pcsv-parse-file "~/Downloads/entries.csv")))))))
2023-01-05_21-42-06.png
Figure 1: Journal entries

Sketches

(defun my-calendar-visualize-sketches ()
  (interactive)
  (let ((my-calendar-sketches
         (assoc-delete-all
          nil
          (seq-group-by
           (lambda (o)
             (when (string-match "^\\([0-9][0-9][0-9][0-9]\\)[-_]?\\([0-9][0-9]\\)[-_]?\\([0-9][0-9]\\)" o)
               (format "%s-%s-%s"
                       (match-string 1 o)
                       (match-string 2 o)
                       (match-string 3 o))))
           (append
            (directory-files "~/sync/sketches" nil "\\.\\(png\\|jpg\\)\\'")
            (directory-files "~/sync/private-sketches" nil "\\.\\(png\\|jpg\\)\\'"))))))
    (my-calendar-visualize
     (mapcar
      (lambda (o)
        (cons (car o)
              ;; many days have just 1 sketch, so I set the low end of the scale
              ;; to make them visible, and use a logarithmic scale for the rest
              (ceiling (+ 3 (* 7.0 (cdr o))))))
      (my-scale-calendar-entries-logarithmically my-calendar-sketches)))))
2023-01-05_21-37-03.png
Figure 2: Sketches

Big feelings

(defun my-calendar-visualize-tantrums ()
  (interactive)
  (my-calendar-visualize
   (mapcar
    (lambda (o)
      (cons
       (car o)
       (ceiling (* 10.0 (cdr o)))))
    (my-scale-calendar-entries
     (seq-group-by #'my-journal-date
                   (seq-filter (lambda (o) (string-match "tantrum\\|grump\\|angry\\|meltdown"
                                                           (my-journal-note o)))
                               (cdr (pcsv-parse-file "~/Downloads/entries.csv"))))))))
2023-01-05_21-46-22.png
Figure 3: Tantrums and meltdowns

(The start of the schoolyear was pretty rough.)

I'd like to figure out a yearly calendar view, and maybe use the calendar as a way to navigate my data too. calendar-mark-visible-date relies on the position and gets confused by the stuff I tried from these yearly calendar hacks, but maybe I can change calendar-date-echo-text to '(calendar-iso-date-string (list month day year)) and then extract the data from the help-echo property, since mysteriously, the date doesn't actually seem to be otherwise stored in the calendar. Anyway, I'll post that when I figure it out!

View or add comments (Disqus), or e-mail me at sacha@sachachua.com