src/rclg-abstractions.lisp

   1 ;;; RCLG: R-CommonLisp Gateway
   2
   3 ;;; Copyright (c) 2005--2007, <rif@mit.edu>
   4 ;;;                           AJ Rossini <blindglobe@gmail.com>
   5 ;;; All rights reserved.
   6 ;;;
   7 ;;; Redistribution and use in source and binary forms, with or without
   8 ;;; modification, are permitted provided that the following conditions are
   9 ;;; met:
  10 ;;;
  11 ;;;     * Redistributions of source code must retain the above copyright
  12 ;;;       notice, this list of conditions and the following disclaimer.
  13 ;;;     * Redistributions in binary form must reproduce the above
  14 ;;;       copyright notice, this list of conditions and the following disclaimer
  15 ;;;       in the documentation and/or other materials provided with the
  16 ;;;       distribution.
  17 ;;;     * The names of the contributors may not be used to endorse or
  18 ;;;       promote products derived from this software without specific
  19 ;;;       prior written permission.
  20 ;;;
  21 ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  22 ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  23 ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
  24 ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
  25 ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  26 ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
  27 ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
  28 ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
  29 ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
  30 ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
  31 ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  32
  33
  34 ;;; Author:      rif@mit.edu
  35 ;;; Maintainers: rif@mit.edu,
  36 ;;;              AJ Rossini <blindglobe@gmail.com>
  37
  38 ;;; Intent: higher level abstractions on top of RCLG.
  39
  40 (defpackage :rclg-abstractions
  41   (:use :common-lisp :rclg-control :rclg-util)
  42   (:export :def-r-call))
  43
  44 (in-package :rclg-abstractions)
  45
  46 ;;; Internal functions
  47
  48 (defun remove-keys-from-plist (plist keys)
  49   "Returns a copy of plist with keys removed.  For re-using the &REST arg after
  50 removing some options."
  51   (when plist
  52     (append (unless (member (car plist) keys) (subseq plist 0 2))
  53             (remove-keys-from-plist (cddr plist) keys))))
  54
  55 (defun to-keyword (symbol)
  56   (intern (symbol-name symbol) :keyword))
  57
  58 (defun atom-or-first (val)
  59   (if (atom val) val (car val)))
  60
  61 ;;; External functions
  62
  63 (defmacro def-r-call ((function-name r-name conversion &rest required-args)
  64                       &rest keyword-args)
  65   "Utility macro for defining calls to R.  Defines a CL function
  66 function-name that calls the R function r-name.  The conversion
  67 argument specifices what happens to the result: :convert converts the
  68 result to CL, :raw yields an unconverted R sexp, and :no-result throws
  69 away the results (for side effects only).  The keyword args allow
  70 specification of default values, others keys are allowed.  For example,
  71
  72   (def-r-call (r-hist hist :no-result sequence) main xlab (breaks 50)
  73               (probability t) (col \"blue\"))
  74
  75 creates a CL function r-hist that calls the R function hist on a
  76 sequence, returning no results.  The keywords :main and :xlab are
  77 passed with default values nil, and the other keywords are passed with
  78 the chosen values.  (Try (r-hist (rnbi rnorm 1000)), for instance.)
  79 "
  80   (let* ((keyword-names (mapcar #'atom-or-first keyword-args))
  81          (keywords (mapcar #'to-keyword keyword-names))
  82          (rest-sym (gensym)))
  83     `(defun ,function-name (,@required-args
  84                          &rest ,rest-sym
  85                          &key ,@keyword-args
  86                          &allow-other-keys)
  87       (,(case conversion
  88               (:convert 'r)
  89               (:raw 'rnb)
  90               (:no-result 'rnr))
  91        ,r-name
  92        ,@required-args
  93        ,@(mapcan #'(lambda (k n) (list k n))
  94                  keywords
  95                  keyword-names)
  96        (remove-keys-from-plist ,rest-sym ',keywords)))))