ascii-data.lisp

   1 ;;;; ascii-data.lisp
   2 ;;;;
   3 ;;;; A quick and dirty way of loading numerical data from an ASCII
   4 ;;;; (text) file into a CL-ARRAY.
   5 ;;;;
   6 ;;;; (C) 2012, Sumant S.R. Oemrawsingh
   7
   8 (in-package #:ascii-data)
   9
  10 (eval-when (compile)
  11   (declaim (optimize (speed 3) (safety 1))))
  12
  13 (defvar *comment-characters* '(#\# #\' #\;)
  14   "LIST of characters that sigal a comment in the data.")
  15
  16 ;;;; Utility functions and macros
  17
  18 (let ((type-functions
  19        (list (list 'integer
  20                    #'(lambda (string start)
  21                        (parse-integer string :start start :junk-allowed t))
  22                    #'(lambda (value &optional formatspec)
  23                        (format nil (or formatspec "~D") value)))
  24              (list 'double-float
  25                    #'(lambda (string start)
  26                        (parse-float:parse-float string :start start :type 'double-float :junk-allowed t))
  27                    #'(lambda (value &optional formatspec)
  28                        (format nil (or formatspec "~,18,2,,,,'eE") value)))
  29              (list 'single-float
  30                    #'(lambda (string start)
  31                        (parse-float:parse-float string :start start :type 'single-float :junk-allowed t))
  32                    #'(lambda (value &optional formatspec)
  33                        (format nil (or formatspec "~,18,2,,,,'eE") value))))))
  34
  35   (defun get-closest-type-function (type)
  36     (car (member type type-functions :key #'car :test #'subtypep)))
  37
  38   (defun type-reader (type)
  39     (or (cadr (get-closest-type-function type))
  40         (cadr (get-closest-type-function 'double-float))))
  41
  42   (defun type-writer (type)
  43     (or (caddr (get-closest-type-function type))
  44         (caddr (get-closest-type-function 'double-float)))))
  45
  46 (defmacro loop-at-most ((n) &body body)
  47   "Modified loop macro that repeats at most N times, if N is a
  48 positive integer. Else, the behaviour is the same as LOOP."
  49   (let ((total (gensym)))
  50     `(let ((,total ,n))
  51        (if (numberp ,total)
  52            (loop repeat ,total
  53                 ,@body)
  54            (loop ,@body)))))
  55
  56 ;;; At the moment, the data is read by creating a list of values. This
  57 ;;; list constitutes a row. These rows are then collected into a list,
  58 ;;; thus creating a nested list, suitable for providing to
  59 ;;; :initial-contents of make-array.
  60 ;;;
  61 ;;; Another strategy would be to create an adjustable vector with a
  62 ;;; fill pointer. Then, vector-push-extend all values into this vector
  63 ;;; and finally, having determined the shape of the array, return an
  64 ;;; array displaced to that vector (is this even
  65 ;;; possible?). Theoretically, this means we could return two values:
  66 ;;; the displaced array, and the target vector. A user would then be
  67 ;;; free to modify the original vector any way he/she wants
  68 ;;; (e.g. adding extra values) and make a new array displaced to the
  69 ;;; adjusted vector.
  70 ;;;
  71 ;;; I'm not sure which approach is "better". Does "better" mean
  72 ;;; "faster", or "more flexible"?
  73 (defun read-row* (stream reader &optional number-of-columns)
  74   "Read a row from STREAM and convert the values using READER. if
  75 NUMBER-OF-COLUMNS is given, read at most that many values. The values
  76 are returned in a LIST."
  77   (let ((row (loop for line = (read-line stream nil nil)
  78                 while (and line (member (char line 0) *comment-characters* :test #'char=))
  79                 finally (return line))))
  80     (when row
  81       (loop-at-most (number-of-columns)
  82          with start = 0
  83          with value
  84
  85          do (multiple-value-bind (val pos)
  86                 (funcall reader row start)
  87               (setf start pos
  88                     value val))
  89
  90          while value
  91
  92          collect value))))
  93
  94 (defun read-ascii-list* (stream &key (element-type 'single-float)
  95                          number-of-rows
  96                          number-of-columns)
  97   "Read data from STREAM into a LIST. The elements will have the
  98 given ELEMENT-TYPE. Optionally, you can limit the NUMBER-OF-ROWS and
  99 NUMBER-OF-COLUMNS that are read, thus truncating the data. If these
 100 are not positive integers (e.g. NIL), just read everything."
 101   (let ((reader (type-reader element-type)))
 102     (loop-at-most (number-of-rows)
 103        for row = (read-row* stream reader number-of-columns)
 104
 105        unless row
 106        do (loop-finish)
 107
 108        unless number-of-columns
 109        do (setf number-of-columns (length row))
 110
 111        collect row)))
 112
 113 (defun read-ascii-array* (stream &key (element-type 'single-float)
 114                           number-of-rows
 115                           number-of-columns)
 116   "Read data from STREAM into a CL-ARRAY. The array will have the
 117 given ELEMENT-TYPE. STREAM must contain a rectangular grid of values,
 118 i.e. each row must contain the same number of values.
 119
 120 NUMBER-OF-ROWS can be used to limit the number of rows that are
 121 read. The default is NIL, which will result in all rows being read.
 122
 123 NUMBER-OF-COLUMNS works as NUMBER-OF-ROWS, but for columns."
 124   (let ((values (read-ascii-list* stream :element-type element-type
 125                                   :number-of-rows number-of-rows
 126                                   :number-of-columns number-of-columns)))
 127     (make-array (list (length values) (length (car values)))
 128                 :element-type element-type
 129                 :initial-contents values)))
 130
 131 (defun read-ascii-array (file &key (element-type 'single-float)
 132                          number-of-rows
 133                          number-of-columns)
 134   "Read data from FILE into an ARRAY. It opens FILE and calls
 135 READ-ASCII-ARRAY* on the resulting stream."
 136   (with-open-file (s file :direction :input :element-type 'base-char)
 137     (read-ascii-array* s :element-type element-type
 138                        :number-of-rows number-of-rows
 139                        :number-of-columns number-of-columns)))
 140
 141 (defun read-ascii-vector-or-array* (stream &key (element-type 'single-float)
 142                                     number-of-rows
 143                                     number-of-columns)
 144   "Read data from STREAM into an ARRAY or a VECTOR. The array will
 145 have the given ELEMENT-TYPE. STREAM must contain a rectangular grid of
 146 values, i.e. each row must contain the same number of values.
 147
 148 NUMBER-OF-ROWS can be used to limit the number of rows that are
 149 read. The default is NIL, which will result in all rows being read.
 150
 151 NUMBER-OF-COLUMNS works as NUMBER-OF-ROWS, but for columns.
 152
 153 This function uses READ-ASCII-ARRAY*. If the returned ARRAY has only a
 154 single row or a single column, the return rank-1 array, a VECTOR, is
 155 displaced to that ARRAY. Else the original ARRAY is returned."
 156   (let ((read-array (read-ascii-array* stream :element-type element-type
 157                                        :number-of-rows number-of-rows
 158                                        :number-of-columns number-of-columns)))
 159     (if (or (= (array-dimension read-array 0) 1)
 160             (= (array-dimension read-array 1) 1))
 161         (make-array (apply #'* (array-dimensions read-array))
 162                     :element-type element-type
 163                     :displaced-to read-array
 164                     :displaced-index-offset 0)
 165         read-array)))
 166
 167
 168
 169 #+nil ; Written before I knew about and understood displaced arrays.
 170 (defun read-ascii-vector-or-array* (stream &key (element-type 'single-float)
 171                                     number-of-rows
 172                                     number-of-columns)
 173   (let* ((values (read-ascii-list* stream :element-type element-type
 174                                    :number-of-rows number-of-rows
 175                                    :number-of-columns number-of-columns))
 176          (num-rows (length values))
 177          (num-cols (length (car values)))
 178          len)
 179
 180     (cond ((= num-rows 1)
 181            (setf len num-cols
 182                  values (car values)))
 183           ((= num-cols 1)
 184            (setf len num-rows
 185                  values (alexandria:flatten values)))
 186            (t (setf len (list num-rows num-cols))))
 187           (make-array len
 188                       :element-type element-type
 189                       :initial-contents values)))
 190
 191 (defun read-ascii-vector-or-array (file &key (element-type 'single-float)
 192                                    number-of-rows
 193                                    number-of-columns)
 194   "Read data from FILE into an ARRAY or a VECTOR. It opens FILE and
 195 calls READ-ASCII-VECTOR-OR-ARRAY* on the resulting stream."
 196   (with-open-file (s file)
 197     (read-ascii-vector-or-array* s :element-type element-type
 198                                  :number-of-rows number-of-rows
 199                                  :number-of-columns number-of-columns)))
 200
 201 (defun write-ascii-array% (array stream formatspec number-of-rows number-of-columns)
 202   (let ((writer (type-writer (array-element-type array))))
 203     (loop for row below number-of-rows
 204        for start-column = (* row number-of-columns)
 205        for stop-column = (+ start-column number-of-columns)
 206        do (progn
 207             (loop for column from start-column below stop-column
 208                do (princ (funcall writer (aref array column) formatspec) stream)
 209                unless (= column (- stop-column 1))
 210                do (princ " " stream))
 211             (terpri stream)))))
 212
 213 (defun write-ascii-array* (array stream &key formatspec)
 214   "Write the values in ARRAY to the given STREAM, optionally making
 215 use of FORMATSPEC, which is a control string for FORMAT to write out a
 216 single numerical value."
 217   (assert (= (array-rank array) 2))
 218   (destructuring-bind (rows columns)
 219       (array-dimensions array)
 220     (write-ascii-array%
 221      (make-array (* rows columns)
 222                  :element-type (array-element-type array)
 223                  :displaced-to array
 224                  :displaced-index-offset 0)
 225      stream
 226      formatspec
 227      rows
 228      columns)))
 229
 230 (defun write-ascii-array (array file &key formatspec
 231                           (if-exists :supersede)
 232                           (if-does-not-exist :create))
 233   "Write the values in ARRAY to the given FILE. It opens the FILE and
 234 writes the data to the restulting stream using WRITE-ASCII-ARRAY*."
 235   (with-open-file (s file :direction :output :if-exists if-exists :if-does-not-exist if-does-not-exist)
 236     (write-ascii-array* array s :formatspec formatspec)))
 237
 238 (defun write-ascii-vector-or-array* (vector-or-array stream &key formatspec)
 239   "Write the values in VECTOR-OR-ARRAY to the given STREAM, optionally
 240 making use of FORMATSPEC, which is a control string for FORMAT to
 241 write out a single numerical value."
 242   (assert (< (array-rank vector-or-array) 3))
 243   (if (= (array-rank vector-or-array) 1)
 244       (write-ascii-array% vector-or-array stream formatspec (array-dimension vector-or-array 0) 1)
 245       (write-ascii-array* vector-or-array stream :formatspec formatspec)))
 246
 247 (defun write-ascii-vector-or-array (vector-or-array file &key formatspec
 248                                     (if-exists :supersede)
 249                                     (if-does-not-exist :create))
 250   "Write the values in VECTOR-OR-ARRAY to the given FILE. It opens the FILE and
 251 writes the data to the restulting stream using WRITE-ASCII-VECTOR-OR-ARRAY*."
 252   (with-open-file (s file :direction :output :if-exists if-exists :if-does-not-exist if-does-not-exist)
 253     (write-ascii-vector-or-array* vector-or-array s :formatspec formatspec)))