org-collector.el 8.3 KB

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