contrib/lisp/org-collector.el

   1 ;;; org-collector --- collect properties into tables
   2
   3 ;; Copyright (C) 2008 Free Software Foundation, Inc.
   4
   5 ;; Author: Eric Schulte <schulte dot eric at gmail dot com>
   6 ;; Keywords: outlines, hypermedia, calendar, wp, experimentation,
   7 ;;           organization, properties
   8 ;; Homepage: http://orgmode.org
   9 ;; Version: 0.01
  10
  11 ;; This file is not yet part of GNU Emacs.
  12
  13 ;; GNU Emacs is free software; you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation; either version 3, or (at your option)
  16 ;; any later version.
  17
  18 ;; GNU Emacs is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  25
  26 ;;; Commentary:
  27
  28 ;; Pass in an alist of columns, each column can be either a single
  29 ;; property or a function which takes column names as arguments.
  30 ;;
  31 ;; For example the following propview block would collect the value of
  32 ;; the 'amount' property from each header in the current buffer
  33 ;;
  34 ;; #+BEGIN: propview :cols (ITEM amount)
  35 ;; | "ITEM"              | "amount" |
  36 ;; |---------------------+----------|
  37 ;; | "December Spending" |        0 |
  38 ;; | "Grocery Store"     |    56.77 |
  39 ;; | "Athletic club"     |     75.0 |
  40 ;; | "Restaurant"        |    30.67 |
  41 ;; | "January Spending"  |        0 |
  42 ;; | "Athletic club"     |     75.0 |
  43 ;; | "Restaurant"        |    50.00 |
  44 ;; |---------------------+----------|
  45 ;; |                     |          |
  46 ;; #+END:
  47 ;;
  48 ;; This slightly more selective propview block will limit those
  49 ;; headers included to those in the subtree with the id 'december'
  50 ;; in which the spendtype property is equal to "food"
  51 ;;
  52 ;; #+BEGIN: propview :id "december" :conds ((string= spendtype "food")) :cols (ITEM amount)
  53 ;; | "ITEM"          | "amount" |
  54 ;; |-----------------+----------|
  55 ;; | "Grocery Store" |    56.77 |
  56 ;; | "Restaurant"    |    30.67 |
  57 ;; |-----------------+----------|
  58 ;; |                 |          |
  59 ;; #+END:
  60 ;;
  61 ;; Org Collector allows arbitrary processing of the property values
  62 ;; through elisp in the cols: property.  This allows for both simple
  63 ;; computations as in the following example
  64 ;;
  65 ;; #+BEGIN: propview :id "results" :cols (ITEM f d list (apply '+ list) (+ f d))
  66 ;; | "ITEM" | "f" | "d" | "list"                  | "(apply (quote +) list)" | "(+ f d)" |
  67 ;; |--------+-----+-----+-------------------------+--------------------------+-----------|
  68 ;; | "run1" |   2 |  33 | (quote (9 2 3 4 5 6 7)) | 36                       |        35 |
  69 ;; | "run2" |   2 |  34 | :na                     | :na                      |        36 |
  70 ;; | "run3" |   2 |  35 | :na                     | :na                      |        37 |
  71 ;; | "run4" |   2 |  36 | :na                     | :na                      |        38 |
  72 ;; |        |     |     |                         |                          |           |
  73 ;; #+END:
  74 ;;
  75 ;; or more complex computations as in the following example taken from
  76 ;; an org file where each header in "results" subtree contained a
  77 ;; property "sorted_hits" which was passed through the
  78 ;; "average-precision" elisp function
  79 ;;
  80 ;; #+BEGIN: propview :id "results" :cols (ITEM (average-precision sorted_hits))
  81 ;; | "ITEM"    | "(average-precision sorted_hits)" |
  82 ;; |-----------+-----------------------------------|
  83 ;; | run (80)  |                          0.105092 |
  84 ;; | run (70)  |                          0.108142 |
  85 ;; | run (10)  |                          0.111348 |
  86 ;; | run (60)  |                          0.113593 |
  87 ;; | run (50)  |                          0.116446 |
  88 ;; | run (100) |                          0.118863 |
  89 ;; #+END:
  90 ;;
  91
  92 ;;; Code:
  93 (require 'org)
  94 (require 'org-table)
  95
  96 (defvar org-propview-default-value 0
  97   "Default value to insert into the propview table when the no
  98 value is calculated either through lack of required variables for
  99 a column, or through the generation of an error.")
 100
 101 (defun and-rest (list)
 102   (if (listp list)
 103       (if (> (length list) 1)
 104           (and (car list) (and-rest (cdr list)))
 105         (car list))
 106     list))
 107
 108 (put 'org-collector-error
 109      'error-conditions
 110      '(error column-prop-error org-collector-error))
 111
 112 (defun org-read-prop (prop)
 113   "Convert the string property PROP to a number if appropriate.
 114 If prop looks like a list (meaning it starts with a '(') then
 115 read it as lisp expression, otherwise return it unmodified as a
 116 string.
 117
 118 Results of calling:
 119 \(org-read-prop \"12\") -> 12
 120 \(org-read-prop \"(1 2 3)\") -> (1 2 3)
 121 \(org-read-prop \"+0\") -> 0
 122 \(org-read-prop \"aaa\") -> \"aaa\""
 123   (if (and (stringp prop) (not (equal prop "")))
 124       (let ((out (string-to-number prop)))
 125         (if (equal out 0)
 126             (cond
 127              ((or
 128                (equal "(" (substring prop 0 1))
 129                (equal "'" (substring prop 0 1)))
 130
 131               (condition-case nil
 132                   (read prop)
 133                 (error prop)))
 134              ((string-match "^\\(+0\\|-0\\|0\\)$" prop)
 135               0)
 136              (t
 137               (set-text-properties 0 (length prop) nil prop)
 138               prop))
 139           out))
 140     prop))
 141
 142 (defun org-dblock-write:propview (params)
 143   "collect the column specification from the #+cols line
 144 preceeding the dblock, then update the contents of the dblock."
 145   (interactive)
 146   (condition-case er
 147       (let ((cols (plist-get params :cols))
 148             (conds (plist-get params :conds))
 149             (match (plist-get params :match))
 150             (scope (plist-get params :scope))
 151             (content-lines (org-split-string (plist-get params :content) "\n"))
 152             id table line pos)
 153         (save-excursion
 154           (when (setq id (plist-get params :id))
 155             (cond ((not id) nil)
 156                   ((eq id 'global) (goto-char (point-min)))
 157                   ((eq id 'local)  nil)
 158                   ((setq idpos (org-find-entry-with-id id))
 159                    (goto-char idpos))
 160                   (t (error "Cannot find entry with :ID: %s" id))))
 161           (org-narrow-to-subtree)
 162           (setq table (org-propview-to-table (org-propview-collect cols conds match scope)))
 163           (widen))
 164         (setq pos (point))
 165         (when content-lines
 166           (while (string-match "^#" (car content-lines))
 167             (insert (pop content-lines) "\n")))
 168         (insert table) (insert "\n|--") (org-cycle) (move-end-of-line 1)
 169         (message (format "point-%d" pos))
 170         (while (setq line (pop content-lines))
 171           (when (string-match "^#" line)
 172             (insert "\n" line)))
 173         (goto-char pos)
 174         (org-table-recalculate 'all))
 175     (org-collector-error (widen) (error "%s" er))
 176     (error (widen) (error "%s" er))))
 177
 178 (defun org-propview-eval-w-props (props body)
 179   "evaluate the BODY-FORMS binding the variables using the
 180 variables and values specified in props"
 181   (condition-case nil ;; catch any errors
 182       (eval `(let ,(mapcar
 183                     (lambda (pair) (list (intern (car pair)) (cdr pair)))
 184                     props)
 185                ,body))
 186     (error nil)))
 187
 188 (defun org-propview-collect (cols &optional conds match scope)
 189   (interactive)
 190   ;; collect the properties from every header
 191   (let* ((header-props
 192           (let ((org-trust-scanner-tags t))
 193             (org-map-entries (quote (cons (cons "ITEM" (org-get-heading t))
 194                                           (org-entry-properties)))
 195                              match scope)))
 196          ;; read property values
 197          (header-props (mapcar (lambda (props)
 198                                  (mapcar (lambda (pair) (cons (car pair) (org-read-prop (cdr pair))))
 199                                          props))
 200                                header-props))
 201          ;; collect all property names
 202          (prop-names (mapcar 'intern (delete-dups
 203                                       (apply 'append (mapcar (lambda (header)
 204                                                                (mapcar 'car header))
 205                                                              header-props))))))
 206     (append
 207      (list
 208       (mapcar (lambda (el) (format "%S" el)) cols) ;; output headers
 209       'hline) ;; ------------------------------------------------
 210      (mapcar ;; calculate the value of the column for each header
 211       (lambda (props) (mapcar (lambda (col) (let ((result (org-propview-eval-w-props props col)))
 212                                               (if result result org-propview-default-value)))
 213                               cols))
 214       (if conds
 215           ;; eliminate the headers which don't satisfy the property
 216           (delq nil
 217                 (mapcar
 218                  (lambda (props)
 219                    (if (and-rest (mapcar (lambda (col) (org-propview-eval-w-props props col)) conds))
 220                        props))
 221                  header-props))
 222           header-props)))))
 223
 224 (defun org-propview-to-table (results)
 225   ;; (message (format "cols:%S" cols))
 226   (orgtbl-to-orgtbl
 227    (mapcar
 228     (lambda (row)
 229       (if (equal row 'hline)
 230           'hline
 231         (mapcar (lambda (el) (format "%S" el)) row)))
 232     (delq nil results)) '()))
 233
 234 (provide 'org-collector)
 235 ;;; org-collector ends here