lisp/org-table.el: fix table alignment
[org-mode/org-tableheadings.git] / contrib / lisp / org-collector.el
blob833ecbf514e074397fe33255fc88855123109818
1 ;;; org-collector --- collect properties into tables
3 ;; Copyright (C) 2008-2018 Free Software Foundation, Inc.
5 ;; Author: Eric Schulte <schulte dot eric at gmail dot com>
6 ;; Keywords: outlines, hypermedia, calendar, wp, experimentation,
7 ;; organization, properties
8 ;; Homepage: https://orgmode.org
9 ;; Version: 0.01
11 ;; This file is not yet part of GNU Emacs.
13 ;; This program 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.
18 ;; This program 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.
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/>.
26 ;;; Commentary:
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.
31 ;; For example the following propview block would collect the value of
32 ;; the 'amount' property from each header in the current buffer
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:
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"
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:
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
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:
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
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:
92 ;;; Code:
93 (require 'org)
94 (require 'org-table)
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.")
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))
108 (put 'org-collector-error
109 'error-conditions
110 '(error column-prop-error org-collector-error))
112 (defun org-dblock-write:propview (params)
113 "collect the column specification from the #+cols line
114 preceeding the dblock, then update the contents of the dblock."
115 (interactive)
116 (condition-case er
117 (let ((cols (plist-get params :cols))
118 (inherit (plist-get params :inherit))
119 (conds (plist-get params :conds))
120 (match (plist-get params :match))
121 (scope (plist-get params :scope))
122 (noquote (plist-get params :noquote))
123 (colnames (plist-get params :colnames))
124 (defaultval (plist-get params :defaultval))
125 (content-lines (org-split-string (plist-get params :content) "\n"))
126 id table line pos)
127 (save-excursion
128 (when (setq id (plist-get params :id))
129 (cond ((not id) nil)
130 ((eq id 'global) (goto-char (point-min)))
131 ((eq id 'local) nil)
132 ((setq idpos (org-find-entry-with-id id))
133 (goto-char idpos))
134 (t (error "Cannot find entry with :ID: %s" id))))
135 (unless (eq id 'global) (org-narrow-to-subtree))
136 (setq stringformat (if noquote "%s" "%S"))
137 (let ((org-propview-default-value (if defaultval defaultval org-propview-default-value)))
138 (setq table (org-propview-to-table
139 (org-propview-collect cols stringformat conds match scope inherit
140 (if colnames colnames cols)) stringformat)))
141 (widen))
142 (setq pos (point))
143 (when content-lines
144 (while (string-match "^#" (car content-lines))
145 (insert (pop content-lines) "\n")))
146 (insert table) (insert "\n|--") (org-cycle) (move-end-of-line 1)
147 (message (format "point-%d" pos))
148 (while (setq line (pop content-lines))
149 (when (string-match "^#" line)
150 (insert "\n" line)))
151 (goto-char pos)
152 (org-table-recalculate 'all))
153 (org-collector-error (widen) (error "%s" er))
154 (error (widen) (error "%s" er))))
156 (defun org-propview-eval-w-props (props body)
157 "evaluate the BODY-FORMS binding the variables using the
158 variables and values specified in props"
159 (condition-case nil ;; catch any errors
160 (eval `(let ,(mapcar
161 (lambda (pair) (list (intern (car pair)) (cdr pair)))
162 props)
163 ,body))
164 (error nil)))
166 (defun org-propview-get-with-inherited (&optional inherit)
167 (append
168 (org-entry-properties)
169 (delq nil
170 (mapcar (lambda (i)
171 (let* ((n (symbol-name i))
172 (p (org-entry-get (point) n 'do-inherit)))
173 (when p (cons n p))))
174 inherit))))
176 (defun org-propview-collect (cols stringformat &optional conds match scope inherit colnames)
177 (interactive)
178 ;; collect the properties from every header
179 (let* ((header-props
180 (let ((org-trust-scanner-tags t) alst)
181 (org-map-entries
182 (quote (cons (cons "ITEM" (org-get-heading t))
183 (org-propview-get-with-inherited inherit)))
184 match scope)))
185 ;; read property values
186 (header-props
187 (mapcar (lambda (props)
188 (mapcar (lambda (pair)
189 (let ((inhibit-lisp-eval (string= (car pair) "ITEM")))
190 (cons (car pair) (org-babel-read (cdr pair) inhibit-lisp-eval))))
191 props))
192 header-props))
193 ;; collect all property names
194 (prop-names
195 (mapcar 'intern (delete-dups
196 (apply 'append (mapcar (lambda (header)
197 (mapcar 'car header))
198 header-props))))))
199 (append
200 (list
201 (if colnames colnames (mapcar (lambda (el) (format stringformat el)) cols))
202 'hline) ;; ------------------------------------------------
203 (mapcar ;; calculate the value of the column for each header
204 (lambda (props) (mapcar (lambda (col)
205 (let ((result (org-propview-eval-w-props props col)))
206 (if result result org-propview-default-value)))
207 cols))
208 (if conds
209 ;; eliminate the headers which don't satisfy the property
210 (delq nil
211 (mapcar
212 (lambda (props)
213 (if (and-rest (mapcar
214 (lambda (col)
215 (org-propview-eval-w-props props col))
216 conds))
217 props))
218 header-props))
219 header-props)))))
221 (defun org-propview-to-table (results stringformat)
222 ;; (message (format "cols:%S" cols))
223 (orgtbl-to-orgtbl
224 (mapcar
225 (lambda (row)
226 (if (equal row 'hline)
227 'hline
228 (mapcar (lambda (el) (format stringformat el)) row)))
229 (delq nil results)) '()))
231 (provide 'org-collector)
232 ;;; org-collector ends here