summaryrefslogtreecommitdiff
path: root/contrib/lisp/org-collector.el
diff options
context:
space:
mode:
Diffstat (limited to 'contrib/lisp/org-collector.el')
-rw-r--r--contrib/lisp/org-collector.el229
1 files changed, 229 insertions, 0 deletions
diff --git a/contrib/lisp/org-collector.el b/contrib/lisp/org-collector.el
new file mode 100644
index 0000000..089e8ad
--- /dev/null
+++ b/contrib/lisp/org-collector.el
@@ -0,0 +1,229 @@
+;;; org-collector --- collect properties into tables
+
+;; Copyright (C) 2008-2012 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte <schulte dot eric at gmail dot com>
+;; Keywords: outlines, hypermedia, calendar, wp, experimentation,
+;; organization, properties
+;; Homepage: http://orgmode.org
+;; Version: 0.01
+
+;; This file is not yet part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Pass in an alist of columns, each column can be either a single
+;; property or a function which takes column names as arguments.
+;;
+;; For example the following propview block would collect the value of
+;; the 'amount' property from each header in the current buffer
+;;
+;; #+BEGIN: propview :cols (ITEM amount)
+;; | "ITEM" | "amount" |
+;; |---------------------+----------|
+;; | "December Spending" | 0 |
+;; | "Grocery Store" | 56.77 |
+;; | "Athletic club" | 75.0 |
+;; | "Restaurant" | 30.67 |
+;; | "January Spending" | 0 |
+;; | "Athletic club" | 75.0 |
+;; | "Restaurant" | 50.00 |
+;; |---------------------+----------|
+;; | | |
+;; #+END:
+;;
+;; This slightly more selective propview block will limit those
+;; headers included to those in the subtree with the id 'december'
+;; in which the spendtype property is equal to "food"
+;;
+;; #+BEGIN: propview :id "december" :conds ((string= spendtype "food")) :cols (ITEM amount)
+;; | "ITEM" | "amount" |
+;; |-----------------+----------|
+;; | "Grocery Store" | 56.77 |
+;; | "Restaurant" | 30.67 |
+;; |-----------------+----------|
+;; | | |
+;; #+END:
+;;
+;; Org Collector allows arbitrary processing of the property values
+;; through elisp in the cols: property. This allows for both simple
+;; computations as in the following example
+;;
+;; #+BEGIN: propview :id "results" :cols (ITEM f d list (apply '+ list) (+ f d))
+;; | "ITEM" | "f" | "d" | "list" | "(apply (quote +) list)" | "(+ f d)" |
+;; |--------+-----+-----+-------------------------+--------------------------+-----------|
+;; | "run1" | 2 | 33 | (quote (9 2 3 4 5 6 7)) | 36 | 35 |
+;; | "run2" | 2 | 34 | :na | :na | 36 |
+;; | "run3" | 2 | 35 | :na | :na | 37 |
+;; | "run4" | 2 | 36 | :na | :na | 38 |
+;; | | | | | | |
+;; #+END:
+;;
+;; or more complex computations as in the following example taken from
+;; an org file where each header in "results" subtree contained a
+;; property "sorted_hits" which was passed through the
+;; "average-precision" elisp function
+;;
+;; #+BEGIN: propview :id "results" :cols (ITEM (average-precision sorted_hits))
+;; | "ITEM" | "(average-precision sorted_hits)" |
+;; |-----------+-----------------------------------|
+;; | run (80) | 0.105092 |
+;; | run (70) | 0.108142 |
+;; | run (10) | 0.111348 |
+;; | run (60) | 0.113593 |
+;; | run (50) | 0.116446 |
+;; | run (100) | 0.118863 |
+;; #+END:
+;;
+
+;;; Code:
+(require 'org)
+(require 'org-table)
+
+(defvar org-propview-default-value 0
+ "Default value to insert into the propview table when the no
+value is calculated either through lack of required variables for
+a column, or through the generation of an error.")
+
+(defun and-rest (list)
+ (if (listp list)
+ (if (> (length list) 1)
+ (and (car list) (and-rest (cdr list)))
+ (car list))
+ list))
+
+(put 'org-collector-error
+ 'error-conditions
+ '(error column-prop-error org-collector-error))
+
+(defun org-dblock-write:propview (params)
+ "collect the column specification from the #+cols line
+preceeding the dblock, then update the contents of the dblock."
+ (interactive)
+ (condition-case er
+ (let ((cols (plist-get params :cols))
+ (inherit (plist-get params :inherit))
+ (conds (plist-get params :conds))
+ (match (plist-get params :match))
+ (scope (plist-get params :scope))
+ (noquote (plist-get params :noquote))
+ (colnames (plist-get params :colnames))
+ (content-lines (org-split-string (plist-get params :content) "\n"))
+ id table line pos)
+ (save-excursion
+ (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))))
+ (unless (eq id 'global) (org-narrow-to-subtree))
+ (setq stringformat (if noquote "%s" "%S"))
+ (setq table (org-propview-to-table
+ (org-propview-collect cols stringformat conds match scope inherit
+ (if colnames colnames cols)) stringformat))
+ (widen))
+ (setq pos (point))
+ (when content-lines
+ (while (string-match "^#" (car content-lines))
+ (insert (pop content-lines) "\n")))
+ (insert table) (insert "\n|--") (org-cycle) (move-end-of-line 1)
+ (message (format "point-%d" pos))
+ (while (setq line (pop content-lines))
+ (when (string-match "^#" line)
+ (insert "\n" line)))
+ (goto-char pos)
+ (org-table-recalculate 'all))
+ (org-collector-error (widen) (error "%s" er))
+ (error (widen) (error "%s" er))))
+
+(defun org-propview-eval-w-props (props body)
+ "evaluate the BODY-FORMS binding the variables using the
+variables and values specified in props"
+ (condition-case nil ;; catch any errors
+ (eval `(let ,(mapcar
+ (lambda (pair) (list (intern (car pair)) (cdr pair)))
+ props)
+ ,body))
+ (error nil)))
+
+(defun org-propview-get-with-inherited (&optional inherit)
+ (append
+ (org-entry-properties)
+ (delq nil
+ (mapcar (lambda (i)
+ (let* ((n (symbol-name i))
+ (p (org-entry-get (point) n 'do-inherit)))
+ (when p (cons n p))))
+ inherit))))
+
+(defun org-propview-collect (cols stringformat &optional conds match scope inherit colnames)
+ (interactive)
+ ;; collect the properties from every header
+ (let* ((header-props
+ (let ((org-trust-scanner-tags t) alst)
+ (org-map-entries
+ (quote (cons (cons "ITEM" (org-get-heading t))
+ (org-propview-get-with-inherited inherit)))
+ match scope)))
+ ;; read property values
+ (header-props
+ (mapcar (lambda (props)
+ (mapcar (lambda (pair)
+ (cons (car pair) (org-babel-read (cdr pair))))
+ props))
+ header-props))
+ ;; collect all property names
+ (prop-names
+ (mapcar 'intern (delete-dups
+ (apply 'append (mapcar (lambda (header)
+ (mapcar 'car header))
+ header-props))))))
+ (append
+ (list
+ (if colnames colnames (mapcar (lambda (el) (format stringformat el)) cols))
+ 'hline) ;; ------------------------------------------------
+ (mapcar ;; calculate the value of the column for each header
+ (lambda (props) (mapcar (lambda (col)
+ (let ((result (org-propview-eval-w-props props col)))
+ (if result result org-propview-default-value)))
+ cols))
+ (if conds
+ ;; eliminate the headers which don't satisfy the property
+ (delq nil
+ (mapcar
+ (lambda (props)
+ (if (and-rest (mapcar
+ (lambda (col)
+ (org-propview-eval-w-props props col))
+ conds))
+ props))
+ header-props))
+ header-props)))))
+
+(defun org-propview-to-table (results stringformat)
+ ;; (message (format "cols:%S" cols))
+ (orgtbl-to-orgtbl
+ (mapcar
+ (lambda (row)
+ (if (equal row 'hline)
+ 'hline
+ (mapcar (lambda (el) (format stringformat el)) row)))
+ (delq nil results)) '()))
+
+(provide 'org-collector)
+;;; org-collector ends here