2 ;;; Copyright (c) 2005--2008, by A.J. Rossini <blindglobe@gmail.com>
3 ;;; See COPYRIGHT file for any additional restrictions (BSD license).
4 ;;; Since 1991, ANSI was finally finished. Edited for ANSI Common Lisp.
7 (in-package #:lisp-matrix-stat-linalg
)
10 ;;;; Spline Interpolation
13 (cffi:defcfun
("ccl_range_to_rseq" ccl-range-to-rseq
)
14 :int
(x size-t
) (y :pointer
) (z size-t
) (u :pointer
))
15 (defun la-range-to-rseq (x y z u
)
16 (ccl-range-to-rseq x y z u
))
18 (cffi:defcfun
("ccl_spline_front" ccl-spline-front
)
19 :int
(x size-t
) (y :pointer
) (z :pointer
) (u size-t
) (v :pointer
) (w :pointer
) (a :pointer
))
20 (defun spline-front (x y z u v w a
)
21 (ccl-spline-front x y z u v w a
))
24 ;;;; Kernel Density Estimators and Smoothers
27 (cffi:defcfun
("ccl_kernel_dens_front" ccl-kernel-dens-front
)
28 :int
(x :pointer
) (y size-t
) (z :double
) (u :pointer
) (v :pointer
) (w size-t
) (a :int
))
29 (defun kernel-dens-front (x y z u v w a
)
30 (ccl-kernel-dens-front x y
(float z
1d0
) u v w a
))
32 (cffi:defcfun
("ccl_kernel_smooth_front" ccl-kernel-smooth-front
)
33 :int
(x :pointer
) (y :pointer
) (z size-t
) (u :double
) (v :pointer
) (w :pointer
) (a size-t
) (b :int
))
34 (defun kernel-smooth-front (x y z u v w a b
)
35 (ccl-kernel-smooth-front x y z
(float u
1d0
) v w a b
))
38 ;;;; Lowess Smoother Interface
41 (cffi:defcfun
("ccl_base_lowess_front" ccl-base-lowess-front
)
42 :int
(x :pointer
) (y :pointer
) (z size-t
) (u :double
) (v size-t
) (w :double
) (a :pointer
) (b :pointer
) (c :pointer
))
43 (defun base-lowess-front (x y z u v w a b c
)
44 (ccl-base-lowess-front x y z
(float u
1d0
) v
(float w
1d0
) a b c
))
50 (cffi:defcfun
("ccl_fft_front" ccl-fft-front
)
51 :int
(x size-t
) (y :pointer
) (z :pointer
) (u :int
))
52 (defun fft-front (x y z u
)
53 (ccl-fft-front x y z u
))
58 ;;;; Spline Interpolation
61 (defun make-smoother-args (x y xvals
)
67 (unless (integerp xvals
)
68 (check-sequence xvals
)
71 (ns (if (integerp xvals
) xvals
(length xvals
)))
72 (result (list (make-list ns
) (make-list ns
))))
73 (if (and y
(/= n
(length y
))) (error "sequences not the same length"))
74 (list x y n
(if (integerp xvals
) 0 1) ns xvals result
)))
76 (defun get-smoother-result (args) (seventh args
))
78 (defmacro with-smoother-data
((x y xvals is-reg
) &rest body
)
85 (unless (integerp ,xvals
)
86 (check-sequence ,xvals
)
88 (let* ((supplied (not (integerp ,xvals
)))
90 (ns (if supplied
(length ,xvals
) ,xvals
))
91 (result (list (make-list ns
) (make-list ns
))))
92 (if (and ,is-reg
(/= n
(length ,y
)))
93 (error "sequences not the same length"))
94 (if (and (not supplied
) (< ns
2))
95 (error "too few points for interpolation"))
96 (let* ((px (la-data-to-vector ,x
+mode-re
+))
97 (py (if ,is-reg
(la-data-to-vector ,y
+mode-re
+)))
99 (la-data-to-vector ,xvals
+mode-re
+)
100 (la-vector ns
+mode-re
+)))
101 (pys (la-vector ns
+mode-re
+)))
102 (unless supplied
(la-range-to-rseq n px ns pxs
))
105 (la-vector-to-data pxs ns
+mode-re
+ (first result
))
106 (la-vector-to-data pys ns
+mode-re
+ (second result
)))
108 (if ,is-reg
(la-free-vector py
))
110 (la-free-vector pys
))
113 (defun spline (x y
&key
(xvals 30))
114 "Args: (x y &key xvals)
115 Returns list of x and y values of natural cubic spline interpolation of (X,Y).
116 X must be strictly increasing. XVALS can be an integer, the number of equally
117 spaced points to use in the range of X, or it can be a sequence of points at
118 which to interpolate."
119 (with-smoother-data (x y xvals t
)
120 (let ((work (la-vector (* 2 n
) +mode-re
+))
123 (setf error
(spline-front n px py ns pxs pys work
))
124 (la-free-vector work
))
125 (if (/= error
0) (error "bad data for splines")))))
128 ;;;; Kernel Density Estimators and Smoothers
131 (defun kernel-type-code (type)
132 (cond ((eq type
'u
) 0)
137 (defun kernel-dens (x &key
(type 'b
) (width -
1.0) (xvals 30))
138 "Args: (x &key xvals width type)
139 Returns list of x and y values of kernel density estimate of X. XVALS can be an
140 integer, the number of equally spaced points to use in the range of X, or it
141 can be a sequence of points at which to interpolate. WIDTH specifies the
142 window width. TYPE specifies the lernel and should be one of the symbols G, T,
143 U or B for gaussian, triangular, uniform or bisquare. The default is B."
144 (check-one-real width
)
145 (with-smoother-data (x nil xvals nil
) ;; warning about deleting unreachable code is TRUE -- 2nd arg=nil!
146 (let ((code (kernel-type-code type
))
148 (setf error
(kernel-dens-front px n width pxs pys ns code
))
149 (if (/= 0 error
) (error "bad kernel density data")))))
151 (defun kernel-smooth (x y
&key
(type 'b
) (width -
1.0) (xvals 30))
152 "Args: (x y &key xvals width type)
153 Returns list of x and y values of kernel smooth of (X,Y). XVALS can be an
154 integer, the number of equally spaced points to use in the range of X, or it
155 can be a sequence of points at which to interpolate. WIDTH specifies the
156 window width. TYPE specifies the lernel and should be one of the symbols G, T,
157 U or B for Gaussian, triangular, uniform or bisquare. The default is B."
158 (check-one-real width
)
159 (with-smoother-data (x y xvals t
)
160 (let ((code (kernel-type-code type
))
162 (kernel-smooth-front px py n width pxs pys ns code
)
163 ;; if we get the Lisp version ported from C, uncomment below and
164 ;; comment above. (thanks to Carlos Ungil for the initial CFFI
166 ;;(kernel-smooth-Cport px py n width pxs pys ns code)
167 (if (/= 0 error
) (error "bad kernel density data")))))
171 (defun kernel-smooth-Cport (px py n width
;;wts wds ;; see above for mismatch?
173 "Port of kernel_smooth (Lib/kernel.c) to Lisp.
174 FIXME:kernel-smooth-Cport : This is broken.
175 Until this is fixed, we are using Luke's C code and CFFI as glue."
176 (declare (ignore width xs
))
178 ((and (< n
2) (<= width
0)) 1.0)
179 (t (let* ((xmin (min px
))
181 (width (/ (- xmax xmin
) (+ 1.0 (log n
)))))
182 (dotimes (i (- ns
1))
186 (dotimes (j (- n
1)) )
187 ;;;possible nasty errors...
189 ;; ((lwidth (if wds (* width (aref wds j)) width))
190 ;; (lwt (* (kernel-Cport (aref xs i) (aref px j) lwidth ktype) ;; px?
191 ;; (if wts (aref wts j) 1.0))))
192 ;; (setf wsum (+ wsum lwt))
193 ;; (setf ysum (if py (+ ysum (* lwt (aref py j)))))) ;; py? y?
205 (defun kernel-Cport (x y w ktype
)
206 "Port of kernel() (Lib/kernel.c) to Lisp.
207 x,y,w are doubles, type is an integer"
211 (cond ((eq ktype
"B")
216 (/ (/ (* 15.0 (* (- 1.0 (* 4 z z
)) ;; k/w
217 (- 1.0 (* 4 z z
)))) ;; k/w
222 (let* ((w (* w
0.25))
224 (k (/ (exp (* -
0.5 z z
))
230 (k (if (< (abs z
) 0.5)
235 (cond ((and (> z -
1.0)
246 ;;;; Lowess Smoother Interface
249 (defun |base-lowess|
(s1 s2 f nsteps delta
)
255 (check-one-fixnum nsteps
)
256 (check-one-real delta
)
257 (let* ((n (length s1
))
258 (result (make-list n
)))
259 (if (/= n
(length s2
)) (error "sequences not the same length"))
260 (let ((x (la-data-to-vector s1
+mode-re
+))
261 (y (la-data-to-vector s2
+mode-re
+))
262 (ys (la-vector n
+mode-re
+))
263 (rw (la-vector n
+mode-re
+))
264 (res (la-vector n
+mode-re
+))
268 (setf error
(base-lowess-front x y n f nsteps delta ys rw res
))
269 (la-vector-to-data ys n
+mode-re
+ result
))
274 (la-free-vector res
))
275 (if (/= error
0) (error "bad data for lowess"))
279 static LVAL add_contour_point
(i, j
, k
, l
, x
, y
, z
, v
, result
)
289 if
((z[i][j] <= v && v < z[k][l]) || (z[k][l] <= v && v < z[i][j])) {
292 p = (v - z[i][j]) / (z[k][l] - z[i][j]);
294 rplaca(pt, cvflonum((FLOTYPE) (q * x[i] + p * x[k])));
295 rplaca
(cdr(pt), cvflonum
((FLOTYPE) (q * y
[j] + p * y[l])));
296 result = cons(pt, result);
302 LVAL xssurface_contour()
304 LVAL s1, s2, mat, result;
310 s1 = xsgetsequence();
311 s2 = xsgetsequence();
313 v = makedouble(xlgetarg());
316 n = seqlen(s1); m = seqlen(s2);
317 if (n != numrows(mat) || m != numcols(mat)) xlfail("dimensions do not match");
318 if (data_mode(s1) == CX || data_mode(s2) == CX || data_mode(mat) == CX)
319 xlfail("data must be real");
321 x = (RVector) data_to_vector(s1, RE);
322 y = (RVector) data_to_vector(s2, RE);
323 z = (RMatrix) data_to_matrix(mat, RE);
327 for (i = 0; i < n - 1; i++) {
328 for (j = 0; j < m - 1; j++) {
329 result = add_contour_point(i, j, i, j+1, x, y, z, v, result);
330 result = add_contour_point(i, j+1, i+1, j+1, x, y, z, v, result);
331 result = add_contour_point(i+1, j+1, i+1, j, x, y, z, v, result);
332 result = add_contour_point(i+1, j, i, j, x, y, z, v, result);
349 ;;; ??replace with matlisp:fft and matlisp:ifft (the latter for inverse mapping)
351 (defun fft (x &optional inverse)
352 "Args: (x &optional inverse)
353 Returns unnormalized Fourier transform of X, or inverse transform if INVERSE
356 (let* ((n (length x))
357 ;;(mode (la-data-mode x))
358 (isign (if inverse -1 1))
359 (result (if (consp x) (make-list n) (make-array n))))
360 (let ((px (la-data-to-vector x +mode-cx+))
361 (work (la-vector (+ (* 4 n) 15) +mode-re+)))
364 (fft-front n px work isign)
365 (la-vector-to-data px n +mode-cx+ result))
367 (la-free-vector work))
371 ;;; SWEEP Operator: FIXME: use matlisp
374 (defun make-sweep-front (x y w n p mode has_w x_mean result)
375 (declare (fixnum n p mode has_w))
390 (has-w (if (/= 0 has_w) t nil))
392 (declare (long-float val dxi dyi dv dw sum_w dxik dxjk dyj
393 dx_meani dx_meanj dy_mean)) ;; originally "declare-double" macro
395 (if (> mode RE) (error "not supported for complex data yet"))
397 (setf x_data (compound-data-seq x))
398 (setf result_data (compound-data-seq result))
400 ;; find the mean of y
405 (setf dyi (makedouble (aref y i)))
407 (setf dw (makedouble (aref w i)))
409 (setf dyi (* dyi dw)))
411 (if (not has-w) (setf sum_w (float n 0.0)))
412 (if (<= sum_w 0.0) (error "non positive sum of weights"))
413 (setf dy_mean (/ val sum_w))
415 ;; find the column means
421 (setf dxi (makedouble (aref x_data (+ (* p i) j))))
423 (setf dw (makedouble (aref w i)))
424 (setf dxi (* dxi dw)))
426 (setf (aref x_mean j) (/ val sum_w)))
428 ;; put 1/sum_w in topleft, means on left, minus means on top
429 (setf (aref result_data 0) (/ 1.0 sum_w))
432 (setf dxi (makedouble (aref x_mean i)))
433 (setf (aref result_data (+ i 1)) (- dxi))
434 (setf (aref result_data (* (+ i 1) (+ p 2))) dxi))
435 (setf (aref result_data (+ p 1)) (- dy_mean))
436 (setf (aref result_data (* (+ p 1) (+ p 2))) dy_mean)
438 ;; put sums of adjusted cross products in body
446 (setf dxik (makedouble (aref x_data (+ (* p k) i))))
447 (setf dxjk (makedouble (aref x_data (+ (* p k) j))))
448 (setf dx_meani (makedouble (aref x_mean i)))
449 (setf dx_meanj (makedouble (aref x_mean j)))
450 (setf dv (* (- dxik dx_meani) (- dxjk dx_meanj)))
452 (setf dw (makedouble (aref w k)))
455 (setf (aref result_data (+ (* (+ i 1) (+ p 2)) (+ j 1))) val)
456 (setf (aref result_data (+ (* (+ j 1) (+ p 2)) (+ i 1))) val))
460 (setf dxik (makedouble (aref x_data (+ (* p j) i))))
461 (setf dyj (makedouble (aref y j)))
462 (setf dx_meani (makedouble (aref x_mean i)))
463 (setf dv (* (- dxik dx_meani) (- dyj dy_mean)))
465 (setf dw (makedouble (aref w j)))
468 (setf (aref result_data (+ (* (+ i 1) (+ p 2)) (+ p 1))) val)
469 (setf (aref result_data (+ (* (+ p 1) (+ p 2)) (+ i 1))) val))
473 (setf dyj (makedouble (aref y j)))
474 (setf dv (* (- dyj dy_mean) (- dyj dy_mean)))
476 (setf dw (makedouble (aref w j)))
479 (setf (aref result_data (+ (* (+ p 1) (+ p 2)) (+ p 1))) val)))
481 ;;; FIXME: use matlisp
482 (defun sweep-in-place-front (a rows cols mode k tol)
483 "Sweep algorithm for linear regression."
484 (declare (long-float tol))
485 (declare (fixnum rows cols mode k))
493 (declare (long-float pivot aij aik akj akk))
495 (if (> mode RE) (error "not supported for complex data yet"))
496 (if (or (< k 0) (>= k rows) (>= k cols)) (error "index out of range"))
498 (setf tol (max tol machine-epsilon))
499 (setf data (compound-data-seq a))
501 (setf pivot (makedouble (aref data (+ (* cols k) k))))
504 ((or (> pivot tol) (< pivot (- tol)))
509 (when (and (/= i k) (/= j k))
510 (setf aij (makedouble (aref data (+ (* cols i) j))))
511 (setf aik (makedouble (aref data (+ (* cols i) k))))
512 (setf akj (makedouble (aref data (+ (* cols k) j))))
513 (setf aij (- aij (/ (* aik akj) pivot)))
514 (setf (aref data (+ (* cols i) j)) aij))))
518 (setf aik (makedouble (aref data (+ (* cols i) k))))
520 (setf aik (/ aik pivot))
521 (setf (aref data (+ (* cols i) k)) aik)))
525 (setf akj (makedouble (aref data (+ (* cols k) j))))
527 (setf akj (- (/ akj pivot)))
528 (setf (aref data (+ (* cols k) j)) akj)))
530 (setf akk (/ 1.0 pivot))
531 (setf (aref data (+ (* cols k) k)) akk)
535 ;; FIXME: use matlisp
536 (defun make-sweep-matrix (x y &optional w)
537 "Args: (x y &optional weights)
538 X is matrix-like, Y and WEIGHTS are vector-like. Returns the sweep matrix of the
539 (weighted) regression of Y on X"
540 (assert (typep x 'matrix-like))
541 (assert (typep y 'vector-like))
542 (if w (assert (typep w 'vector-like)))
543 (let ((n (matrix-dimension x 0))
544 (p (matrix-dimension x 1)))
545 (if (/= n (length y)) (error "dimensions do not match"))
546 (if (and w (/= n (length w))) (error "dimensions do not match"))
547 (let ((mode (max (la-data-mode x)
549 (if w (la-data-mode w) 0)))
550 (result (make-matrix (+ p 2) (+ p 2))))
551 (x-mean (make-vector p))
553 (make-sweep-front x y w n p mode has-w x-mean result)
556 (defun sweep-in-place (a k tol)
557 (assert (typep a 'matrix-like))
560 (let ((rows (num-rows a))
562 (mode (la-data-mode a)))
563 (let ((swept (sweep-in-place-front
565 (matrix-dimensions a 0)
566 (matrix-dimensions a 1)
568 (if (/= 0 swept) t nil))))
570 (defun sweep-operator (a columns &optional tolerances)
571 "Args: (a indices &optional tolerances)
573 A is a matrix, INDICES a sequence of the column indices to be
574 swept. Returns a list of the swept result and the list of the columns
575 actually swept. (See MULTREG documentation.) If supplied, TOLERANCES
576 should be a list of real numbers the same length as INDICES. An index
577 will only be swept if its pivot element is larger than the
578 corresponding element of TOLERANCES."
581 (if (not (typep columns 'sequence))
582 (setf columns (list columns)))
583 (check-sequence columns)
586 (if (not (typep tolerances 'sequence))
587 (setf tolerances (list tolerances)))
588 (check-sequence tolerances)))
591 (check-fixnum columns)
592 (if tolerances (check-real tolerances))
594 (result (copy-array a))
596 (columns (coerce columns 'list) (cdr columns))
597 (tolerances (if (consp tolerances) (coerce tolerances 'list))
598 (if (consp tolerances) (cdr tolerances))))
599 ((null columns) (list result swept-columns))
600 (let ((col (first columns))
601 (tol (if (consp tolerances) (first tolerances) tol)))
602 (if (sweep-in-place result col tol)
603 (setf swept-columns (cons col swept-columns))))))
612 (defun ax+y (a x y &optional lower)
613 "Args (a x y &optional lower)
614 Returns (+ (matmult A X) Y). If LOWER is not nil, A is taken to be lower
616 This could probably be made more efficient."
617 (check-square-matrix a)
623 (let* ((n (num-rows a))
624 (result (make-list n))
625 (a (compound-data-seq a)))
627 (if (or (/= n (length x)) (/= n (length y)))
628 (error "dimensions do not match"))
629 (do* ((tx (make-next-element x) (make-next-element x))
630 (ty (make-next-element y))
631 (tr (make-next-element result))
633 (start 0 (+ start n))
634 (end (if lower (+ i 1) n) (if lower (+ i 1) n)))
636 (declare (fixnum i start end))
637 (let ((val (get-next-element ty i)))
640 (setf val (+ val (* (get-next-element tx j)
641 (aref a (+ start j))))))
642 (set-next-element tr i val)))))
649 ;;;; Linear Algebra Functions
652 (defun matrix (dim data)
654 returns a matrix of dimensions DIM initialized using sequence DATA
656 (let ((dim (coerce dim 'list))
657 (data (coerce data 'list)))
658 (make-array dim :initial-contents (split-list data (nth 1 dim)))))
661 (length x)) ;; FIXME: defined badly!!
663 (defun print-matrix (a &optional (stream *standard-output*))
664 "Args: (matrix &optional stream)
665 Prints MATRIX to STREAM in a nice form that is still machine readable"
666 (unless (matrixp a) (error "not a matrix - ~a" a))
667 (let ((size (min 15 (max (map-elements #'flatsize a)))))
668 (format stream "#2a(~%")
669 (dolist (x (row-list a))
671 (let ((n (length x)))
673 (let ((y (aref x i)))
675 ((integerp y) (format stream "~vd" size y))
676 ((floatp y) (format stream "~vg" size y))
677 (t (format stream "~va" size y))))
678 (if (< i (- n 1)) (format stream " "))))
679 (format stream ")~%"))
680 (format stream " )~%")
685 Solves A x = B using LU decomposition and backsolving. B can be a sequence
687 (let ((lu (lu-decomp a)))
689 (apply #'bind-columns
690 (mapcar #'(lambda (x) (lu-solve lu x)) (column-list b)))
693 (defun backsolve (a b)
695 Solves A x = B by backsolving, assuming A is upper triangular. B must be a
696 sequence. For use with qr-decomp."
697 (let* ((n (length b))
698 (sol (make-array n)))
704 (setq val (- val (* (aref sol l) (aref a k l))))))
705 (setf (aref sol k) (/ val (aref a k k)))))
706 (if (listp b) (coerce sol 'list) sol)))
708 (defun eigenvalues (a)
710 Returns list of eigenvalues of square, symmetric matrix A"
713 (defun eigenvectors (a)
715 Returns list of eigenvectors of square, symmetric matrix A"
718 (defun accumulate (f s)
720 Accumulates elements of sequence S using binary function F.
721 (accumulate #'+ x) returns the cumulative sum of x."
722 (let* ((result (list (elt s 0)))
724 (flet ((acc (dummy x)
725 (rplacd tail (list (funcall f (first tail) x)))
726 (setf tail (cdr tail))))
728 (if (vectorp s) (coerce result 'vector) result)))
732 Returns the cumulative sum of X."
735 (defun combine (&rest args)
737 Returns sequence of elements of all arguments."
738 (copy-seq (element-seq args)))
740 (defun lowess (x y &key (f .25) (steps 2) (delta -1) sorted)
741 "Args: (x y &key (f .25) (steps 2) delta sorted)
742 Returns (list X YS) with YS the LOWESS fit. F is the fraction of data used for
743 each point, STEPS is the number of robust iterations. Fits for points within
744 DELTA of each other are interpolated linearly. If the X values setting SORTED
745 to T speeds up the computation."
746 (let ((x (if sorted x (sort-data x)))
747 (y (if sorted y (select y (order x))))
748 (delta (if (> delta 0.0) delta (/ (- (max x) (min x)) 50))))
749 (list x y delta f steps)));; (|base-lowess| x y f steps delta))))