From mboxrd@z Thu Jan 1 00:00:00 1970 From: Keith David Bershatsky Subject: Programmatically add birthdays/holidays to the Agenda View. Date: Fri, 24 Apr 2015 23:22:43 -0700 Message-ID: Mime-Version: 1.0 (generated by - "") Content-Type: text/plain; charset=US-ASCII Return-path: Received: from eggs.gnu.org ([2001:4830:134:3::10]:46302) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1YltUK-0008Ep-0L for emacs-orgmode@gnu.org; Sat, 25 Apr 2015 02:22:54 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1YltUE-0004P3-VN for emacs-orgmode@gnu.org; Sat, 25 Apr 2015 02:22:51 -0400 Received: from cobb.liquidweb.com ([50.28.13.150]:54848) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1YltUE-0004Ov-LE for emacs-orgmode@gnu.org; Sat, 25 Apr 2015 02:22:46 -0400 Received: from cpe-45-48-239-195.socal.res.rr.com ([45.48.239.195]:52002 helo=server.local.localhost) by cobb.liquidweb.com with esmtp (Exim 4.82) (envelope-from ) id 1YltUA-0007gx-Fp for emacs-orgmode@gnu.org; Sat, 25 Apr 2015 02:22:42 -0400 List-Id: "General discussions about Org-mode." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: emacs-orgmode-bounces+geo-emacs-orgmode=m.gmane.org@gnu.org Sender: emacs-orgmode-bounces+geo-emacs-orgmode=m.gmane.org@gnu.org To: emacs-orgmode@gnu.org 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. http://emacs.stackexchange.com/questions/10871/programmatically-add-birthdays-holidays-to-agenda-view-in-org-mode ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (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") )) "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 -- MODIFICATON (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 '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 '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)))