rcl/streams.lisp

   1 ;; Copyright (c) 2006 Carlos Ungil
   2
   3 ;; Permission is hereby granted, free of charge, to any person obtaining
   4 ;; a copy of this software and associated documentation files (the
   5 ;; "Software"), to deal in the Software without restriction, including
   6 ;; without limitation the rights to use, copy, modify, merge, publish,
   7 ;; distribute, sublicense, and/or sell copies of the Software, and to
   8 ;; permit persons to whom the Software is furnished to do so, subject to
   9 ;; the following conditions:
  10
  11 ;; The above copyright notice and this permission notice shall be
  12 ;; included in all copies or substantial portions of the Software.
  13
  14 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  15 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  16 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  17 ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
  18 ;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
  19 ;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
  20 ;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  21
  22 (in-package :rcl)
  23
  24 (defvar *r-output* t
  25   "Default stream where R output will be sent if captured")
  26
  27 (defvar *r-message* t
  28   "Default stream where R messages will be sent if captured")
  29
  30 (defvar *r-output-prefix* ";R# "
  31   "Default prefix used to print lines of R output")
  32 (defvar *r-message-prefix* ";R! "
  33   "Default prefix used to print lines of R messages")
  34
  35 (defmacro with-r-output ((&optional stream prefix) &body body)
  36   "Capture R output and send it to stream (default *r-output*),
  37 adding a prefix to each line (default *r-output-prefix*)"
  38   (let ((sink (gensym "SINK-OUT"))
  39         (result (gensym "RESULT")))
  40   `(let ((,sink (r-funcall "textConnection" "tmpout" "w"))
  41          ,result)
  42      (r-funcall "sink" :file ,sink :type "output")
  43      (unwind-protect
  44           (setf ,result (progn ,@body))
  45        (r-funcall "sink" :type "output")
  46        (r-funcall "close" ,sink)
  47        (format ,(or stream '*r-output*)
  48                (concatenate 'string "~{"  ,(or prefix '*r-output-prefix*) "~A~&~}")
  49                (let ((*extract-single-element* nil))
  50                  (r-obj-decode (r-variable "tmpout")))))
  51      ,result)))
  52
  53 (defmacro with-r-message ((&optional (stream *r-message*) (prefix *r-message-prefix*)) &body body)
  54   "Capture R messages and send them to stream (default *r-message*),
  55 adding a prefix to each line (default *r-message-prefix*)"
  56   (let ((sink (gensym "SINK-ERR"))
  57         (result (gensym "RESULT")))
  58   `(let ((,sink (r-funcall "textConnection" "tmperr" "w"))
  59          ,result)
  60      (r-funcall "sink" :file ,sink :type "message")
  61      (unwind-protect
  62           (setf ,result (progn ,@body))
  63        (r-funcall "sink" :type "message")
  64        (r-funcall "close" ,sink)
  65        (format ,stream (concatenate 'string "~{"  ,prefix "~A~&~}")
  66                (let ((*extract-single-element* nil))
  67                  (r-obj-decode (r-variable "tmperr")))))
  68      ,result)))
  69
  70 (defmacro with-r-streams (() &body body)
  71   `(let ((sink-out (r-funcall "textConnection" "tmpout" "w"))
  72          (sink-err (r-funcall "textConnection" "tmperr" "w"))
  73          result)
  74      (r-funcall "sink" :file sink-out :type "output")
  75      (r-funcall "sink" :file sink-err :type "message")
  76      (unwind-protect
  77           (setf result (progn ,@body))
  78        (r-funcall "closeAllConnections")
  79 ;; I had to resort to closing all connections
  80 ;; there were issues with the more granular approach below
  81 ;;        (r-funcall "sink" :type "output")
  82 ;;        (r-funcall "sink" :type "message")
  83 ;;        (r-funcall "close.connection" sink-out)
  84 ;;        (r-funcall "close.connection" sink-err)
  85        (format *r-output*
  86                (concatenate 'string "~{"  *r-output-prefix* "~A~&~}")
  87                (let ((*extract-single-element* nil))
  88                  (r-obj-decode (r-variable "tmpout"))))
  89        (format *r-message* (concatenate 'string "~{"  *r-message-prefix* "~A~&~}")
  90                (let ((*extract-single-element* nil))
  91                  (r-obj-decode (r-variable "tmperr")))))
  92      result))
  93
  94