src/rclg-convert.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: Conversion between R objects (technically, R SEXPs, which
  39 ;;;         are pointers to functions).  Should converted R objects
  40 ;;;         maintain a link to their source (and hence need to be
  41 ;;;         flagged for GC, etc)?
  42
  43 (defpackage :rclg-convert
  44   (:use :common-lisp :cffi
  45         :rclg-util :rclg-types :rclg-foreigns)
  46   (:export :*r-na*
  47            :convert-to-r :convert-from-r
  48            :r-bound-p :r-nil-p))
  49
  50 (in-package :rclg-convert)
  51
  52 (eval-when (:compile-toplevel :load-toplevel)
  53   ;;  PLATFORM SPECIFIC HACK FOR 32-BIT MACHINES (e.g. Pentium Linux)
  54   (defvar *r-NA-internal* -2147483648)
  55   (defvar *r-na* 'r-na))
  56
  57 ;;; Basic Conversion Routines.  None of them support error checking on
  58 ;;; input, but do provide NA on output.
  59
  60 (defun robj-to-int (robj &optional (i 0))
  61   "Returns the integer inside an R object as a CL value.
  62 SEXP? Assumes it's an integral robj.  Converts NA's"
  63   (let ((result (mem-aref (%INT robj) :int i)))
  64     (if (= result *r-NA-internal*)
  65         *r-NA*
  66       result)))
  67
  68 (defun robj-to-logical (robj &optional (i 0))
  69   "Returns the logical inside an R object as a CL value.
  70 SEXP? Assumes it's an logical robj."
  71   (= 1 (robj-to-int robj i)))
  72
  73 (defun robj-to-double (robj &optional (i 0))
  74   "Returns the double-float inside an R object as a CL value.
  75 SEXP? Assumes it's an double-float robj."
  76   (declare (type fixnum i))
  77   (mem-aref (%real robj) :double i))
  78
  79 (defun robj-to-complex (robj &optional (i 0))
  80   "Returns the complex number inside an R object as a CL value.
  81 Assumes it's a complex robj."
  82   (let ((complex (mem-aref (%COMPLEX robj) 'r-complex i)))
  83     (complex (foreign-slot-value complex 'r-complex 'rl)
  84              (foreign-slot-value complex 'r-complex 'im))))
  85
  86 (defun robj-to-string (robj &optional (i 0))
  87   "Convert an R object to a CL string.
  88 Assumes it's a string robj."
  89   (foreign-string-to-lisp (%r-char (%string-elt robj i))))
  90
  91
  92 ;;; FIXME:AJR:  NA value?
  93 (defgeneric convert-to-r (value)
  94   (:method ((n null)) *r-nil-value*)
  95   (:method ((i integer)) (int-to-robj i))
  96   (:method ((f float)) (float-to-robj f))
  97   (:method ((d double-float)) (double-float-to-robj d))
  98   (:method ((c complex)) (complex-to-robj c))
  99   (:method ((s string)) (string-to-robj s))
 100   (:method ((s sequence)) (sequence-to-robj s))
 101   (:method ((s sexp-holder)) (sexp-to-robj s))
 102   (:method ((v vector)) (sequence-to-robj v))
 103   (:method ((a array)) (array-to-robj a))
 104   (:method ((k symbol)) k)) ;; for keywords or for T
 105
 106 (defmethod convert-to-r ((na (eql *r-NA*)))
 107   (convert-to-r *r-NA-internal*))
 108
 109 (defmethod convert-to-r ((l (eql t)))
 110   "Returns an R object corresponding to the logical t."
 111   (let ((robj (%rf-alloc-vector #.(sexp-elt-type :lglsxp) 1)))
 112     (setf (mem-ref (%LOGICAL robj) :int) 1)
 113     robj))
 114
 115 (defun int-to-robj (n)
 116   "Returns an R object which corresponds to a CL integer."
 117   (let ((robj (%rf-alloc-vector #.(sexp-elt-type :intsxp) 1)))
 118     (setf (mem-ref (%INT robj) :int) n)
 119     robj))
 120
 121 (defun float-to-robj (f)
 122   "Returns an R object corresponding to a CL floating point number.
 123 Coerces the number to double-float since R has no sense of lower
 124 precision."
 125   (double-float-to-robj (coerce f 'double-float)))
 126
 127
 128 (defun double-float-to-robj (d)
 129   "Returns an R object corresponding to a double floating point number."
 130   (let ((robj (%rf-alloc-vector #.(sexp-elt-type :realsxp) 1)))
 131     (setf (mem-ref (%real robj) :double) d)
 132     robj))
 133
 134 (defun complex-to-robj (c)
 135   "Returns an R object corresponding to a CL complex number.
 136 Coerces both real and imaginary points to double-float."
 137   (let ((robj (%rf-alloc-vector #.(sexp-elt-type :cplxsxp) 1)))
 138     (let ((complex (mem-ref (%COMPLEX robj) 'r-complex)))
 139       (setf (foreign-slot-value complex 'r-complex 'rl)
 140             (coerce (realpart c) 'double-float)
 141             (foreign-slot-value complex 'r-complex 'im)
 142             (coerce (imagpart c) 'double-float)))
 143     robj))
 144
 145 (defun sexp-to-robj (s)
 146   (slot-value s 'sexp))
 147
 148 (defun string-to-robj (string)
 149   "Convert a string to an R object.
 150 I(rif) *believe* that %rf-mkchar does a copy.  At least, I hope it
 151 does."
 152   (let ((robj (%rf-alloc-vector (sexp-elt-type :strsxp) 1))
 153         (str-sexp
 154          (with-foreign-string (s string)
 155            (%rf-mkchar s))))
 156     (%set-string-elt robj 0 str-sexp)
 157     robj))
 158
 159
 160 (defun array-to-vector-column-major (array)
 161   "FIXME:AJR: needs doc string."
 162   (let ((result
 163          (make-array (array-total-size array)
 164                      :element-type (array-element-type array))))
 165     (over-column-major-indices (array cmi rmi)
 166         (setf (aref result rmi) (row-major-aref array cmi)))
 167     result))
 168
 169
 170 (defun array-to-robj (a)
 171   "Convert an array to an R object (R array)."
 172   (let ((column-vector
 173          (convert-to-r (array-to-vector-column-major a))))
 174     (%rf-set-attrib column-vector
 175                     *r-dims-symbol*
 176                     (convert-to-r (array-dimensions a)))
 177     column-vector))
 178
 179 ;;; Sequence conversion
 180 (eval-when (:compile-toplevel :load-toplevel)
 181   (defvar +int-seq+ 1)
 182   (defvar +float-seq+ 2)
 183   (defvar +complex-seq+ 3)
 184   (defvar +string-seq+ 4)
 185   (defvar +any-seq+ 0)
 186
 187   (defvar +seq-fsm+ #2A((0 0 0 0 0)
 188                         (0 1 2 3 0)
 189                         (0 2 2 3 0)
 190                         (0 3 3 3 0)
 191                         (0 0 0 0 4))))
 192
 193 (defun type-to-int (obj)
 194   "FIXME:AJR: Needs doc string."
 195   (cond ((eql obj *r-na*) +int-seq+)
 196         (t (typecase obj
 197              (integer +int-seq+)
 198              (float +float-seq+)
 199              (complex +complex-seq+)
 200              (string +string-seq+)
 201              (t +any-seq+)))))
 202
 203 (defun sequence-to-robj (seq)
 204   "FIXME:AJR: Needs doc string."
 205   (let ((len (length seq)))
 206     (let ((robj (%rf-protect (%rf-alloc-vector #.(sexp-elt-type :vecsxp) len)))
 207           (state (type-to-int (elt seq 0)))
 208           (i 0))
 209       ;; We may reinclude more efficient handling of certain
 210       ;; vectors for certain implementations here at some late time
 211       (map nil
 212            (lambda (e)
 213              (%set-vector-elt robj i (convert-to-r e))
 214              (setf state (aref +seq-fsm+ state (type-to-int e))
 215                    i     (+ i 1)))
 216            seq)
 217       (let ((result
 218              (case state
 219                (#.+int-seq+ (%rf-coerce-vector robj #.(sexp-elt-type :intsxp)))
 220                (#.+float-seq+ (%rf-coerce-vector robj #.(sexp-elt-type :realsxp)))
 221                (#.+complex-seq+ (%rf-coerce-vector robj #.(sexp-elt-type :cplxsxp)))
 222                (#.+string-seq+ (%rf-coerce-vector robj #.(sexp-elt-type :strsxp)))
 223                (t robj))))
 224         (%rf-unprotect 1)
 225         (values result state)))))
 226
 227
 228 (defun convert-from-r (robj)
 229   "Attempt to convert a general R value to a CL value.
 230 FIXME:AJR: what should happen upon failure?  Do we even care, or
 231 should be let user beware (i.e. assume 'intelligence')."
 232   (unless (r-nil-p robj)
 233     (let ((length (%rf-length robj)))
 234       (unless (= length 0)
 235         (let ((result (convert-from-r-seq robj length)))
 236           (if (= length 1)
 237               (aref result 0)
 238               result))))))
 239
 240 (defun sexptype-to-element-type (type)
 241   (case type
 242     (#.(sexp-elt-type :intsxp) 'integer); Sigh, not fixnum.
 243                                         ; FIXME:AJR: Why not? Range?
 244                                         ; AJR: I think speed
 245     (#.(sexp-elt-type :lglsxp) 'boolean)
 246     (#.(sexp-elt-type :realsxp) 'double-float)
 247     (#.(sexp-elt-type :cplxsxp) 'complex)
 248     (#.(sexp-elt-type :strsxp) 'string)
 249     (#.(sexp-elt-type :listsxp) 't)
 250     (#.(sexp-elt-type :vecsxp) 't)
 251     (t (error "Unknown type"))))
 252
 253 (defun convert-from-r-seq (robj length)
 254   "Convert an R sequence into a CL array."
 255   (let* ((type (sexptype robj))
 256          (result (make-array length
 257                              :element-type (sexptype-to-element-type type))))
 258     (dotimes (i length)
 259       (setf (aref result i)
 260             (case type
 261               (#.(sexp-elt-type :intsxp) (robj-to-int robj i))
 262               (#.(sexp-elt-type :lglsxp) (robj-to-logical robj i))
 263               (#.(sexp-elt-type :realsxp) (robj-to-double robj i))
 264               (#.(sexp-elt-type :cplxsxp) (robj-to-complex robj i))
 265               (#.(sexp-elt-type :strsxp) (robj-to-string robj i))
 266               (#.(sexp-elt-type :listsxp) (convert-from-r (%rf-elt robj i)))
 267               (#.(sexp-elt-type :vecsxp) (convert-from-r (%vector-elt robj i)))
 268               (t (error "Unknown type")))))
 269     (values result type)))
 270
 271 (defun r-bound-p (robj)
 272   "Checks if an R SEXP is (has the address of) the *r-unbound-value*
 273 SEXP.  Used to verify values."
 274   (not (= (pointer-address robj)
 275           (pointer-address *r-unbound-value*))))
 276
 277 (defun r-nil-p (robj)
 278   "Checks if an R SEXP is (has the address of) the *r-nil-value*
 279 SEXP."
 280   (= (pointer-address robj)
 281      (pointer-address *r-nil-value*)))
 282
 283
 284 ;;; Need to write
 285 #+nil
 286 (defun r-na (robj)
 287   "Checks if R SEXP is missing value."
 288   (= (pointer-address robj)
 289      (pointer-address *r-missing-value*)))
 290