elisp/org-collector.el

   1 ;;; org-collector --- collect properties into tables
   2 ;;
   3 ;; Copyright (C) 2008 Eric Schulte
   4 ;;
   5 ;; Emacs Lisp Archive Entry
   6 ;; Filename: org-collector.el
   7 ;; Version: 0.1
   8 ;; Author: Eric Schulte <schulte.eric AT gmail DOT com>
   9 ;; Keywords: org, properties, collection, tables
  10 ;; Description: collect properties into tables
  11 ;;
  12 ;; This program is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 3, or (at your option)
  15 ;; any later version.
  16 ;;
  17 ;; This program is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21 ;;
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with this program; if not, write to the Free Software
  24 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  25 ;;
  26 ;;; Comments:
  27 ;;
  28 ;; Pass in an alist of columns, each column can be either a single
  29 ;; property or a function which takes properties as arguments.  A
  30 ;; table will be populated by passing proerty values to each of the
  31 ;; column specifiers.  There will be one row in the table for each
  32 ;; headline which satisfies your colum specifiers.  An example dblock
  33 ;; specification with results may look like this.
  34 ;;
  35 ;; #+BEGIN: propview :id "data" :cols (ITEM f d list (apply '* list) (+ f d))
  36 ;; | "ITEM" | "f" | "d" | "list"                  | "(apply (quote *) list)" | "(+ f d)" |
  37 ;; |--------+-----+-----+-------------------------+--------------------------+-----------|
  38 ;; | "run1" |   2 |  33 | (quote (9 2 3 4 5 6 7)) | 45360                    |        35 |
  39 ;; | "run2" |   4 |  34 | :na                     | :na                      |        38 |
  40 ;; | "run3" |   4 |  35 | :na                     | :na                      |        39 |
  41 ;; | "run4" |   2 |  36 | :na                     | :na                      |        38 |
  42 ;; |        |     |     |                         |                          |           |
  43 ;; #+END:
  44 ;;
  45 ;;; History:
  46 ;;
  47 ;; Simplified org-propview-to-table and made unquoted headers (removed
  48 ;; extra format %S call). /mfo 2008-12-16
  49 ;;
  50 ;; Added a :no-inherit feature to gain speed together with some
  51 ;; documentation. /mfo 2008-11-25
  52 ;;
  53 ;;; Code:
  54 (require 'org)
  55 (require 'org-table)
  56
  57 (defun and-rest (list)
  58   (if (listp list)
  59       (if (> (length list) 1)
  60           (and (car list) (and-rest (cdr list)))
  61         (car list))
  62     list))
  63
  64 (put 'org-collector-error
  65      'error-conditions
  66      '(error column-prop-error org-collector-error))
  67
  68 (defun org-read-prop (prop)
  69   "Convert the string property PROP to a number if appropriate.
  70 Otherwise if prop looks like a list (meaning it starts with a
  71 '(') then read it as lisp, otherwise return it unmodified as a
  72 string."
  73   (if (and (stringp prop) (not (equal prop "")))
  74       (let ((out (string-to-number prop)))
  75         (if (equal out 0)
  76             (if (or (equal "(" (substring prop 0 1)) (equal "'" (substring prop 0 1)))
  77                 (read prop)
  78               (if (string-match "^\\(+0\\|-0\\|0\\)$" prop)
  79                   0
  80                 (progn (set-text-properties 0 (length prop) nil prop)
  81                        prop)))
  82           out))
  83     prop))
  84
  85 (defun org-dblock-write:propview (params)
  86   "Generates org-collector propview table.
  87
  88 It collects the column specifications from the :cols parameter
  89 preceeding the dblock, then update the contents of the dblock
  90 with data from headings selected by the :id parameter. It can be:
  91
  92  * global      - data from whole document is processed
  93  * local       - only current subtree
  94  * <org-id>    - only headings with this property :ID:.
  95
  96 If no inheritance is wanted set paramter :no-inherit, to gain
  97 speed."
  98   (interactive)
  99   (condition-case er
 100       (let* ((cols (plist-get params :cols))
 101              (id (plist-get params :id))
 102              (inherit (not (plist-get params :no-inherit)))
 103              (org-use-tag-inheritance inherit)
 104              (org-use-property-inheritance inherit)
 105              table idpos)
 106         (save-excursion
 107           (cond ((not id) nil)
 108                 ((eq id 'global)
 109                  (goto-char (point-min))
 110                  (outline-next-heading))
 111                 ((eq id 'local)  nil)
 112                 ((setq idpos (org-find-entry-with-id id))
 113                  (goto-char idpos))
 114                 (t (error "Cannot find entry with :ID: %s" id)))
 115           (org-narrow-to-subtree)
 116           (setq table (org-propview-to-table (org-propview-collect cols)))
 117           (widen))
 118         (insert table)
 119         (org-cycle))
 120     (org-collector-error (widen) (error "%s" er))
 121     (error (widen) (error "%s" er))))
 122
 123 (defun org-propview-collect (cols)
 124   (interactive)
 125   ;; collect the properties from every header
 126   (let* ((header-props (org-map-entries (quote (cons (cons "ITEM" (org-get-heading))
 127                                                      (org-entry-properties)))))
 128          ;; collect all property names
 129          (prop-names (mapcar 'intern (delete-dups
 130                                       (apply 'append (mapcar (lambda (header)
 131                                                                (mapcar 'car header))
 132                                                              header-props))))))
 133     ;; (message (format "header-props=%S" header-props))
 134     ;; (message (format "prop-names=%S" prop-names))
 135     (append
 136      (list
 137       ;; create an output list of the headers for each output col
 138       cols
 139       'hline)
 140      (mapcar ;; for each header's entries
 141       (lambda (props)
 142         (mapcar ;;   for each col
 143          (lambda (col)
 144            (or
 145             ;; if col is a symbol and it's present return it's value
 146             (and (symbolp col)
 147                  (let ((val (cdr (assoc (symbol-name col) props))))
 148                    (if val (org-read-prop val))))
 149             ;; if col is a list, and everything in it's cdr is present,
 150             ;; then evaluate it as a function
 151             (and (listp col)
 152                  (let ((vals (mapcar (lambda (el) (if (memq el prop-names)
 153                                                       (org-read-prop (cdr (assoc (symbol-name el) props)))
 154                                                       el))
 155                                      (cdr col))))
 156                    ;; (message (format "vals-%S" vals))
 157                    (condition-case col-er
 158                        (and (and-rest vals) (org-read-prop (eval (cons (car col) vals))))
 159                      (error (signal 'org-collector-error
 160                                     (list (format "%S while processing: %S" col-er col)))))))
 161             :na)) ;; else return an appropriate default
 162          cols))
 163       header-props))))
 164
 165 (defun org-propview-to-table (results)
 166   (orgtbl-to-orgtbl results '(:fmt "%S" :remove-nil-lines)))
 167
 168 (provide 'org-collector)
 169 ;;; org-collector ends here