プログラムで誕生日/休日を組織モードの議題ビューに追加する

org-modeには、誕生日/休日をの議題ビューに追加するための組み込みオプションがいくつかありますorg-mode。ただし、これらの日付をプログラムで完全に追加するための組み込みサポートはありません。手動で日記エントリまたは標準のorgファイルにエントリを追加する必要はありません。

http://orgmode.org/manual/Weekly_002fdaily-agenda.html

calendar-modeオファーと同様に、プログラムで誕生日/休日をアジェンダビューに追加する方法はありますか？ではcalendar-mode、ユーザーは、holiday-fixedやなどの関数と組み合わせた変数を使用して、休日と誕生日を定義できますholiday-float。と同じタイプのセットアップがorg-mode便利に思われます。

以下は、に変更をorg-agenda-list加えたもので、新しい変数と、休日/誕生日を追加する新しい関数が追加されています。ときorg-agenda--show-holidays-birthdays以外でnil、誕生日や休日は、アジェンダビューでプログラムが表示されます。変数org-agenda--birthday-listとorg-agenda--holiday-listは、ユーザーがカスタマイズできます。org-agenda-custom-commandsこの新機能を試すためのエントリがに追加されました。大文字の「Y」は、休日/誕生日を含む年ビューを起動します。いくつかの基本的なテキストプロパティをサポートするために、いくつかの制限された機能が追加されました。他の機能は後日追加される可能性があります。

上記の変数内で使用されている休日や誕生日をフォーマットする方法の例については、変数のドキュメント文字列を参照してくださいcalendar-holidaysライブラリ内holidays.el-例えば、holiday-fixed; holiday-float; holiday-sexp; (lunar-phases); (solar-equinoxes-solstices); holiday-hebrew; holiday-islamic; holiday-bahai; holiday-julian; holiday-chinese; 等

この例をどのように試すことができますか？：コードをブロック/コピー/ *Scratch*バッファーに貼り付けます。と入力しM-x eval-buffer RETます。次にM-x org-agenda RET大文字を入力し、大文字を選択しますY。これは完全に機能する作業草案ですが、見栄えを良くしたり、アルファベット順に並べ替えたりする機能を追加するには、少しカスタマイズする必要があります。試した後で気に入らない場合は、Emacsを再起動するだけで元に戻ります。あなたがそれを試す前にあなたがいた場所に。

変更されたソースコードと実行されたテストは、Emacsの最新の公開リリースで行われました：   Org-mode version 8.2.10（release_8.2.10 @ /Applications/Emacs.app/Contents/Resources/lisp/org /） ; そして、 builder10-6.porkrind.org上の2014-10-20のGNU Emacs 24.4.1（x86_64-apple-darwin10.8.0、NS apple-appkit-1038.36）。

コード：

