;;; org-colview.el --- Column View in Org-mode
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.02b
+;; Version: 6.35i
;;
;; This file is part of GNU Emacs.
;;
;;
;;; Commentary:
-;; This file contains the face definitons for Org.
+;; This file contains the column view for Org.
;;; Code:
(eval-when-compile (require 'cl))
(require 'org)
+(declare-function org-agenda-redo "org-agenda" ())
+(declare-function org-agenda-do-context-action "org-agenda" ())
+
;;; Column View
(defvar org-columns-overlays nil
(org-defkey org-columns-map "\M-b" 'backward-char)
(org-defkey org-columns-map "a" 'org-columns-edit-allowed)
(org-defkey org-columns-map "s" 'org-columns-edit-attributes)
-(org-defkey org-columns-map "\M-f" (lambda () (interactive) (goto-char (1+ (point)))))
-(org-defkey org-columns-map [right] (lambda () (interactive) (goto-char (1+ (point)))))
+(org-defkey org-columns-map "\M-f"
+ (lambda () (interactive) (goto-char (1+ (point)))))
+(org-defkey org-columns-map [right]
+ (lambda () (interactive) (goto-char (1+ (point)))))
+(org-defkey org-columns-map [down]
+ (lambda () (interactive)
+ (let ((col (current-column)))
+ (beginning-of-line 2)
+ (while (and (org-invisible-p2) (not (eobp)))
+ (beginning-of-line 2))
+ (move-to-column col)
+ (if (eq major-mode 'org-agenda-mode)
+ (org-agenda-do-context-action)))))
+(org-defkey org-columns-map [up]
+ (lambda () (interactive)
+ (let ((col (current-column)))
+ (beginning-of-line 0)
+ (while (and (org-invisible-p2) (not (bobp)))
+ (beginning-of-line 0))
+ (move-to-column col)
+ (if (eq major-mode 'org-agenda-mode)
+ (org-agenda-do-context-action)))))
(org-defkey org-columns-map [(shift right)] 'org-columns-next-allowed-value)
(org-defkey org-columns-map "n" 'org-columns-next-allowed-value)
(org-defkey org-columns-map [(shift left)] 'org-columns-previous-allowed-value)
(org-defkey org-columns-map [(meta left)] 'org-columns-move-left)
(org-defkey org-columns-map [(shift meta right)] 'org-columns-new)
(org-defkey org-columns-map [(shift meta left)] 'org-columns-delete)
+(dotimes (i 10)
+ (org-defkey org-columns-map (number-to-string i)
+ `(lambda () (interactive)
+ (org-columns-next-allowed-value nil ,i))))
(easy-menu-define org-columns-menu org-columns-map "Org Column Menu"
'("Column"
(push ov org-columns-overlays)
ov))
-(defun org-columns-display-here (&optional props)
+(defun org-columns-display-here (&optional props dateline)
"Overlay the current line with column display."
(interactive)
(let* ((fmt org-columns-current-fmt-compiled)
(and (eq major-mode 'org-agenda-mode)
(get-text-property (point-at-bol) 'face))
'default))
- (color (list :foreground
- (face-attribute ref-face :foreground)
- :weight 'normal :strike-through nil
- :underline nil))
- (face (list color 'org-column level-face))
- pom property ass width f string ov column val modval)
+ (color (list :foreground (face-attribute ref-face :foreground)))
+ (face (list color 'org-column ref-face))
+ (face1 (list color 'org-agenda-column-dateline ref-face))
+ (pl (or (get-text-property (point-at-bol) 'prefix-length) 0))
+ (cphr (get-text-property (point-at-bol) 'org-complex-heading-regexp))
+ pom property ass width f string ov column val modval s2 title calc)
;; Check if the entry is in another buffer.
(unless props
(if (eq major-mode 'org-agenda-mode)
- (setq pom (or (get-text-property (point) 'org-hd-marker)
- (get-text-property (point) 'org-marker))
+ (setq pom (or (org-get-at-bol 'org-hd-marker)
+ (org-get-at-bol 'org-marker))
props (if pom (org-entry-properties pom) nil))
(setq props (org-entry-properties nil))))
;; Walk the format
(while (setq column (pop fmt))
(setq property (car column)
+ title (nth 1 column)
ass (if (equal property "ITEM")
(cons "ITEM"
(save-match-data
(nth 2 column)
(length property))
f (format "%%-%d.%ds | " width width)
+ calc (nth 7 column)
val (or (cdr ass) "")
- modval (if (equal property "ITEM")
- (org-columns-cleanup-item val org-columns-current-fmt-compiled))
- string (format f (or modval val)))
+ modval (cond ((and org-columns-modify-value-for-display-function
+ (functionp
+ org-columns-modify-value-for-display-function))
+ (funcall org-columns-modify-value-for-display-function
+ title val))
+ ((equal property "ITEM")
+ (if (org-mode-p)
+ (org-columns-cleanup-item
+ val org-columns-current-fmt-compiled)
+ (org-agenda-columns-cleanup-item
+ val pl cphr org-columns-current-fmt-compiled)))
+ ((and calc (functionp calc)
+ (not (string= val ""))
+ (not (get-text-property 0 'org-computed val)))
+ (org-columns-number-to-string
+ (funcall calc (org-columns-string-to-number
+ val (nth 4 column)))
+ (nth 4 column)))))
+ (setq s2 (org-columns-add-ellipses (or modval val) width))
+ (setq string (format f s2))
;; Create the overlay
(org-unmodified
(setq ov (org-columns-new-overlay
- beg (setq beg (1+ beg)) string face))
+ beg (setq beg (1+ beg)) string (if dateline face1 face)))
(org-overlay-put ov 'keymap org-columns-map)
(org-overlay-put ov 'org-columns-key property)
(org-overlay-put ov 'org-columns-value (cdr ass))
(save-excursion
(goto-char beg)
(org-unmodified (insert " ")))))) ;; FIXME: add props and remove later?
- ;; Make the rest of the line disappear.
- (org-unmodified
- (setq ov (org-columns-new-overlay beg (point-at-eol)))
- (org-overlay-put ov 'invisible t)
- (org-overlay-put ov 'keymap org-columns-map)
- (org-overlay-put ov 'intangible t)
- (push ov org-columns-overlays)
- (setq ov (org-make-overlay (1- (point-at-eol)) (1+ (point-at-eol))))
- (org-overlay-put ov 'keymap org-columns-map)
- (push ov org-columns-overlays)
- (let ((inhibit-read-only t))
- (put-text-property (max (point-min) (1- (point-at-bol)))
+ ;; Make the rest of the line disappear.
+ (org-unmodified
+ (setq ov (org-columns-new-overlay beg (point-at-eol)))
+ (org-overlay-put ov 'invisible t)
+ (org-overlay-put ov 'keymap org-columns-map)
+ (org-overlay-put ov 'intangible t)
+ (push ov org-columns-overlays)
+ (setq ov (org-make-overlay (1- (point-at-eol)) (1+ (point-at-eol))))
+ (org-overlay-put ov 'keymap org-columns-map)
+ (push ov org-columns-overlays)
+ (let ((inhibit-read-only t))
+ (put-text-property (max (point-min) (1- (point-at-bol)))
(min (point-max) (1+ (point-at-eol)))
'read-only "Type `e' to edit property")))))
+(defun org-columns-add-ellipses (string width)
+ "Truncate STRING with WIDTH characters, with ellipses."
+ (cond
+ ((<= (length string) width) string)
+ ((<= width (length org-columns-ellipses))
+ (substring org-columns-ellipses 0 width))
+ (t (concat (substring string 0 (- width (length org-columns-ellipses)))
+ org-columns-ellipses))))
+
(defvar org-columns-full-header-line-format nil
- "Fthe full header line format, will be shifted by horizontal scrolling." )
+ "The full header line format, will be shifted by horizontal scrolling." )
(defvar org-previous-header-line-format nil
"The header line format before column view was turned on.")
(defvar org-columns-inhibit-recalculation nil
(defvar header-line-format)
(defvar org-columns-previous-hscroll 0)
+
(defun org-columns-display-here-title ()
"Overlay the newline before the current line with the table title."
(interactive)
org-columns-previous-hscroll (window-hscroll))
(force-mode-line-update)))
+(defvar org-colview-initial-truncate-line-value nil
+ "Remember the value of `truncate-lines' across colview.")
+
(defun org-columns-remove-overlays ()
"Remove all currently active column overlays."
(interactive)
(let ((inhibit-read-only t))
(remove-text-properties (point-min) (point-max) '(read-only t))))
(when org-columns-flyspell-was-active
- (flyspell-mode 1)))))
+ (flyspell-mode 1))
+ (when (local-variable-p 'org-colview-initial-truncate-line-value)
+ (setq truncate-lines org-colview-initial-truncate-line-value)))))
(defun org-columns-cleanup-item (item fmt)
"Remove from ITEM what is a column in the format FMT."
(if (not org-complex-heading-regexp)
item
(when (string-match org-complex-heading-regexp item)
- (concat
- (org-add-props (concat (match-string 1 item) " ") nil
- 'org-whitespace (* 2 (1- (org-reduced-level (- (match-end 1) (match-beginning 1))))))
- (and (match-end 2) (not (assoc "TODO" fmt)) (concat " " (match-string 2 item)))
- (and (match-end 3) (not (assoc "PRIORITY" fmt)) (concat " " (match-string 3 item)))
- " " (match-string 4 item)
- (and (match-end 5) (not (assoc "TAGS" fmt)) (concat " " (match-string 5 item)))))))
+ (setq item
+ (concat
+ (org-add-props (match-string 1 item) nil
+ 'org-whitespace (* 2 (1- (org-reduced-level (- (match-end 1) (match-beginning 1))))))
+ (and (match-end 2) (not (assoc "TODO" fmt)) (concat " " (match-string 2 item)))
+ (and (match-end 3) (not (assoc "PRIORITY" fmt)) (concat " " (match-string 3 item)))
+ " " (save-match-data (org-columns-compact-links (match-string 4 item)))
+ (and (match-end 5) (not (assoc "TAGS" fmt)) (concat " " (match-string 5 item)))))
+ (add-text-properties
+ 0 (1+ (match-end 1))
+ (list 'org-whitespace (* 2 (1- (org-reduced-level (- (match-end 1) (match-beginning 1))))))
+ item)
+ item)))
+
+(defun org-columns-compact-links (s)
+ "Replace [[link][desc]] with [desc] or [link]."
+ (while (string-match org-bracket-link-regexp s)
+ (setq s (replace-match
+ (concat "[" (match-string (if (match-end 3) 3 1) s) "]")
+ t t s)))
+ s)
+
+(defvar org-agenda-columns-remove-prefix-from-item)
+
+(defun org-agenda-columns-cleanup-item (item pl cphr fmt)
+ "Cleanup the time property for agenda column view.
+See also the variable `org-agenda-columns-remove-prefix-from-item'."
+ (let* ((org-complex-heading-regexp cphr)
+ (prefix (substring item 0 pl))
+ (rest (substring item pl))
+ (fake (concat "* " rest))
+ (cleaned (org-trim (substring (org-columns-cleanup-item fake fmt) 1))))
+ (if org-agenda-columns-remove-prefix-from-item
+ cleaned
+ (concat prefix cleaned))))
(defun org-columns-show-value ()
"Show the full value of the property."
(message "Value is: %s" (or value ""))))
(defvar org-agenda-columns-active) ;; defined in org-agenda.el
+
(defun org-columns-quit ()
"Remove the column overlays and in this way exit column editing."
(interactive)
Where possible, use the standard interface for changing this line."
(interactive)
(org-columns-check-computed)
- (let* ((external-key key)
- (col (current-column))
+ (let* ((col (current-column))
(key (or key (get-char-property (point) 'org-columns-key)))
(value (get-char-property (point) 'org-columns-value))
(bol (point-at-bol)) (eol (point-at-eol))
(<= (overlay-start x) eol)
x))
org-columns-overlays)))
+ (org-columns-time (time-to-number-of-days (current-time)))
nval eval allowed)
(cond
((equal key "CLOCKSUM")
(setq eval '(org-with-point-at pom
(org-edit-headline))))
((equal key "TODO")
- (setq eval '(org-with-point-at pom
- (let ((current-prefix-arg
- (if external-key current-prefix-arg '(4))))
- (call-interactively 'org-todo)))))
+ (setq eval '(org-with-point-at
+ pom
+ (call-interactively 'org-todo))))
((equal key "PRIORITY")
(setq eval '(org-with-point-at pom
(call-interactively 'org-priority))))
((equal key "SCHEDULED")
(setq eval '(org-with-point-at pom
(call-interactively 'org-schedule))))
+ ((equal key "BEAMER_env")
+ (setq eval '(org-with-point-at pom
+ (call-interactively 'org-beamer-set-environment-tag))))
(t
(setq allowed (org-property-get-allowed-values pom key 'table))
(if allowed
- (setq nval (completing-read "Value: " allowed nil t))
+ (setq nval (org-icompleting-read
+ "Value: " allowed nil
+ (not (get-text-property 0 'org-unrestricted
+ (caar allowed)))))
(setq nval (read-string "Edit: " value)))
(setq nval (org-trim nval))
(when (not (equal nval value))
(cond
((equal major-mode 'org-agenda-mode)
- (org-columns-eval '(org-entry-put pom key nval))
+ (org-columns-eval eval)
;; The following let preserves the current format, and makes sure
;; that in only a single file things need to be upated.
(let* ((org-agenda-overriding-columns-format org-columns-current-fmt)
"Edit the current headline, the part without TODO keyword, TAGS."
(org-back-to-heading)
(when (looking-at org-todo-line-regexp)
- (let ((pre (buffer-substring (match-beginning 0) (match-beginning 3)))
+ (let ((pos (point))
+ (pre (buffer-substring (match-beginning 0) (match-beginning 3)))
(txt (match-string 3))
(post "")
txt2)
txt (substring txt 0 (match-beginning 0))))
(setq txt2 (read-string "Edit: " txt))
(when (not (equal txt txt2))
- (beginning-of-line 1)
+ (goto-char pos)
(insert pre txt2 post)
(delete-region (point) (point-at-eol))
(org-set-tags nil t)))))
(defun org-columns-edit-allowed ()
"Edit the list of allowed values for the current property."
(interactive)
- (let* ((pom (or (get-text-property (point-at-bol) 'org-marker)
- (get-text-property (point-at-bol) 'org-hd-marker)
+ (let* ((pom (or (org-get-at-bol 'org-marker)
+ (org-get-at-bol 'org-hd-marker)
(point)))
(key (get-char-property (point) 'org-columns-key))
(key1 (concat key "_ALL"))
(interactive)
(org-columns-next-allowed-value t))
-(defun org-columns-next-allowed-value (&optional previous)
- "Switch to the next allowed value for this column."
+(defun org-columns-next-allowed-value (&optional previous nth)
+ "Switch to the next allowed value for this column.
+When PREVIOUS is set, go to the previous value. When NTH is
+an integer, select that value."
(interactive)
(org-columns-check-computed)
(let* ((col (current-column))
(and (memq
(nth 4 (assoc key org-columns-current-fmt-compiled))
'(checkbox checkbox-n-of-m checkbox-percent))
- '("[ ]" "[X]"))))
+ '("[ ]" "[X]"))
+ (org-colview-construct-allowed-dates value)))
nval)
+ (when (integerp nth)
+ (setq nth (1- nth))
+ (if (= nth -1) (setq nth 9)))
(when (equal key "ITEM")
(error "Cannot edit item headline from here"))
(unless (or allowed (member key '("SCHEDULED" "DEADLINE")))
(if (member key '("SCHEDULED" "DEADLINE"))
(setq nval (if previous 'earlier 'later))
(if previous (setq allowed (reverse allowed)))
- (if (member value allowed)
- (setq nval (car (cdr (member value allowed)))))
- (setq nval (or nval (car allowed)))
- (if (equal nval value)
- (error "Only one allowed value for this property")))
+ (cond
+ (nth
+ (setq nval (nth nth allowed))
+ (if (not nval)
+ (error "There are only %d allowed values for property `%s'"
+ (length allowed) key)))
+ ((member value allowed)
+ (setq nval (or (car (cdr (member value allowed)))
+ (car allowed)))
+ (if (equal nval value)
+ (error "Only one allowed value for this property")))
+ (t (setq nval (car allowed)))))
(cond
((equal major-mode 'org-agenda-mode)
(org-columns-eval '(org-entry-put pom key nval))
(and (nth 3 (assoc key org-columns-current-fmt-compiled))
(org-columns-update key))))))
+(defun org-colview-construct-allowed-dates (s)
+ "Construct a list of three dates around the date in S.
+This respects the format of the time stamp in S, active or non-active,
+and also including time or not. S must be just a time stamp, no text
+around it."
+ (when (and s (string-match (concat "^" org-ts-regexp3 "$") s))
+ (let* ((time (org-parse-time-string s 'nodefaults))
+ (active (equal (string-to-char s) ?<))
+ (fmt (funcall (if (nth 1 time) 'cdr 'car) org-time-stamp-formats))
+ time-before time-after)
+ (unless active (setq fmt (concat "[" (substring fmt 1 -1) "]")))
+ (setf (car time) (or (car time) 0))
+ (setf (nth 1 time) (or (nth 1 time) 0))
+ (setf (nth 2 time) (or (nth 2 time) 0))
+ (setq time-before (copy-sequence time))
+ (setq time-after (copy-sequence time))
+ (setf (nth 3 time-before) (1- (nth 3 time)))
+ (setf (nth 3 time-after) (1+ (nth 3 time)))
+ (mapcar (lambda (x) (format-time-string fmt (apply 'encode-time x)))
+ (list time-before time time-after)))))
+
(defun org-verify-version (task)
(cond
((eq task 'columns)
(defun org-columns-get-format-and-top-level ()
(let (fmt)
(when (condition-case nil (org-back-to-heading) (error nil))
- (move-marker org-entry-property-inherited-from nil)
(setq fmt (org-entry-get nil "COLUMNS" t)))
(setq fmt (or fmt org-columns-default-format))
(org-set-local 'org-columns-current-fmt fmt)
(org-verify-version 'columns)
(org-columns-remove-overlays)
(move-marker org-columns-begin-marker (point))
- (let (beg end fmt cache maxwidths)
+ (let ((org-columns-time (time-to-number-of-days (current-time)))
+ beg end fmt cache maxwidths)
(setq fmt (org-columns-get-format-and-top-level))
(save-excursion
(goto-char org-columns-top-level-marker)
(narrow-to-region beg end)
(org-clock-sum))))
(while (re-search-forward (concat "^" outline-regexp) end t)
- (push (cons (org-current-line) (org-entry-properties)) cache))
+ (if (and org-columns-skip-archived-trees
+ (looking-at (concat ".*:" org-archive-tag ":")))
+ (org-end-of-subtree t)
+ (push (cons (org-current-line) (org-entry-properties)) cache)))
(when cache
(setq maxwidths (org-columns-get-autowidth-alist fmt cache))
(org-set-local 'org-columns-current-maxwidths maxwidths)
(when (org-set-local 'org-columns-flyspell-was-active
(org-bound-and-true-p flyspell-mode))
(flyspell-mode 0))
+ (unless (local-variable-p 'org-colview-initial-truncate-line-value)
+ (org-set-local 'org-colview-initial-truncate-line-value
+ truncate-lines))
+ (setq truncate-lines t)
(mapc (lambda (x)
- (goto-line (car x))
+ (org-goto-line (car x))
(org-columns-display-here (cdr x)))
cache)))))
-(defun org-columns-new (&optional prop title width op fmt &rest rest)
+(eval-when-compile (defvar org-columns-time))
+
+(defvar org-columns-compile-map
+ '(("none" none +)
+ (":" add_times +)
+ ("+" add_numbers +)
+ ("$" currency +)
+ ("X" checkbox +)
+ ("X/" checkbox-n-of-m +)
+ ("X%" checkbox-percent +)
+ ("max" max_numbers max)
+ ("min" min_numbers min)
+ ("mean" mean_numbers
+ (lambda (&rest x) (/ (apply '+ x) (float (length x)))))
+ (":max" max_times max)
+ (":min" min_times min)
+ (":mean" mean_times
+ (lambda (&rest x) (/ (apply '+ x) (float (length x)))))
+ ("@min" min_age min (lambda (x) (- org-columns-time x)))
+ ("@max" max_age max (lambda (x) (- org-columns-time x)))
+ ("@mean" mean_age
+ (lambda (&rest x) (/ (apply '+ x) (float (length x))))
+ (lambda (x) (- org-columns-time x))))
+ "Operator <-> format,function,calc map.
+Used to compile/uncompile columns format and completing read in
+interactive function org-columns-new.
+
+operator string used in #+COLUMNS definition describing the
+ summary type
+format symbol describing summary type selected interactively in
+ org-columns-new and internally in
+ org-columns-number-to-string and
+ org-columns-string-to-number
+function called with a list of values as argument to calculate
+ the summary value
+calc function called on every element before summarizing. This is
+ optional and should only be specified if needed")
+
+(defun org-columns-new (&optional prop title width op fmt fun &rest rest)
"Insert a new column, to the left of the current column."
(interactive)
(let ((editp (and prop (assoc prop org-columns-current-fmt-compiled)))
cell)
- (setq prop (completing-read
+ (setq prop (org-icompleting-read
"Property: " (mapcar 'list (org-buffer-property-keys t nil t))
nil nil prop))
(setq title (read-string (concat "Column title [" prop "]: ") (or title prop)))
(if (string-match "\\S-" width)
(setq width (string-to-number width))
(setq width nil))
- (setq fmt (completing-read "Summary [none]: "
- '(("none") ("add_numbers") ("currency") ("add_times") ("checkbox") ("checkbox-n-of-m") ("checkbox-percent"))
- nil t))
- (if (string-match "\\S-" fmt)
- (setq fmt (intern fmt))
- (setq fmt nil))
+ (setq fmt (org-icompleting-read
+ "Summary [none]: "
+ (mapcar (lambda (x) (list (symbol-name (cadr x))))
+ org-columns-compile-map)
+ nil t))
+ (setq fmt (intern fmt)
+ fun (cdr (assoc fmt (mapcar 'cdr org-columns-compile-map))))
(if (eq fmt 'none) (setq fmt nil))
(if editp
(progn
(setcar editp prop)
- (setcdr editp (list title width nil fmt)))
+ (setcdr editp (list title width nil fmt nil fun)))
(setq cell (nthcdr (1- (current-column))
org-columns-current-fmt-compiled))
- (setcdr cell (cons (list prop title width nil fmt)
+ (setcdr cell (cons (list prop title width nil fmt nil
+ (car fun) (cadr fun))
(cdr cell))))
(org-columns-store-format)
(org-columns-redo)))
(org-columns-redo)))
(defun org-columns-narrow (arg)
- "Make the column nrrower by ARG characters."
+ "Make the column narrower by ARG characters."
(interactive "p")
(org-columns-widen (- arg)))
"Compute all columns that have operators defined."
(org-unmodified
(remove-text-properties (point-min) (point-max) '(org-summaries t)))
- (let ((columns org-columns-current-fmt-compiled) col)
+ (let ((columns org-columns-current-fmt-compiled)
+ (org-columns-time (time-to-number-of-days (current-time)))
+ col)
(while (setq col (pop columns))
(when (nth 3 col)
(save-excursion
(interactive)
(let* ((re (concat "^" outline-regexp))
(lmax 30) ; Does anyone use deeper levels???
- (lsum (make-vector lmax 0))
+ (lvals (make-vector lmax nil))
(lflag (make-vector lmax nil))
(level 0)
(ass (assoc property org-columns-current-fmt-compiled))
(format (nth 4 ass))
(printf (nth 5 ass))
+ (fun (nth 6 ass))
+ (calc (or (nth 7 ass) 'identity))
(beg org-columns-top-level-marker)
last-level val valflag flag end sumpos sum-alist sum str str1 useval)
(save-excursion
(cond
((< level last-level)
;; put the sum of lower levels here as a property
- (setq sum (aref lsum last-level) ; current sum
+ (setq sum (when (aref lvals last-level)
+ (apply fun (aref lvals last-level)))
flag (aref lflag last-level) ; any valid entries from children?
str (org-columns-number-to-string sum format printf)
str1 (org-add-props (copy-sequence str) nil 'org-computed t 'face 'bold)
(list 'org-summaries sum-alist))))
(when (and val (not (equal val (if flag str val))))
(org-entry-put nil property (if flag str val)))
- ;; add current to current level accumulator
+ ;; add current to current level accumulator
(when (or flag valflag)
- (aset lsum level (+ (aref lsum level)
- (if flag sum (org-column-string-to-number
- (if flag str val) format))))
+ (push (if flag
+ sum
+ (funcall calc (org-columns-string-to-number
+ (if flag str val) format)))
+ (aref lvals level))
(aset lflag level t))
;; clear accumulators for deeper levels
(loop for l from (1+ level) to (1- lmax) do
- (aset lsum l 0)
+ (aset lvals l nil)
(aset lflag l nil)))
((>= level last-level)
;; add what we have here to the accumulator for this level
- (aset lsum level (+ (aref lsum level)
- (org-column-string-to-number (or val "0") format)))
- (and valflag (aset lflag level t)))
+ (when valflag
+ (push (funcall calc (org-columns-string-to-number val format))
+ (aref lvals level))
+ (aset lflag level t)))
(t (error "This should not happen")))))))
(defun org-columns-redo ()
"Construct the column display again."
(interactive)
(message "Recomputing columns...")
- (save-excursion
- (if (marker-position org-columns-begin-marker)
- (goto-char org-columns-begin-marker))
- (org-columns-remove-overlays)
- (if (org-mode-p)
- (call-interactively 'org-columns)
- (call-interactively 'org-agenda-columns)))
+ (let ((line (org-current-line))
+ (col (current-column)))
+ (save-excursion
+ (if (marker-position org-columns-begin-marker)
+ (goto-char org-columns-begin-marker))
+ (org-columns-remove-overlays)
+ (if (org-mode-p)
+ (call-interactively 'org-columns)
+ (org-agenda-redo)
+ (call-interactively 'org-agenda-columns)))
+ (org-goto-line line)
+ (move-to-column col))
(message "Recomputing columns...done"))
(defun org-columns-not-in-agenda ()
(if (eq major-mode 'org-agenda-mode)
(error "This command is only allowed in Org-mode buffers")))
-
(defun org-string-to-number (s)
"Convert string to number, and interpret hh:mm:ss."
(if (not (string-match ":" s))
(defun org-columns-number-to-string (n fmt &optional printf)
"Convert a computed column number to a string value, according to FMT."
(cond
- ((eq fmt 'add_times)
+ ((not (numberp n)) "")
+ ((memq fmt '(add_times max_times min_times mean_times))
(let* ((h (floor n)) (m (floor (+ 0.5 (* 60 (- n h))))))
- (format "%d:%02d" h m)))
+ (format org-time-clocksum-format h m)))
((eq fmt 'checkbox)
(cond ((= n (floor n)) "[X]")
((> n 1.) "[-]")
(printf (format printf n))
((eq fmt 'currency)
(format "%.2f" n))
+ ((memq fmt '(min_age max_age mean_age))
+ (org-format-time-period n))
(t (number-to-string n))))
(defun org-nofm-to-completion (n m &optional percent)
(format "[%d/%d]" n m)
(format "[%d%%]"(floor (+ 0.5 (* 100. (/ (* 1.0 n) m)))))))
-(defun org-column-string-to-number (s fmt)
+(defun org-columns-string-to-number (s fmt)
"Convert a column value to a number that can be used for column computing."
- (cond
- ((string-match ":" s)
- (let ((l (nreverse (org-split-string s ":"))) (sum 0.0))
- (while l
- (setq sum (+ (string-to-number (pop l)) (/ sum 60))))
- sum))
- ((memq fmt '(checkbox checkbox-n-of-m checkbox-percent))
- (if (equal s "[X]") 1. 0.000001))
- (t (string-to-number s))))
+ (if s
+ (cond
+ ((memq fmt '(min_age max_age mean_age))
+ (cond ((string= s "") org-columns-time)
+ ((string-match
+ "\\([0-9]+\\)d \\([0-9]+\\)h \\([0-9]+\\)m \\([0-9]+\\)s"
+ s)
+ (+ (* 60 (+ (* 60 (+ (* 24 (string-to-number (match-string 1 s)))
+ (string-to-number (match-string 2 s))))
+ (string-to-number (match-string 3 s))))
+ (string-to-number (match-string 4 s))))
+ (t (time-to-number-of-days (apply 'encode-time
+ (org-parse-time-string s t))))))
+ ((string-match ":" s)
+ (let ((l (nreverse (org-split-string s ":"))) (sum 0.0))
+ (while l
+ (setq sum (+ (string-to-number (pop l)) (/ sum 60))))
+ sum))
+ ((memq fmt '(checkbox checkbox-n-of-m checkbox-percent))
+ (if (equal s "[X]") 1. 0.000001))
+ (t (string-to-number s)))))
(defun org-columns-uncompile-format (cfmt)
"Turn the compiled columns format back into a string representation."
- (let ((rtn "") e s prop title op width fmt printf)
+ (let ((rtn "") e s prop title op op-match width fmt printf fun calc)
(while (setq e (pop cfmt))
(setq prop (car e)
title (nth 1 e)
width (nth 2 e)
op (nth 3 e)
fmt (nth 4 e)
- printf (nth 5 e))
- (cond
- ((eq fmt 'add_times) (setq op ":"))
- ((eq fmt 'checkbox) (setq op "X"))
- ((eq fmt 'checkbox-n-of-m) (setq op "X/"))
- ((eq fmt 'checkbox-percent) (setq op "X%"))
- ((eq fmt 'add_numbers) (setq op "+"))
- ((eq fmt 'currency) (setq op "$")))
+ printf (nth 5 e)
+ fun (nth 6 e)
+ calc (nth 7 e))
+ (when (setq op-match (rassoc (list fmt fun calc) org-columns-compile-map))
+ (setq op (car op-match)))
(if (and op printf) (setq op (concat op ";" printf)))
(if (equal title prop) (setq title nil))
(setq s (concat "%" (if width (number-to-string width))
width the column width in characters, can be nil for automatic
operator the operator if any
format the output format for computed results, derived from operator
-printf a printf format for computed values"
- (let ((start 0) width prop title op f printf)
+printf a printf format for computed values
+fun the lisp function to compute summary values, derived from operator
+calc function to get values from base elements
+"
+ (let ((start 0) width prop title op op-match f printf fun calc)
(setq org-columns-current-fmt-compiled nil)
(while (string-match
(org-re "%\\([0-9]+\\)?\\([[:alnum:]_-]+\\)\\(?:(\\([^)]+\\))\\)?\\(?:{\\([^}]+\\)}\\)?\\s-*")
title (or (match-string 3 fmt) prop)
op (match-string 4 fmt)
f nil
- printf nil)
+ printf nil
+ fun '+
+ calc nil)
(if width (setq width (string-to-number width)))
(when (and op (string-match ";" op))
(setq printf (substring op (match-end 0))
op (substring op 0 (match-beginning 0))))
- (cond
- ((equal op "+") (setq f 'add_numbers))
- ((equal op "$") (setq f 'currency))
- ((equal op ":") (setq f 'add_times))
- ((equal op "X") (setq f 'checkbox))
- ((equal op "X/") (setq f 'checkbox-n-of-m))
- ((equal op "X%") (setq f 'checkbox-percent))
- )
- (push (list prop title width op f printf) org-columns-current-fmt-compiled))
+ (when (setq op-match (assoc op org-columns-compile-map))
+ (setq f (cadr op-match)
+ fun (caddr op-match)
+ calc (cadddr op-match)))
+ (push (list prop title width op f printf fun calc)
+ org-columns-current-fmt-compiled))
(setq org-columns-current-fmt-compiled
(nreverse org-columns-current-fmt-compiled))))
of fields."
(save-excursion
(let* ((title (mapcar 'cadr org-columns-current-fmt-compiled))
+ (re-comment (concat "\\*+[ \t]+" org-comment-string "\\>"))
+ (re-archive (concat ".*:" org-archive-tag ":"))
(n (length title)) row tbl)
(goto-char (point-min))
- (while (and (re-search-forward "^\\(\\*+\\) " nil t)
- (or (null maxlevel)
- (>= maxlevel
- (if org-odd-levels-only
- (/ (1+ (length (match-string 1))) 2)
- (length (match-string 1))))))
- (when (get-char-property (match-beginning 0) 'org-columns-key)
- (setq row nil)
- (loop for i from 0 to (1- n) do
- (push (or (get-char-property (+ (match-beginning 0) i) 'org-columns-value-modified)
- (get-char-property (+ (match-beginning 0) i) 'org-columns-value)
- "")
- row))
- (setq row (nreverse row))
- (unless (and skip-empty-rows
- (eq 1 (length (delete "" (delete-dups row)))))
- (push row tbl))))
+ (while (re-search-forward "^\\(\\*+\\) " nil t)
+ (catch 'next
+ (when (and (or (null maxlevel)
+ (>= maxlevel
+ (if org-odd-levels-only
+ (/ (1+ (length (match-string 1))) 2)
+ (length (match-string 1)))))
+ (get-char-property (match-beginning 0) 'org-columns-key))
+ (when (save-excursion
+ (goto-char (point-at-bol))
+ (or (looking-at re-comment)
+ (looking-at re-archive)))
+ (org-end-of-subtree t)
+ (throw 'next t))
+ (setq row nil)
+ (loop for i from 0 to (1- n) do
+ (push
+ (org-quote-vert
+ (or (get-char-property (+ (match-beginning 0) i) 'org-columns-value-modified)
+ (get-char-property (+ (match-beginning 0) i) 'org-columns-value)
+ ""))
+ row))
+ (setq row (nreverse row))
+ (unless (and skip-empty-rows
+ (eq 1 (length (delete "" (delete-dups (copy-sequence row))))))
+ (push row tbl)))))
(append (list title 'hline) (nreverse tbl)))))
(defun org-dblock-write:columnview (params)
:width enforce same column widths with <N> specifiers.
:id the :ID: property of the entry where the columns view
- should be built, as a string. When `local', call locally.
- When `global' call column view with the cursor at the beginning
- of the buffer (usually this means that the whole buffer switches
- to column view).
+ should be built. When the symbol `local', call locally.
+ When `global' call column view with the cursor at the beginning
+ of the buffer (usually this means that the whole buffer switches
+ to column view). When \"file:path/to/file.org\", invoke column
+ view at the start of that file. Otherwise, the ID is located
+ using `org-id-find'.
:hlines When t, insert a hline before each item. When a number, insert
- a hline before each level <= that number.
+ a hline before each level <= that number.
:vlines When t, make each column a colgroup to enforce vertical lines.
:maxlevel When set to a number, don't capture headlines below this level.
:skip-empty-rows
- When t, skip rows where all specifiers other than ITEM are empty."
+ When t, skip rows where all specifiers other than ITEM are empty."
(let ((pos (move-marker (make-marker) (point)))
(hlines (plist-get params :hlines))
(vlines (plist-get params :vlines))
(maxlevel (plist-get params :maxlevel))
+ (content-lines (org-split-string (plist-get params :content) "\n"))
(skip-empty-rows (plist-get params :skip-empty-rows))
- tbl id idpos nfields tmp)
- (save-excursion
- (save-restriction
- (when (setq id (plist-get params :id))
- (cond ((not id) nil)
- ((eq id 'global) (goto-char (point-min)))
- ((eq id 'local) nil)
- ((setq idpos (org-find-entry-with-id id))
- (goto-char idpos))
- (t (error "Cannot find entry with :ID: %s" id))))
- (org-columns)
- (setq tbl (org-columns-capture-view maxlevel skip-empty-rows))
- (setq nfields (length (car tbl)))
- (org-columns-quit)))
+ tbl id idpos nfields tmp recalc line
+ id-as-string view-file view-pos)
+ (when (setq id (plist-get params :id))
+ (setq id-as-string (cond ((numberp id) (number-to-string id))
+ ((symbolp id) (symbol-name id))
+ ((stringp id) id)
+ (t "")))
+ (cond ((not id) nil)
+ ((eq id 'global) (setq view-pos (point-min)))
+ ((eq id 'local))
+ ((string-match "^file:\\(.*\\)" id-as-string)
+ (setq view-file (match-string 1 id-as-string)
+ view-pos 1)
+ (unless (file-exists-p view-file)
+ (error "No such file: \"%s\"" id-as-string)))
+ ((setq idpos (org-find-entry-with-id id))
+ (setq view-pos idpos))
+ ((setq idpos (org-id-find id))
+ (setq view-file (car idpos))
+ (setq view-pos (cdr idpos)))
+ (t (error "Cannot find entry with :ID: %s" id))))
+ (with-current-buffer (if view-file
+ (get-file-buffer view-file)
+ (current-buffer))
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (or view-pos (point)))
+ (org-columns)
+ (setq tbl (org-columns-capture-view maxlevel skip-empty-rows))
+ (setq nfields (length (car tbl)))
+ (org-columns-quit))))
(goto-char pos)
(move-marker pos nil)
(when tbl
(if (string-match "\\` *\\(\\*+\\)" (caar tbl))
(if (and (not (eq (car tmp) 'hline))
(or (eq hlines t)
- (and (numberp hlines) (<= (- (match-end 1) (match-beginning 1)) hlines))))
+ (and (numberp hlines)
+ (<= (- (match-end 1) (match-beginning 1))
+ hlines))))
(push 'hline tmp)))
(push (pop tbl) tmp)))
(setq tbl (nreverse tmp)))
tbl))
(setq tbl (append tbl (list (cons "/" (make-list nfields "<>"))))))
(setq pos (point))
+ (when content-lines
+ (while (string-match "^#" (car content-lines))
+ (insert (pop content-lines) "\n")))
(insert (org-listtable-to-string tbl))
(when (plist-get params :width)
(insert "\n|" (mapconcat (lambda (x) (format "<%d>" (max 3 x)))
org-columns-current-widths "|")))
- (goto-char pos)
- (org-table-align))))
+ (while (setq line (pop content-lines))
+ (when (string-match "^#" line)
+ (insert "\n" line)
+ (when (string-match "^[ \t]*#\\+TBLFM" line)
+ (setq recalc t))))
+ (if recalc
+ (progn (goto-char pos) (org-table-recalculate 'all))
+ (goto-char pos)
+ (org-table-align)))))
(defun org-listtable-to-string (tbl)
"Convert a listtable TBL to a string that contains the Org-mode table.
-The table still need to be alligned. The resulting string has no leading
+The table still need to be aligned. The resulting string has no leading
and tailing newline characters."
(mapconcat
(lambda (x)
"Create a dynamic block capturing a column view table."
(interactive)
(let ((defaults '(:name "columnview" :hlines 1))
- (id (completing-read
+ (id (org-icompleting-read
"Capture columns (local, global, entry with :ID: property) [local]: "
(append '(("global") ("local"))
(mapcar 'list (org-property-values "ID"))))))
(org-verify-version 'columns)
(org-columns-remove-overlays)
(move-marker org-columns-begin-marker (point))
- (let (fmt cache maxwidths m p a d)
+ (let ((org-columns-time (time-to-number-of-days (current-time)))
+ cache maxwidths m p a d fmt)
(cond
((and (boundp 'org-agenda-overriding-columns-format)
org-agenda-overriding-columns-format)
(setq fmt org-agenda-overriding-columns-format)
(org-set-local 'org-agenda-overriding-columns-format fmt))
- ((setq m (get-text-property (point-at-bol) 'org-hd-marker))
+ ((setq m (org-get-at-bol 'org-hd-marker))
(setq fmt (or (org-entry-get m "COLUMNS" t)
(with-current-buffer (marker-buffer m)
org-columns-default-format))))
;; Get and cache the properties
(goto-char (point-min))
(while (not (eobp))
- (when (setq m (or (get-text-property (point) 'org-hd-marker)
- (get-text-property (point) 'org-marker)))
+ (when (setq m (or (org-get-at-bol 'org-hd-marker)
+ (org-get-at-bol 'org-marker)))
(setq p (org-entry-properties m))
(when (or (not (setq a (assoc org-effort-property p)))
(org-bound-and-true-p flyspell-mode))
(flyspell-mode 0))
(mapc (lambda (x)
- (goto-line (car x))
+ (org-goto-line (car x))
(org-columns-display-here (cdr x)))
cache)
(when org-agenda-columns-show-summaries
"Summarize the summarizable columns in column view in the agenda.
This will add overlays to the date lines, to show the summary for each day."
(let* ((fmt (mapcar (lambda (x)
- (list (car x) (if (equal (car x) "CLOCKSUM")
- 'add_times (nth 4 x))))
+ (if (equal (car x) "CLOCKSUM")
+ (list "CLOCKSUM" (nth 1 x) (nth 2 x) ":" 'add_times
+ nil '+ nil)
+ x))
org-columns-current-fmt-compiled))
- line c c1 stype props lsum entries prop v)
+ line c c1 stype calc sumfunc props lsum entries prop v title)
(catch 'exit
(when (delq nil (mapcar 'cadr fmt))
;; OK, at least one summation column, it makes sense to try this
(setq props
(mapcar
(lambda (f)
- (setq prop (car f) stype (nth 1 f))
+ (setq prop (car f)
+ title (nth 1 f)
+ stype (nth 4 f)
+ sumfunc (nth 6 f)
+ calc (or (nth 7 f) 'identity))
(cond
((equal prop "ITEM")
(cons prop (buffer-substring (point-at-bol)
(point-at-eol))))
((not stype) (cons prop ""))
- (t
- ;; do the summary
- (setq lsum 0)
- (mapc (lambda (x)
- (setq v (cdr (assoc prop x)))
- (if v (setq lsum (+ lsum
- (org-column-string-to-number
- v stype)))))
- entries)
- (setq lsum (org-columns-number-to-string lsum stype))
- (put-text-property
- 0 (length lsum) 'face 'bold lsum)
+ (t ;; do the summary
+ (setq lsum nil)
+ (dolist (x entries)
+ (setq v (cdr (assoc prop x)))
+ (if v
+ (push
+ (funcall
+ (if (not (get-text-property 0 'org-computed v))
+ calc
+ 'identity)
+ (org-columns-string-to-number
+ v stype))
+ lsum)))
+ (setq lsum (remove nil lsum))
+ (setq lsum
+ (cond ((> (length lsum) 1)
+ (org-columns-number-to-string
+ (apply sumfunc lsum) stype))
+ ((eq (length lsum) 1)
+ (org-columns-number-to-string
+ (car lsum) stype))
+ (t "")))
+ (put-text-property 0 (length lsum) 'face 'bold lsum)
+ (unless (eq calc 'identity)
+ (put-text-property 0 (length lsum) 'org-computed t lsum))
(cons prop lsum))))
fmt))
- (org-columns-display-here props)
+ (org-columns-display-here props 'dateline)
(org-set-local 'org-agenda-columns-active t)))
(if (bobp) (throw 'exit t))
(beginning-of-line 0))))))
(equal (nth 4 a) (nth 4 fm)))
(org-columns-compute (car fm)))))))))))
-(provide 'org-colview)
+(defun org-format-time-period (interval)
+ "Convert time in fractional days to days/hours/minutes/seconds"
+ (if (numberp interval)
+ (let* ((days (floor interval))
+ (frac-hours (* 24 (- interval days)))
+ (hours (floor frac-hours))
+ (minutes (floor (* 60 (- frac-hours hours))))
+ (seconds (floor (* 60 (- (* 60 (- frac-hours hours)) minutes)))))
+ (format "%dd %02dh %02dm %02ds" days hours minutes seconds))
+ ""))
-;;; org-colview.el ends here
+
+(provide 'org-colview)
;; arch-tag: 61f5128d-747c-4983-9479-e3871fa3d73c
+
+;;; org-colview.el ends here
HCoop / bpt / emacs.git / blobdiff