emacs-orgmode@gnu.org archives
 help / color / mirror / code / Atom feed
* Programmatically add birthdays/holidays to the Agenda View.
@ 2015-04-25  6:22 Keith David Bershatsky
  0 siblings, 0 replies; only message in thread
From: Keith David Bershatsky @ 2015-04-25  6:22 UTC (permalink / raw)
  To: emacs-orgmode

The following is a full working draft to programmatically add birthdays/holidays to the Agenda View without making entries in the diary or org files.  It is modeled after what `calendar-mode` presently offers.  I have posted the code on the Emacs beta stackexchange.  Please feel free to modify / incorporate that new feature into org-mode.  I have added limited support for text properties -- there are undoubtedly some additional text properties that the org-mode maintainers will want to add for sorting by name / date / priority, etc., and, perhaps whatever should appear when clicking on a link (e.g., the source code for birthday/holiday list, or something that might be useful).  In addition, the org-mode maintainers may wish to have the entries look more like standard headings with stars an
 d so forth.



    (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") ))
      :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") ))
      "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))
           (format "*Org Agenda(%s)*" org-keys))
          (t "*Org Agenda(a)*")))
        (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))
          (if (or (eq ndays 7) (eq ndays 14))
         (thefiles (org-agenda-files nil 'ifmode))
         (files thefiles)
         (start (if (or (null org-agenda-start-on-weekday)
            (< ndays 7))
            (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)
            (if (< (- d2 d1) 350)
          (if (= w1 w2)
              (format " (W%02d)" w1)
            (format " (W%02d-W%02d)" w1 w2))
      (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))))
             ((memq org-agenda-show-log-scoped '(only clockcheck))
        (setq rtn (org-agenda-get-day-entries
             file date :closed)))
        (setq rtn (apply 'org-agenda-get-day-entries
             file date
             (append '(:closed) org-agenda-entry-types))))
        (setq rtn (apply 'org-agenda-get-day-entries
             file date
          (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))))
      (when org-agenda--show-holidays-birthdays
        (setq rtn (org-agenda--get-birthdays-holidays))
        (setq rtnall (append rtnall rtn)))
      (if (or rtnall org-agenda-show-all-dates)
            (setq day-cnt (1+ day-cnt))
             (if (stringp org-agenda-format-date)
           (format-time-string org-agenda-format-date
                   (org-time-from-absolute date))
         (funcall org-agenda-format-date date))
            (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)
            (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))
        (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)))
            (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)
          (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))
          (displayed-month (nth 0 date))
          (displayed-year (nth 2 date))
            (dolist (p org-agenda--holiday-list res-holidays)
              (let* (h)
               (when (setq h (eval p))
                 (setq res-holidays (append h res-holidays))))))
            (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
            (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
                    '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))))
            (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
                    '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))))
        (nreverse ee)))

^ permalink raw reply	[flat|nested] only message in thread

only message in thread, other threads:[~2015-04-25  6:22 UTC | newest]

Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2015-04-25  6:22 Programmatically add birthdays/holidays to the Agenda View Keith David Bershatsky

Code repositories for project(s) associated with this public inbox


This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).