Org Agendaに天気・日の出日の入・月の状態を表示する

org-modeのagendaについてはこれまでに色々な設定をしてきました。

特に日付に対する付加情報として、毎日の天気、日の出時刻、日の入り時刻、月相、月出、月没等も表示させるようにしてきました(diary-sexpで)。

ただ、これらの日付に対する付加的な情報を、情報ごとに1行ずつ表示していると肝心の予定が見づらくなってしまいます。なので私はこれらの情報は1日1行にまとめて表示するようにもしてきました。

今日はそれをさらに一歩進めて、付加的な情報は日付の右側に小さく表示させてみようと思います。

最終的な見た目は次のようになりました。

これならあまり邪魔にならないでしょう。

設定箇所が散乱していて大変でしたが、関連しそうな所を次のようにまとめてみました。足りないところがあったらすみません。

;;; my-org-agenda.el ---                            -*- lexical-binding: t; -*-
(require 'org-agenda)
(require 'calendar)
(require 'solar)
(require 'lunar)
(require 'japanese-holidays) ;; https://github.com/emacs-jp/japanese-holidays
(require 'jma-forecast) ;; https://github.com/misohena/el-jma
(require 'moonrise) ;; https://github.com/misohena/moonrise-el

;;;; 雑多な設定(関係ないのも含まれているかも)

;; moonrise-el用
(setq moonrise-day-events-format-org-agenda
      '(rise set
             (time :hour 12 :preceding t :display-time nil
                   :display-moon-phase t))
      moonrise-org-agenda-event-separator ""
      moonrise-org-agenda-use-cache t
      moonrise-point-event-format
      '((point-name :separator " ") (time :separator "")
        (moon-age :separator " ") (moon-phase :separator ""))
      moonrise-point-name-alist '((rise . "月出") (set . "月没") (meridian . "南中")))

;; el-jma用
(setq jma-weather-code-image-default-height 22
      jma-forecast-location-amedas "44132" ;; 東京(AMEDAS)
      jma-forecast-location-class10 "130010" ;; 東京地方
      jma-forecast-location-office "130000" ;; 東京都
      jma-forecast-location-week-amedas "44132" ;; 東京(AMEDAS)(週間予報)
      jma-forecast-location-week-area "130010") ;; 東京地方(週間予報)

;; solar.el用
(setq solar-n-hemi-seasons '("春分" "夏至" "秋分" "冬至"))

(setq calendar-latitude 35.0000 ;; 緯度
      calendar-longitude 139.0000) ;; 経度

;; org-modern用 (必要に応じて)
;; (add-hook 'org-agenda-finalize-hook #'org-modern-agenda)


;;; org-agenda用の設定

(setq
 org-agenda-custom-commands
 '(("a" "Default"
    ((agenda "" ((org-agenda-overriding-header "TODO"))))
    ((org-agenda-export-html-style
      "<link rel=\"stylesheet\" type=\"text/css\" href=\"agenda.css\">")
     (org-agenda-use-time-grid nil))
    ("~/my-org-agenda-html/agenda.html")))
 org-agenda-deadline-leaders '("DL" "DL%dd:" "DL-%dd:")
 org-agenda-files '("~/my-org-files/todo.org")
 org-agenda-include-diary t
 org-agenda-prefix-format
 '((agenda . " %i %?-12t%? s") (todo . " %i %-8:c")
   (tags . " %i %-8:c") (search . " %i %-8:c"))
 org-agenda-scheduled-leaders '("" "-%dd:")
 org-agenda-search-headline-for-time nil
 org-agenda-sort-notime-is-late nil
 org-agenda-span 31
 org-agenda-tags-column 0
 org-agenda-time-grid
 '((daily today require-timed) (800 1000 1200 1400 1600 1800 2000)
   " ·····" "────────────"))


;;;; 長い見出しの折り返し後をインデント

;; https://misohena.jp/blog/2022-10-30-org-agenda-wrap-prefix.html

(defvar my-org-agenda-format-item-prefix "") ;;formatterが返した値を取っておくための変数。
(defun my-org-agenda-format-item (orig-fun &rest args)
  ;; 元のorg-agenda-format-itemを呼び出す前に
  ;; org-prefix-format-compiledを一時的に書き替える。
  (let* ((org-prefix-format-compiled
          (list
           (car org-prefix-format-compiled)
           ;; formatterを書き替えてしまう。
           ;; 結果を my-org-agenda-format-item-prefix に書き込む関数に。
           (list 'setq
                 'my-org-agenda-format-item-prefix
                 (cadr org-prefix-format-compiled))))
         ;; 元のorg-agenda-format-itemを呼び出す。
         (rv (apply orig-fun args)))
    ;; 戻り値にwrap-prefixテキストプロパティを追加する。
    ;; インデントの深さはformatterが返した文字列(prefix)の長さとする。
    (put-text-property
     0 (length rv) 'wrap-prefix
     (make-string (length my-org-agenda-format-item-prefix) ? )
     rv)
    rv))

(advice-add #'org-agenda-format-item :around #'my-org-agenda-format-item)


;;;; ブロック区切りを一行に

;; ブロック区切りを制御するには `org-agenda-block-separator' を使用するが、
;; これはnilにすると空行が無くなってしまうし、文字や文字列を設定すると必ず
;; 2つの\nが挿入されてしまう。""を指定すると空行が2つ挿入されてしまう。
;; この処理は `org-agenda-prepare' で行っているので、そのafterアドバイスで
;; \nを一つだけ挿入する。

(setq org-agenda-block-separator nil) ;; 2行追加しない。

(defun my-org-agenda-prepare-after (&rest _args)
  (when (and (not (org-agenda-use-sticky-p))
             org-agenda-multi
             (> (point) 1) ;; (not (bobp))ではダメ。narrowingされているから。
             (not org-agenda-compact-blocks))
    ;; 1行のみ追加してそれ以降をナローイング
    (insert "\n")
    (narrow-to-region (point) (point-max))))

(advice-add #'org-agenda-prepare :after #'my-org-agenda-prepare-after)


;;;; 日付の形式

(defconst my-org-agenda-dow '(?日 ?月 ?火 ?水 ?木 ?金 ?土))

(defun my-org-agenda-format-date--date (date)
  (let* ((year (caddr date))
         (month (car date))
         (day (cadr date))
         (dow (elt my-org-agenda-dow (calendar-day-of-week date)))
         (today (calendar-gregorian-from-absolute (org-today)))
         (today-year (caddr today))
         (today-month (car today)))
    (concat
     (if (equal year today-year)
         (if (equal month today-month)
             (format "%d" day)
           (format "%2d/%02d" month day))
       (format "%d/%02d/%02d" year month day))
     ;; " "
     (propertize (format "%c" dow) 'my-org-agenda-dow t))))

(defun my-org-agenda-format-date (date)
  (concat
   ;; 日付の上に空白
   (propertize "" 'display '(space :width (1) :height 1.75 :ascent 100))
   ;; 日付
   (my-org-agenda-format-date--date date)))

(setq org-agenda-format-date #'my-org-agenda-format-date)


;;;; 日付の色

;; https://misohena.jp/blog/2021-08-29-colorize-saturday-and-japanese-holidays-in-org-agenda.html

(defface my-org-agenda-date-saturday
  '((t (:inherit org-agenda-date :foreground "#0bf" :weight bold)))
  "Face used in agenda for saturday."
  :group 'org-faces)

(defface my-org-agenda-dow-saturday
  '((t (:inherit my-org-agenda-date-saturday :height 0.8)))
  "Face used in agenda for saturday."
  :group 'org-faces)

(defface my-org-agenda-dow-weekend
  '((t (:inherit org-agenda-date-weekend :height 0.8)))
  "Face used in agenda for saturday."
  :group 'org-faces)

(defface my-org-agenda-dow
  '((t (:inherit org-agenda-date :height 0.8)))
  "Face used in agenda for saturday."
  :group 'org-faces)

(defun my-org-agenda-day-face (date)
  (let ((face (cond
               ;; 土曜日
               ((= (calendar-day-of-week date) 6)
                'my-org-agenda-date-saturday)
               ;; 日曜日か日本の祝日
               ((or (= (calendar-day-of-week date) 0)
                    (let ((calendar-holidays japanese-holidays))
                      (calendar-check-holidays date)))
                'org-agenda-date-weekend)
               ;; 普通の日
               (t 'org-agenda-date))))
    ;; 今日は色を反転
    ;;(if (org-agenda-today-p date) (list :inherit face :inverse-video t) face)
    face))

(setq org-agenda-day-face-function #'my-org-agenda-day-face)


;; 数字部分と曜日部分を分けて調整できるようにする

(defun my-org-agenda-fontify-dow ()
  ;; 曜日部分を独立したfaceにします。
  ;; `org-agenda-format-date'や`org-agenda-day-face-function'が呼び出され
  ;; るタイミングで行ってもダメなので、Agendaが完成した後にfaceを書き替えます。
  ;; See: `org-agenda-list'
  (let ((inhibit-read-only t)
        match)
    (save-excursion
      (goto-char (point-min))
      (while (setq match (text-property-search-forward 'my-org-agenda-dow t t))
        (put-text-property
         (prop-match-beginning match)
         (prop-match-end match)
         'face
         (pcase (get-text-property (1- (point)) 'face)
           ('org-agenda-date 'my-org-agenda-dow)
           ('org-agenda-date-weekend 'my-org-agenda-dow-weekend)
           ('my-org-agenda-date-saturday 'my-org-agenda-dow-saturday)))))))

(add-hook 'org-agenda-finalize-hook 'my-org-agenda-fontify-dow)


;;;; 日付付加情報

(defun my-org-agenda-sunrise-sunset ()
  ;; Return "<日の出><日の入>"
  (let ((times (solar-sunrise-sunset org-agenda-current-date)))
    (mapconcat
     #'identity
     (delq
      nil
      (list
       (when (car times) (apply #'solar-time-string (car times)))
       (when (and (car times) (cadr times)) "～")
       (when (cadr times) (apply #'solar-time-string (cadr times)))))
     "")))

(defun my-org-agenda-sun-and-moon ()
  (mapconcat #'identity
             (delq nil
                   (list
                    ;; "<日の出><日の入>"
                    (my-org-agenda-sunrise-sunset)
                    ;; "<12時月相><月出没>*"
                    (moonrise-org-agenda)
                    ;; "<四朔望>"
                    (cdr (diary-lunar-phases))))
             " "))

(defun my-org-agenda-weather ()
  (ignore-errors
    (jma-diary-weathers
     ;; 東京都 東京地方 東京
     "130000" "130010" "44132" "130010" "44132"
     ;; "<天気><降水確率><最低気温><最高気温>"
     "{{{weather-image:%s}}}{{{pop:%s%%}}}\
{{{temp-min: %s～}}}{{{temp-max:%s℃}}}")))

(defun my-org-agenda-nature-environment (date-arg)
  ;; 指定された日付(DATE-ARG)の自然環境情報文字列を返す。
  (with-no-warnings (defvar date))
  (let ((date date-arg)
        (org-agenda-current-date date-arg))
    (mapconcat
     #'identity
     (delq nil
           (list
            ;; 天気
            (my-org-agenda-weather)
            ;; 日の出・日の入
            (my-org-agenda-sunrise-sunset)
            ;; 12時月相・月出没
            (let ((moonrise-point-name-alist
                   '((rise . "↑")
                     (set . "↓")
                     (meridian . "中"))))
              (moonrise-org-agenda))
            ;; 四朔望
            (cdr (diary-lunar-phases))))
     " ")))

(defun my-org-agenda-day-info (date)
  ;; 日付DATEの付加情報文字列を返す。
  (propertize
   (concat
    " "
    (my-org-agenda-nature-environment date))
   'my-org-agenda-date-info t
   'face 'my-org-agenda-date-info))

(defface my-org-agenda-date-info
  '((t (:foreground "#999" :height 0.8)))
  "Face used in agenda for date info."
  :group 'org-faces)

(defun my-org-agenda-date-info-display-p ()
  ;; 特定の場所でのみ日付付加情報を表示するなら、ここで何らかの条件で判定せよ
  ;; (equal
  ;;  (get-text-property (point) 'org-series-cmd)
  ;;  '(agenda "" ((org-agenda-overriding-header "TODO"))))
  t)

(defcustom my-org-agenda-date-info-display-p
  #'my-org-agenda-date-info-display-p
  "日付付加情報を表示する条件。
  nil = 常に表示しない
  t = 常に表示する
  関数 = Agendaバッファの日付部分末尾で呼び出され、非nilを返したら表示"
  :type '(choice boolean function)
  :group 'org)

(defun my-org-agenda-update-date-info-face ()
  ;; 日付付加情報をAgendaバッファに挿入する。
  (when my-org-agenda-date-info-display-p
    (let ((inhibit-read-only t))
      (save-excursion
        (goto-char (point-min))
        (while (text-property-search-forward 'org-agenda-date-header)
          (when-let* ((day (get-text-property (1- (point)) 'day))
                      (date (calendar-gregorian-from-absolute day)))
            (when (or (eq my-org-agenda-date-info-display-p t)
                      (and (functionp my-org-agenda-date-info-display-p)
                           (funcall my-org-agenda-date-info-display-p)))
              (insert (my-org-agenda-day-info date)))))))))

(add-hook 'org-agenda-finalize-hook 'my-org-agenda-update-date-info-face)

org-agendaの出力を細かくカスタマイズするにはorg-agenda-finalize-hookを使うのが最も強力なようです。これはorg-agendaの出力が一通り終わった後に呼び出されるフックなので、細かいところも全て後から書き替える事が出来ます。ただし、バッファ全体をスキャンする必要が出てくるので多少効率は落ちます。

出力関数の一部の挙動をピンポイントで修正しようと思っても、それはほとんどの場合困難です。出力関数(org-agenda-list)は205行にもなる大きな関数ですし、処理が適切な粒度で関数化されていないので割り込む余地がありません。

というわけで上のコードでは、org-agenda-finalize-hookに my-org-agenda-update-date-info-face や my-org-agenda-fontify-dow といったフックを追加して付加情報の挿入や曜日部分のface分離を行っています。

その他細かいところを調整するのに苦労しました。

それでも最終的に調整できてしまうのがEmacsの良い所ではあります。