;;; 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.13
+;; Version: 7.4
;;
;; 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:
(require 'org)
(declare-function org-agenda-redo "org-agenda" ())
+(declare-function org-agenda-do-context-action "org-agenda" ())
+
+(when (featurep 'xemacs)
+ (error "Do not load this file into XEmacs, use 'org-colview-xemacs.el'."))
;;; Column View
(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 [(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))))
+ `(lambda () (interactive)
+ (org-columns-next-allowed-value nil ,i))))
(easy-menu-define org-columns-menu org-columns-map "Org Column Menu"
'("Column"
(defun org-columns-new-overlay (beg end &optional string face)
"Create a new column overlay and add it to the list."
- (let ((ov (org-make-overlay beg end)))
- (org-overlay-put ov 'face (or face 'secondary-selection))
+ (let ((ov (make-overlay beg end)))
+ (overlay-put ov 'face (or face 'secondary-selection))
(org-overlay-display ov string face)
(push ov org-columns-overlays)
ov))
(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 s1 s2 title)
+ 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
(nth 2 column)
(length property))
f (format "%%-%d.%ds | " width width)
+ calc (nth 7 column)
val (or (cdr ass) "")
- modval (or (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))
- (if (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)))))
+ 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 (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))
- (org-overlay-put ov 'org-columns-value-modified modval)
- (org-overlay-put ov 'org-columns-pom pom)
- (org-overlay-put ov 'org-columns-format f))
+ (overlay-put ov 'keymap org-columns-map)
+ (overlay-put ov 'org-columns-key property)
+ (overlay-put ov 'org-columns-value (cdr ass))
+ (overlay-put ov 'org-columns-value-modified modval)
+ (overlay-put ov 'org-columns-pom pom)
+ (overlay-put ov 'org-columns-format f)
+ (overlay-put ov 'line-prefix "")
+ (overlay-put ov 'wrap-prefix ""))
(if (or (not (char-after beg))
(equal (char-after beg) ?\n))
(let ((inhibit-read-only t))
(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)))
+ (overlay-put ov 'invisible t)
+ (overlay-put ov 'keymap org-columns-map)
+ (overlay-put ov 'intangible t)
+ (overlay-put ov 'line-prefix "")
+ (overlay-put ov 'wrap-prefix "")
+ (push ov org-columns-overlays)
+ (setq ov (make-overlay (1- (point-at-eol)) (1+ (point-at-eol))))
+ (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
+ (cond
((<= (length string) width) string)
((<= width (length org-columns-ellipses))
(substring org-columns-ellipses 0 width))
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-add-hook 'post-command-hook 'org-columns-hscoll-title nil 'local)))
(defun org-columns-hscoll-title ()
- "Set the header-line-format so that it scrolls along with the table."
+ "Set the `header-line-format' so that it scrolls along with the table."
(sit-for .0001) ; need to force a redisplay to update window-hscroll
(when (not (= (window-hscroll) org-columns-previous-hscroll))
(setq header-line-format
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)
(move-marker org-columns-begin-marker nil)
(move-marker org-columns-top-level-marker nil)
(org-unmodified
- (mapc 'org-delete-overlay org-columns-overlays)
+ (mapc 'delete-overlay org-columns-overlays)
(setq org-columns-overlays nil)
(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."
s)
(defvar org-agenda-columns-remove-prefix-from-item)
+
(defun org-agenda-columns-cleanup-item (item pl cphr fmt)
- "Cleanup the tiem property for agenda column view.
+ "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))
(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-select-environment))))
(t
(setq allowed (org-property-get-allowed-values pom key 'table))
(if allowed
- (setq nval (org-ido-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))
(progn
(setq org-columns-overlays
(org-delete-all line-overlays org-columns-overlays))
- (mapc 'org-delete-overlay line-overlays)
+ (mapc 'delete-overlay line-overlays)
(org-columns-eval eval))
(org-columns-display-here)))
(org-move-to-column col)
(txt (match-string 3))
(post "")
txt2)
- (if (string-match (org-re "[ \t]+:[[:alnum:]:_@]+:[ \t]*$") txt)
+ (if (string-match (org-re "[ \t]+:[[:alnum:]:_@#%]+:[ \t]*$") txt)
(setq post (match-string 0 txt)
txt (substring txt 0 (match-beginning 0))))
(setq txt2 (read-string "Edit: " txt))
(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"))
(progn
(setq org-columns-overlays
(org-delete-all line-overlays org-columns-overlays))
- (mapc 'org-delete-overlay line-overlays)
+ (mapc 'delete-overlay line-overlays)
(org-columns-eval '(org-entry-put pom key nval)))
(org-columns-display-here)))
(org-move-to-column col)
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 (string-match (concat "^" org-ts-regexp3 "$") s)
+ (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))
(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)))
+ ("est+" estimate org-estimate-combine))
+ "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 (org-ido-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 (org-ido-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
(let (fmt val pos)
(save-excursion
(mapc (lambda (ov)
- (when (equal (org-overlay-get ov 'org-columns-key) property)
- (setq pos (org-overlay-start ov))
+ (when (equal (overlay-get ov 'org-columns-key) property)
+ (setq pos (overlay-start ov))
(goto-char pos)
(when (setq val (cdr (assoc property
(get-text-property
(point-at-bol) 'org-summaries))))
- (setq fmt (org-overlay-get ov 'org-columns-format))
- (org-overlay-put ov 'org-columns-value val)
- (org-overlay-put ov 'display (format fmt val)))))
+ (setq fmt (overlay-get ov 'org-columns-format))
+ (overlay-put ov 'org-columns-value val)
+ (overlay-put ov 'display (format fmt val)))))
org-columns-overlays))))
(defun org-columns-compute (property)
(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 ()
(call-interactively 'org-columns)
(org-agenda-redo)
(call-interactively 'org-agenda-columns)))
- (goto-line line)
+ (org-goto-line line)
(move-to-column col))
(message "Recomputing columns...done"))
(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)
+ ((memq fmt '(estimate)) (org-estimate-print n printf))
+ ((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 org-time-clocksum-format h m)))
((eq fmt 'checkbox)
(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))
+ ((memq fmt '(estimate)) (org-string-to-estimate s))
+ (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 (re-search-forward "^\\(\\*+\\) " nil t)
- (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))
- (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))))
+ (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 recalc line)
- (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)))
(while (setq line (pop content-lines))
(when (string-match "^#" line)
(insert "\n" line)
- (when (string-match "^#\\+TBLFM" line)
+ (when (string-match "^[ \t]*#\\+TBLFM" line)
(setq recalc t))))
(if recalc
(progn (goto-char pos) (org-table-recalculate 'all))
(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 (org-ido-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 'dateline)
(equal (nth 4 a) (nth 4 fm)))
(org-columns-compute (car fm)))))))))))
+(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))
+ ""))
+
+(defun org-estimate-mean-and-var (v)
+ "Return the mean and variance of an estimate."
+ (let* ((low (float (car v)))
+ (high (float (cadr v)))
+ (mean (/ (+ low high) 2.0))
+ (var (/ (+ (expt (- mean low) 2.0) (expt (- high mean) 2.0)) 2.0)))
+ (list mean var)))
+
+(defun org-estimate-combine (&rest el)
+ "Combine a list of estimates, using mean and variance.
+The mean and variance of the result will be the sum of the means
+and variances (respectively) of the individual estimates."
+ (let ((mean 0)
+ (var 0))
+ (mapc (lambda (e)
+ (let ((stats (org-estimate-mean-and-var e)))
+ (setq mean (+ mean (car stats)))
+ (setq var (+ var (cadr stats)))))
+ el)
+ (let ((stdev (sqrt var)))
+ (list (- mean stdev) (+ mean stdev)))))
+
+(defun org-estimate-print (e &optional fmt)
+ "Prepare a string representation of an estimate.
+This formats these numbers as two numbers with a \"-\" between them."
+ (if (null fmt) (set 'fmt "%.0f"))
+ (format "%s" (mapconcat (lambda (n) (format fmt n)) e "-")))
+
+(defun org-string-to-estimate (s)
+ "Convert a string to an estimate.
+The string should be two numbers joined with a \"-\"."
+ (if (string-match "\\(.*\\)-\\(.*\\)" s)
+ (list (string-to-number (match-string 1 s))
+ (string-to-number(match-string 2 s)))
+ (list (string-to-number s) (string-to-number s))))
+
(provide 'org-colview)
;; arch-tag: 61f5128d-747c-4983-9479-e3871fa3d73c
HCoop / bpt / emacs.git / blobdiff