(require 'org-agenda)
(require 'holidays)

(add-to-list 'org-agenda-custom-commands '(
  "Y" "365 Days -- holidays/birthdays" agenda "Year View" (
  (org-agenda-span 365)
  (org-agenda-time-grid nil)
  (org-agenda--show-holidays-birthdays t) )))

(defcustom org-agenda--show-holidays-birthdays nil
  "When non-`nil`, show holidays/birthdays in the agenda view."
  :group 'holidays)

(defcustom org-agenda--birthday-list (mapcar 'purecopy '(
  (holiday-fixed 1 2 "Jane Doe -- 01/02/1940")
  (holiday-fixed 2 15 "John Doe -- 02/15/1963")
  (holiday-fixed 3 2 "Seymoure Hersh -- 03/03/1999")
  (holiday-fixed 3 3 "Jashua Smith -- 03/03/1964")
  (holiday-fixed 3 5 "Frederick Holmes -- 03/05/1966")
  (holiday-fixed 4 7 "Fannie Mae -- 04/07/1970")
  (holiday-fixed 4 25 "Freddie Mack -- 04/25/1952")
  (holiday-float 5 0 2 "Mother's Day -- the second Sunday in May")
  (holiday-fixed 5 11 "George Lucas -- 05/11/1976")
  (holiday-fixed 5 18 "Harry Potter -- 05/18")
  (holiday-fixed 5 30 "Darth Vader -- 05/30/1972")
  (holiday-fixed 6 7 "Jabba the Hut -- 06/07/2007")
  (holiday-fixed 6 19 "Princess Lea -- 06/19/1983")
  (holiday-fixed 7 14 "Super Man -- 07/14/1970")
  (holiday-fixed 7 18 "Wonder Woman -- 07/18/1993")
  (holiday-fixed 10 3 "Jenifer Lopez (DOB:  10/03/2011)")
  (holiday-fixed 10 8 "Samuel Jacks (10/08/1965)")
  (holiday-fixed 10 25 "C3PO -- 10/25/2007")
  (holiday-fixed 11 14 "R2D2 -- 11/14/1981")
  (holiday-fixed 12 21 "Yoda -- 12/21/1958")
  (holiday-fixed 12 22 "Wookie -- 12/22/1967") ))
  "Birthdays."
  :type 'sexp
  :group 'holidays)

(defcustom org-agenda--holiday-list (mapcar 'purecopy '(
  (holiday-fixed 1 1 "New Year's Day")
  (holiday-float 1 1 3 "Martin Luther King Day")
  (holiday-float 2 1 3 "President's Day")
  (holiday-float 5 1 -1 "Memorial Day")
  (holiday-fixed 7 4 "Independence Day")
  (holiday-float 9 1 1 "Labor Day")
  (holiday-float 10 1 2 "Columbus Day")
  (holiday-fixed 11 11 "Veteran's Day")
  (holiday-float 11 4 4 "Thanksgiving")
  (holiday-fixed 12 25 "Christmas")
  (solar-equinoxes-solstices)
  (holiday-sexp calendar-daylight-savings-starts
    (format "Daylight Saving Time Begins %s"
      (solar-time-string
        (/ calendar-daylight-savings-starts-time (float 60))
        calendar-standard-time-zone-name)))
  (holiday-sexp calendar-daylight-savings-ends
      (format "Daylight Saving Time Ends %s"
       (solar-time-string
         (/ calendar-daylight-savings-ends-time (float 60))
         calendar-daylight-time-zone-name))) ))
  "Custom holidays defined by the user."
  :type 'sexp
  :group 'holidays)

(defface org-agenda--holiday-face
  '((t (:foreground "red")))
  "Face for `org-agenda--holiday-face`."
  :group 'org-agenda)

(defface org-agenda--birthday-face
  '((t (:foreground "magenta")))
  "Face for `org-agenda--birthday-face`."
  :group 'org-agenda)

(defun org-agenda-list (&optional arg start-day span with-hour)
  "Produce a daily/weekly view from all files in variable `org-agenda-files'.
The view will be for the current day or week, but from the overview buffer
you will be able to go to other days/weeks.

With a numeric prefix argument in an interactive call, the agenda will
span ARG days.  Lisp programs should instead specify SPAN to change
the number of days.  SPAN defaults to `org-agenda-span'.

START-DAY defaults to TODAY, or to the most recent match for the weekday
given in `org-agenda-start-on-weekday'.

When WITH-HOUR is non-nil, only include scheduled and deadline
items if they have an hour specification like [h]h:mm."
  (interactive "P")
  (if org-agenda-overriding-arguments
      (setq arg (car org-agenda-overriding-arguments)
      start-day (nth 1 org-agenda-overriding-arguments)
      span (nth 2 org-agenda-overriding-arguments)))
  (if (and (integerp arg) (> arg 0))
      (setq span arg arg nil))
  (catch 'exit
    (setq org-agenda-buffer-name
    (or org-agenda-buffer-tmp-name
        (if org-agenda-sticky
      (cond ((and org-keys (stringp org-match))
       (format "*Org Agenda(%s:%s)*" org-keys org-match))
      (org-keys
       (format "*Org Agenda(%s)*" org-keys))
      (t "*Org Agenda(a)*")))
        org-agenda-buffer-name))
    (org-agenda-prepare "Day/Week")
    (setq start-day (or start-day org-agenda-start-day))
    (if (stringp start-day)
  ;; Convert to an absolute day number
  (setq start-day (time-to-days (org-read-date nil t start-day))))
    (org-compile-prefix-format 'agenda)
    (org-set-sorting-strategy 'agenda)
    (let* ((span (org-agenda-ndays-to-span
      (or span org-agenda-ndays org-agenda-span)))
     (today (org-today))
     (sd (or start-day today))
     (ndays (org-agenda-span-to-ndays span sd))
     (org-agenda-start-on-weekday
      (if (or (eq ndays 7) (eq ndays 14))
    org-agenda-start-on-weekday))
     (thefiles (org-agenda-files nil 'ifmode))
     (files thefiles)
     (start (if (or (null org-agenda-start-on-weekday)
        (< ndays 7))
          sd
        (let* ((nt (calendar-day-of-week
        (calendar-gregorian-from-absolute sd)))
         (n1 org-agenda-start-on-weekday)
         (d (- nt n1)))
          (- sd (+ (if (< d 0) 7 0) d)))))
     (day-numbers (list start))
     (day-cnt 0)
     (inhibit-redisplay (not debug-on-error))
     (org-agenda-show-log-scoped org-agenda-show-log)
     s e rtn rtnall file date d start-pos end-pos todayp
     clocktable-start clocktable-end filter)
      (setq org-agenda-redo-command
      (list 'org-agenda-list (list 'quote arg) start-day (list 'quote span) with-hour))
      (dotimes (n (1- ndays))
  (push (1+ (car day-numbers)) day-numbers))
      (setq day-numbers (nreverse day-numbers))
      (setq clocktable-start (car day-numbers)
      clocktable-end (1+ (or (org-last day-numbers) 0)))
      (org-set-local 'org-starting-day (car day-numbers))
      (org-set-local 'org-arg-loc arg)
      (org-set-local 'org-agenda-current-span (org-agenda-ndays-to-span span))
      (unless org-agenda-compact-blocks
  (let* ((d1 (car day-numbers))
         (d2 (org-last day-numbers))
         (w1 (org-days-to-iso-week d1))
         (w2 (org-days-to-iso-week d2)))
    (setq s (point))
    (if org-agenda-overriding-header
        (insert (org-add-props (copy-sequence org-agenda-overriding-header)
        nil 'face 'org-agenda-structure) "\n")
      (insert (org-agenda-span-name span)
        "-agenda"
        (if (< (- d2 d1) 350)
      (if (= w1 w2)
          (format " (W%02d)" w1)
        (format " (W%02d-W%02d)" w1 w2))
          "")
        ":\n")))
  (add-text-properties s (1- (point)) (list 'face 'org-agenda-structure
              'org-date-line t))
  (org-agenda-mark-header-line s))
      (while (setq d (pop day-numbers))
  (setq date (calendar-gregorian-from-absolute d)
        s (point))
  (if (or (setq todayp (= d today))
    (and (not start-pos) (= d sd)))
      (setq start-pos (point))
    (if (and start-pos (not end-pos))
        (setq end-pos (point))))
  (setq files thefiles
        rtnall nil)
  (while (setq file (pop files))
    (catch 'nextfile
      (org-check-agenda-file file)
      (let ((org-agenda-entry-types org-agenda-entry-types))
        ;; Starred types override non-starred equivalents
        (when (member :deadline* org-agenda-entry-types)
    (setq org-agenda-entry-types
          (delq :deadline org-agenda-entry-types)))
        (when (member :scheduled* org-agenda-entry-types)
    (setq org-agenda-entry-types
          (delq :scheduled org-agenda-entry-types)))
        ;; Honor with-hour
        (when with-hour
    (when (member :deadline org-agenda-entry-types)
      (setq org-agenda-entry-types
      (delq :deadline org-agenda-entry-types))
      (push :deadline* org-agenda-entry-types))
    (when (member :scheduled org-agenda-entry-types)
      (setq org-agenda-entry-types
      (delq :scheduled org-agenda-entry-types))
      (push :scheduled* org-agenda-entry-types)))
        (unless org-agenda-include-deadlines
    (setq org-agenda-entry-types
          (delq :deadline* (delq :deadline org-agenda-entry-types))))
        (cond
         ((memq org-agenda-show-log-scoped '(only clockcheck))
    (setq rtn (org-agenda-get-day-entries
         file date :closed)))
         (org-agenda-show-log-scoped
    (setq rtn (apply 'org-agenda-get-day-entries
         file date
         (append '(:closed) org-agenda-entry-types))))
         (t
    (setq rtn (apply 'org-agenda-get-day-entries
         file date
         org-agenda-entry-types)))))
      (setq rtnall (append rtnall rtn)))) ;; all entries
  (if org-agenda-include-diary
      (let ((org-agenda-search-headline-for-time t))
        (require 'diary-lib)
        (setq rtn (org-get-entries-from-diary date))
        (setq rtnall (append rtnall rtn))))
  ;; BEGIN -- MODIFICATION
  (when org-agenda--show-holidays-birthdays
    (setq rtn (org-agenda--get-birthdays-holidays))
    (setq rtnall (append rtnall rtn)))
  ;; END -- MODIFICATION
  (if (or rtnall org-agenda-show-all-dates)
      (progn
        (setq day-cnt (1+ day-cnt))
        (insert
         (if (stringp org-agenda-format-date)
       (format-time-string org-agenda-format-date
               (org-time-from-absolute date))
     (funcall org-agenda-format-date date))
         "\n")
        (put-text-property s (1- (point)) 'face
         (org-agenda-get-day-face date))
        (put-text-property s (1- (point)) 'org-date-line t)
        (put-text-property s (1- (point)) 'org-agenda-date-header t)
        (put-text-property s (1- (point)) 'org-day-cnt day-cnt)
        (when todayp
    (put-text-property s (1- (point)) 'org-today t))
        (setq rtnall
        (org-agenda-add-time-grid-maybe rtnall ndays todayp))
        (if rtnall (insert ;; all entries
        (org-agenda-finalize-entries rtnall 'agenda)
        "\n"))
        (put-text-property s (1- (point)) 'day d)
        (put-text-property s (1- (point)) 'org-day-cnt day-cnt))))
      (when (and org-agenda-clockreport-mode clocktable-start)
  (let ((org-agenda-files (org-agenda-files nil 'ifmode))
        ;; the above line is to ensure the restricted range!
        (p (copy-sequence org-agenda-clockreport-parameter-plist))
        tbl)
    (setq p (org-plist-delete p :block))
    (setq p (plist-put p :tstart clocktable-start))
    (setq p (plist-put p :tend clocktable-end))
    (setq p (plist-put p :scope 'agenda))
    (setq tbl (apply 'org-clock-get-clocktable p))
    (insert tbl)))
      (goto-char (point-min))
      (or org-agenda-multi (org-agenda-fit-window-to-buffer))
      (unless (and (pos-visible-in-window-p (point-min))
       (pos-visible-in-window-p (point-max)))
  (goto-char (1- (point-max)))
  (recenter -1)
  (if (not (pos-visible-in-window-p (or start-pos 1)))
      (progn
        (goto-char (or start-pos 1))
        (recenter 1))))
      (goto-char (or start-pos 1))
      (add-text-properties (point-min) (point-max)
         `(org-agenda-type agenda
               org-last-args (,arg ,start-day ,span)
               org-redo-cmd ,org-agenda-redo-command
               org-series-cmd ,org-cmd))
      (if (eq org-agenda-show-log-scoped 'clockcheck)
    (org-agenda-show-clocking-issues))
      (org-agenda-finalize)
      (setq buffer-read-only t)
      (message ""))))

(defun org-agenda--get-birthdays-holidays ()
  "Add holidays/birthdays to the agenda view."
  (let* (
      (props (list
        'mouse-face 'highlight
        'org-not-done-regexp org-not-done-regexp
        'org-todo-regexp org-todo-regexp
        'org-complex-heading-regexp org-complex-heading-regexp
        'help-echo "Birthdays and Holidays"))
      (d1 (calendar-absolute-from-gregorian date))
      ee
      res-holidays
      res-birthdays
      (displayed-month (nth 0 date))
      (displayed-year (nth 2 date))
      (holiday-list
        (dolist (p org-agenda--holiday-list res-holidays)
          (let* (h)
           (when (setq h (eval p))
             (setq res-holidays (append h res-holidays))))))
      (birthday-list
        (dolist (p org-agenda--birthday-list res-birthdays)
          (let* (h)
           (when (setq h (eval p))
             (setq res-birthdays (append h res-birthdays)))))) )
    (when org-agenda--show-holidays-birthdays
      (mapcar
        (lambda (x)
          (let ((txt (format "%s -- holiday -- %s" (car x) (car (cdr x)))))
            (when (eq d1 (calendar-absolute-from-gregorian (car x)))
              (org-add-props txt props
                'ts-date d1
                ;; (char-to-string 65) = A; 66 = B; 67 = C; 68 = D; 69 = E
                'priority 65
                'type "holiday"
                'date d1
                'face 'org-agenda--holiday-face
                 ;; RESERVED FOR POTENTIAL FUTURE USE.
                'org-hd-marker nil
                'org-marker nil
                'warntime nil
                'level nil
                'org-category nil
                'org-category-position nil
                'todo-state nil
                'undone-face nil
                'done-face nil)
              (push txt ee))))
        holiday-list)
      (mapcar
        (lambda (x)
          (let ((txt (format "%s -- birthday -- %s" (car x) (car (cdr x)))))
            (when (eq d1 (calendar-absolute-from-gregorian (car x)))
              (org-add-props txt props
                'ts-date d1
                ;; (char-to-string 65) = A; 66 = B; 67 = C; 68 = D; 69 = E
                'priority 65
                'type "birthday"
                'date d1
                'face 'org-agenda--birthday-face
                 ;; RESERVED FOR POTENTIAL FUTURE USE.
                'org-hd-marker nil
                'org-marker nil
                'warntime nil
                'level nil
                'org-category nil
                'org-category-position nil
                'todo-state nil
                'undone-face nil
                'done-face nil)
              (push txt ee))))
        birthday-list))
    (nreverse ee)))