Merge branch 'master' of git@github.com:eschulte/rorg

litorgy/init.el

@@ -0,0 +1,41 @@
+;;; init.el --- loads litorgy
+
+;; Copyright (C) 2009 Eric Schulte, Dan Davison, Austin F. Frank
+
+;; Author: Eric Schulte, Dan Davison, Austin F. Frank
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 0.01
+
+;;; License:
+
+;; This program 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.
+;;
+;; This program 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; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; Commentary:
+
+;; for more information see the comments in litorgy.el
+
+;;; Code:
+(require 'org)
+(require 'litorgy)
+(require 'litorgy-reference)
+
+;; language specific files
+(require 'litorgy-R)
+(require 'litorgy-lisp)
+(require 'litorgy-script)
+
+;;; init.el ends here

litorgy/litorgy-R.el

@@ -0,0 +1,46 @@
+;;; litorgy-R.el --- litorgy functions for R code evaluation
+
+;; Copyright (C) 2009 Eric Schulte, Dan Davison, Austin F. Frank
+
+;; Author: Eric Schulte, Dan Davison, Austin F. Frank
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 0.01
+
+;;; License:
+
+;; This program 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.
+;;
+;; This program 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; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; Commentary:
+
+;; Litorgy support for evaluating R code
+
+;;; Code:
+(require 'litorgy)
+
+(litorgy-add-interpreter "emacs-R")
+
+(defun litorgy-execute:emacs-R (body params)
+  "Execute a block of emacs-R code with litorgy.  This
+function is called by `litorgy-execute-src-block'."
+  (save-window-excursion
+    (let ((vars (litorgy-reference-variables params))
+          results)
+      ;;TODO: implement
+      (error "`litorgy-execute:emacs-R' is not implemented"))))
+
+(provide 'litorgy-R)
+;;; litorgy-R.el ends here

litorgy/litorgy-lisp.el

@@ -40,7 +40,10 @@ function is called by `litorgy-execute-src-block'."
     (let ((vars (litorgy-reference-variables params))
           (print-level nil) (print-length nil) results)
       (message "executing emacs-lisp code block...")
-      (format "%S" (eval (read body))))))
+      (setq results
+            (eval `(let ,(mapcar (lambda (var) `(,(car var) ',(cdr var))) vars)
+                     ,(read body))))
+      (if (listp results) results (format "%S" results)))))
 
 (provide 'litorgy-lisp)
 ;;; litorgy-lisp.el ends here

litorgy/litorgy-reference.el

@@ -53,11 +53,31 @@
 ;;; Code:
 (require 'litorgy)
 
+(defun litorgy-read-cell (cell)
+  "Convert the string value of CELL to a number if appropriate.
+Otherwise if cell looks like a list (meaning it starts with a
+'(') then read it as lisp, otherwise return it unmodified as a
+string.
+
+This is taken almost directly from `org-read-prop'."
+  (if (and (stringp cell) (not (equal cell "")))
+      (let ((out (string-to-number cell)))
+	(if (equal out 0)
+	    (if (or (equal "(" (substring cell 0 1))
+                    (equal "'" (substring cell 0 1)))
+                (read cell)
+	      (if (string-match "^\\(+0\\|-0\\|0\\)$" cell)
+		  0
+		(progn (set-text-properties 0 (length cell) nil cell)
+		       cell)))
+	  out))
+    cell))
+
 (defun litorgy-reference-variables (params)
   "Takes a parameter alist, and return an alist of variable
 names, and the string representation of the related value."
   (mapcar #'litorgy-reference-parse
-   (delq nil (mapcar (lambda (pair) (if (= (car pair) :var) (cdr pair))) params))))
+   (delq nil (mapcar (lambda (pair) (if (eq (car pair) :var) (cdr pair))) params))))
 
 (defun litorgy-reference-parse (reference)
   "Parse a reference to an external resource returning a list
@@ -65,19 +85,34 @@ with two elements.  The first element of the list will be the
 name of the variable, and the second will be an emacs-lisp
 representation of the value of the variable."
   (save-excursion
-    (if (string-match "(.+)=(.+)" reference)
-      (let ((var (match-string 1 reference))
-            (ref (match-string 2 reference)))
-        (when (string-match "(.+):(.+)" reference)
-          (find-file (match-string 1 reference))
-          (setf ref (match-string 2 reference)))
-        ;; follow the reference in the current file
-        (case ref
-          ("previous"
-           )
-          ("next")
-          (t ))
-        ))))
+    (if (string-match "\\(.+\\)=\\(.+\\)" reference)
+        (let ((var (match-string 1 reference))
+              (ref (match-string 2 reference))
+              direction)
+          (when (string-match "\\(.+\\):\\(.+\\)" reference)
+            (find-file (match-string 1 reference))
+            (setf ref (match-string 2 reference)))
+          (cons (intern var)
+                (progn
+                  (cond ;; follow the reference in the current file
+                   ((string= ref "previous") (setq direction -1))
+                   ((string= ref "next") (setq direction 1))
+                   (t
+                    (goto-char (point-min))
+                    (setq direction 1)
+                    (unless (re-search-forward
+                             (concat "^#\\+TBLNAME:[ \t]*" (regexp-quote ref) "[ \t]*$") nil t)
+                      (setq id-loc (org-id-find name-or-id 'marker)
+                            buffer (marker-buffer id-loc)
+                            loc (marker-position id-loc))
+                      (move-marker id-loc nil))))
+                  (while (not (org-at-table-p))
+                    (forward-line direction)
+                    (if (or (= (point) (point-min)) (= (point) (point-max)))
+                        (error "no table found")))
+                  (mapcar (lambda (row)
+                            (mapcar #'litorgy-read-cell row))
+                          (org-table-to-lisp))))))))
 
 (provide 'litorgy-reference)
 ;;; litorgy-reference.el ends here

litorgy/litorgy.el

@@ -105,7 +105,9 @@ prefix don't dump results into buffer."
     (unless (member lang litorgy-interpreters)
       (error "Language is not in `litorgy-interpreters': %s" lang))
     (setq result (funcall cmd body params))
-    (unless arg (litorgy-insert-result result (assoc :replace params)))))
+    (if arg
+        (message (format "%S" result))
+      (litorgy-insert-result result (assoc :replace params)))))
 
 (defun litorgy-eval-buffer (&optional arg)
   "Replace EVAL snippets in the entire buffer."
@@ -141,42 +143,61 @@ form.  (language body header-arguments-alist)"
   (delq nil
         (mapcar
          (lambda (arg) (if (string-match "\\([^ \f\t\n\r\v]+\\)[ \f\t\n\r\v]*\\([^ \f\t\n\r\v]*\\)" arg)
-                      (cons (intern (concat ":" (match-string 1 arg))) (match-string 2 arg))))
+                           (cons (intern (concat ":" (match-string 1 arg))) (match-string 2 arg))))
          (split-string (concat " " arg-string) "[ \f\t\n\r\v]+:"))))
 
 (defun litorgy-insert-result (result &optional replace)
   "Insert RESULT into the current buffer after the end of the
 current source block.  With optional argument REPLACE replace any
 existing results currently located after the source block."
-  (if replace (litorgy-remove-result))
-  (unless (or (string-equal (substring result -1)
-                            "\n")
-              (string-equal (substring result -1)
-                            "\r"))
+  (if replace (litorgy-remove-result (listp result)))
+  (when (and (stringp result)
+             (not (or (string-equal (substring result -1) "\n")
+                      (string-equal (substring result -1) "\r"))))
     (setq result (concat result "\n")))
   (save-excursion
     (re-search-forward "^#\\+end_src" nil t) (open-line 1) (forward-char 2)
-    (let ((beg (point))
-          (end (progn (insert result)
-                      (point))))
-      (save-excursion
-        (set-mark beg)
-        (goto-char end)
-        (org-toggle-fixed-width-section nil)))))
-
-(defun litorgy-remove-result ()
-  "Remove the result following the current source block"
+    (if (stringp result)
+        (litorgy-examplize-region (point) (progn (insert result) (point)))
+      (progn
+        (insert ;; for now lets assume the result is a table if it's not a string
+         (concat (orgtbl-to-orgtbl
+                  (if (consp (car result)) result (list result))
+                  '(:fmt (lambda (cell) (format "%S" cell)))) "\n"))
+        (forward-line -1)
+        (org-cycle)))))
+
+(defun litorgy-remove-result (&optional table)
+  "Remove the result following the current source block.  If
+optional argument TABLE is supplied then remove the table
+following the block rather than the fixed width example."
   (save-excursion
     (re-search-forward "^#\\+end_src" nil t)
     (forward-char 1)
     (delete-region (point)
                    (save-excursion (forward-line 1)
-                                   (while (if (looking-at ": ")
-                                              (progn (while (looking-at ": ")
-                                                       (forward-line 1)) t))
-                                     (forward-line 1))
-                                   (forward-line -1)
-                                   (point)))))
+                                   (if table
+                                       (org-table-end)
+                                     (while (if (looking-at ": ")
+                                                (progn (while (looking-at ": ")
+                                                         (forward-line 1)) t))
+                                       (forward-line 1))
+                                     (forward-line -1)
+                                     (point))))))
+
+(defun litorgy-examplize-region (beg end)
+  "Comment out region using the ': ' org example quote."
+  (interactive "*r")
+  (let ((size (abs (- (line-number-at-pos end)
+		      (line-number-at-pos beg)))))
+    (if (= size 0)
+	(let ((result (buffer-substring beg end)))
+	  (delete-region beg end)
+	  (insert (concat ": " result)))
+      (save-excursion
+        (goto-char beg)
+        (dotimes (n size)
+          (move-beginning-of-line 1) (insert ": ") (forward-line 1))))))
 
 (defun litorgy-clean-text-properties (text)
   "Strip all properties from text return."

rorg.org

@@ -736,6 +736,34 @@ cell =0,0= through =0,3= of the table
 |                 |
 
 
+** litorgy plays with tables
+Alright, this should demonstrate both the ability of litorgy to read
+tables into a lisp source code block, and to then convert the results
+of the source code block into an org table.  It's using the classic
+"lisp is elegant" demonstration transpose function.  To try this
+out...
+
+1. evaluate [[file:litorgy/init.el]] to load litorgy and friends
+2. evaluate the transpose definition =\C-u \C-c\C-c= on the beginning of
+   the source block (prefix arg to inhibit output)
+3. evaluate the next source code block, this should read in the table
+   because of the =:var table=previous=, then transpose the table, and
+   finally it should insert the transposed table into the buffer
+   immediately following the block
+
+#+begin_src emacs-lisp
+(defun transpose (table)
+  (apply #'mapcar* #'list table))
+#+end_src
+
+| 1 |       2 | 3 |
+| 4 | schulte | 6 |
+
+#+begin_src emacs-lisp :var table=previous :replace t
+(transpose table)
+#+end_src
+
+
 * COMMENT Commentary
 I'm seeing this as like commit notes, and a place for less formal
 communication of the goals of our changes.