Commit f9157461 authored by Liam Healy's avatar Liam Healy
Browse files

Complete ntuple with test

Ported ntuple to cbinfo form with tests duplicating the GSL tests in
ntuple/test.c.
parent 9d7a0de3
;; Definition of GSLL system ;; Definition of GSLL system
;; Liam Healy ;; Liam Healy
;; Time-stamp: <2009-05-03 16:59:16EDT gsll-tests.asd> ;; Time-stamp: <2009-08-26 21:04:08EDT gsll-tests.asd>
(asdf:defsystem "gsll-tests" (asdf:defsystem "gsll-tests"
:name "gsll-tests" :name "gsll-tests"
...@@ -125,6 +125,7 @@ ...@@ -125,6 +125,7 @@
(:file "multinomial") (:file "multinomial")
(:file "negative-binomial") (:file "negative-binomial")
(:file "nonlinear-least-squares") (:file "nonlinear-least-squares")
(:file "ntuple")
(:file "numerical-differentiation") (:file "numerical-differentiation")
(:file "numerical-integration") (:file "numerical-integration")
(:file "ode") (:file "ode")
......
;; Definition of GSLL system ;; Definition of GSLL system
;; Liam Healy ;; Liam Healy
;; Time-stamp: <2009-06-07 08:33:27EDT gsll.asd> ;; Time-stamp: <2009-08-26 21:07:16EDT gsll.asd>
;; $Id$ ;; $Id$
(when (asdf:find-system :fsbv nil) (when (asdf:find-system :fsbv nil)
...@@ -183,8 +183,7 @@ ...@@ -183,8 +183,7 @@
(:file "statistics" :depends-on (histogram)) (:file "statistics" :depends-on (histogram))
(:file "operations" :depends-on (histogram)) (:file "operations" :depends-on (histogram))
(:file "probability-distribution" :depends-on (histogram)) (:file "probability-distribution" :depends-on (histogram))
;;(:file "ntuple") (:file "ntuple")))
))
(:module calculus (:module calculus
:depends-on (init data random) :depends-on (init data random)
:components :components
......
;; N-tuples ;; N-tuples
;; Liam Healy Sat Feb 3 2007 - 12:53 ;; Liam Healy Sat Feb 3 2007 - 12:53
n;; Time-stamp: <2009-07-04 22:20:15EDT ntuple.lisp> ;; Time-stamp: <2009-08-26 21:15:23EDT ntuple.lisp>
(in-package :gsl) (in-package :gsl)
...@@ -103,11 +103,11 @@ n;; Time-stamp: <2009-07-04 22:20:15EDT ntuple.lisp> ...@@ -103,11 +103,11 @@ n;; Time-stamp: <2009-07-04 22:20:15EDT ntuple.lisp>
(SETF PROJECT-NTUPLE-DYNFN0 (SETF PROJECT-NTUPLE-DYNFN0
(MAKE-COMPILED-FUNCALLABLE (MAKE-COMPILED-FUNCALLABLE
VALUE-FUNCTION VALUE-FUNCTION
'(SELECT-FUNCTION :POINTER (:INPUT :POINTER) :SLUG) NIL (LIST)) '(FUNCTION :double (:INPUT :POINTER) :SLUG) NIL (LIST))
PROJECT-NTUPLE-DYNFN1 PROJECT-NTUPLE-DYNFN1
(MAKE-COMPILED-FUNCALLABLE (MAKE-COMPILED-FUNCALLABLE
SELECT-FUNCTION SELECT-FUNCTION
'(SELECT-FUNCTION :POINTER (:INPUT :POINTER) :SLUG) NIL (LIST))) '(FUNCTION :boolean (:INPUT :POINTER) :SLUG) NIL (LIST)))
(SET-CBSTRUCT VALFN 'FNSTRUCT NIL (LIST 'FUNCTION 'PROJECT-NTUPLE-CBFN0)) (SET-CBSTRUCT VALFN 'FNSTRUCT NIL (LIST 'FUNCTION 'PROJECT-NTUPLE-CBFN0))
(SET-CBSTRUCT SELFN 'FNSTRUCT NIL (LIST 'FUNCTION 'PROJECT-NTUPLE-CBFN1)) (SET-CBSTRUCT SELFN 'FNSTRUCT NIL (LIST 'FUNCTION 'PROJECT-NTUPLE-CBFN1))
(LET ((CRETURN (LET ((CRETURN
...@@ -118,9 +118,9 @@ n;; Time-stamp: <2009-07-04 22:20:15EDT ntuple.lisp> ...@@ -118,9 +118,9 @@ n;; Time-stamp: <2009-07-04 22:20:15EDT ntuple.lisp>
(CHECK-GSL-STATUS CRETURN 'PROJECT-NTUPLE) (CHECK-GSL-STATUS CRETURN 'PROJECT-NTUPLE)
(VALUES)))) (VALUES))))
(DEFMCALLBACK PROJECT-NTUPLE-CBFN0 PROJECT-NTUPLE-DYNFN0 (DEFMCALLBACK PROJECT-NTUPLE-CBFN0 PROJECT-NTUPLE-DYNFN0
(VALUE-FUNCTION :POINTER (:INPUT :POINTER) :SLUG)) (VALUE-FUNCTION :double (:INPUT :POINTER) :SLUG))
(DEFMCALLBACK PROJECT-NTUPLE-CBFN1 PROJECT-NTUPLE-DYNFN1 (DEFMCALLBACK PROJECT-NTUPLE-CBFN1 PROJECT-NTUPLE-DYNFN1
(SELECT-FUNCTION :POINTER (:INPUT :POINTER) :SLUG)) (SELECT-FUNCTION :boolean (:INPUT :POINTER) :SLUG))
(MAP-NAME 'PROJECT-NTUPLE "gsl_ntuple_project") (MAP-NAME 'PROJECT-NTUPLE "gsl_ntuple_project")
(EXPORT 'PROJECT-NTUPLE)) (EXPORT 'PROJECT-NTUPLE))
...@@ -141,6 +141,15 @@ n;; Time-stamp: <2009-07-04 22:20:15EDT ntuple.lisp> ...@@ -141,6 +141,15 @@ n;; Time-stamp: <2009-07-04 22:20:15EDT ntuple.lisp>
;;; Examples and unit test ;;; Examples and unit test
;;; See gsl-1.11/ntuple/test.c ;;; See gsl-1.11/ntuple/test.c
(defparameter *ntuple-example-data-file*
(namestring
(merge-pathnames
"ntuple-example.dat"
(asdf:component-pathname
(asdf:find-component (asdf:find-system :gsll) "histogram"))))
"The full path string of the ntuple example data file. This can be created
with the function #'make-ntuple-example-data.")
(defcstruct ntuple-data (defcstruct ntuple-data
(num :int) (num :int)
(x :double) (x :double)
...@@ -153,7 +162,8 @@ n;; Time-stamp: <2009-07-04 22:20:15EDT ntuple.lisp> ...@@ -153,7 +162,8 @@ n;; Time-stamp: <2009-07-04 22:20:15EDT ntuple.lisp>
(let ((xi (/ (+ i 1.5d0)))) (let ((xi (/ (+ i 1.5d0))))
(values xi (expt xi 2) (expt xi 3)))) (values xi (expt xi 2) (expt xi 3))))
(defun make-ntuple-example-data (&optional (filename "test.dat")) (defun make-ntuple-example-data
(&optional (filename *ntuple-example-data-file*))
(cffi:with-foreign-object (data 'ntuple-data) (cffi:with-foreign-object (data 'ntuple-data)
(let ((ntuple (create-ntuple filename data 'ntuple-data)) (let ((ntuple (create-ntuple filename data 'ntuple-data))
(answer (make-array 100 :element-type 'fixnum :initial-element 0))) (answer (make-array 100 :element-type 'fixnum :initial-element 0)))
...@@ -170,44 +180,48 @@ n;; Time-stamp: <2009-07-04 22:20:15EDT ntuple.lisp> ...@@ -170,44 +180,48 @@ n;; Time-stamp: <2009-07-04 22:20:15EDT ntuple.lisp>
(close-ntuple ntuple) (close-ntuple ntuple)
answer))) answer)))
(defun ntuple-example-read (&optional (filename "test.dat")) (defun ntuple-example-read (&optional (filename *ntuple-example-data-file*))
(cffi:with-foreign-object (data 'ntuple-data) (cffi:with-foreign-object (data 'ntuple-data)
(let ((ntuple (open-ntuple filename data 'ntuple-data))) (let ((ntuple (open-ntuple filename data 'ntuple-data)))
(dotimes (row 1000) (prog1
(multiple-value-bind (xi yi zi) (dotimes (row 1000 t)
(ntuple-example-values row) (multiple-value-bind (xi yi zi)
(read-ntuple ntuple) (ntuple-example-values row)
(unless (read-ntuple ntuple)
(and (eql row (cffi:foreign-slot-value data 'ntuple-data 'num)) (unless
(eql xi (cffi:foreign-slot-value data 'ntuple-data 'x)) (and (eql row (cffi:foreign-slot-value data 'ntuple-data 'num))
(eql yi (cffi:foreign-slot-value data 'ntuple-data 'y)) (eql xi (cffi:foreign-slot-value data 'ntuple-data 'x))
(eql zi (cffi:foreign-slot-value data 'ntuple-data 'z))) (eql yi (cffi:foreign-slot-value data 'ntuple-data 'y))
(error "Ntuple test failed.")))) (eql zi (cffi:foreign-slot-value data 'ntuple-data 'z)))
(close-ntuple ntuple) (return nil))))
T))) (close-ntuple ntuple)))))
(defun ntuple-example-sel-func (ntuple-data) (defun ntuple-example-sel-func (ntuple-data)
(< (* (cffi:foreign-slot-value ntuple-data 'ntuple-data 'x) (< (* (cffi:foreign-slot-value ntuple-data 'ntuple-data 'x)
*ntuple-example-scale*) *ntuple-example-scale*)
0.1d0)) 0.1d0))
(defun ntuple-example-val-func (ntuple-data) (defun ntuple-example-val-func (ntuple-data)
(< (* (+ (cffi:foreign-slot-value ntuple-data 'ntuple-data 'x) (* (+ (cffi:foreign-slot-value ntuple-data 'ntuple-data 'x)
(cffi:foreign-slot-value ntuple-data 'ntuple-data 'y) (cffi:foreign-slot-value ntuple-data 'ntuple-data 'y)
(cffi:foreign-slot-value ntuple-data 'ntuple-data 'z)) (cffi:foreign-slot-value ntuple-data 'ntuple-data 'z))
*ntuple-example-scale*) *ntuple-example-scale*))
0.1d0))
(defun ntuple-example-histogramming (&optional (filename "test.dat")) (defun ntuple-example-histogramming
(&optional (filename *ntuple-example-data-file*))
(cffi:with-foreign-object (data 'ntuple-data) (cffi:with-foreign-object (data 'ntuple-data)
(let ((histo (make-histogram 100)) (let ((histo (make-histogram 100))
(ntuple (open-ntuple filename data 'ntuple-data)) (ntuple (open-ntuple filename data 'ntuple-data))
(answer (make-ntuple-example-data filename))) (answer (make-ntuple-example-data filename)))
(set-ranges-uniform histo 0.0d0 1.0d0) (set-ranges-uniform histo 0.0d0 1.0d0)
(project-ntuple (project-ntuple
histo ntuple 'ntuple-example-sel-func 'ntuple-example-val-func) histo ntuple 'ntuple-example-val-func 'ntuple-example-sel-func)
(close-ntuple ntuple) (close-ntuple ntuple)
;; Check the histogram to see if it matches ntuple-example-values ;; Check the histogram to see if it matches ntuple-example-values
(dotimes (row 100) (dotimes (row 100 t)
(unless (eql (maref histo row) (aref answer row)) (unless (= (maref histo row) (aref answer row))
(error "Histogramming ntuple test failed for row=~d." row)))))) (return nil))))))
(save-test ntuple
(ntuple-example-read)
(ntuple-example-histogramming))
;; Regression test NTUPLE for GSLL, automatically generated
(in-package :gsl)
(LISP-UNIT:DEFINE-TEST NTUPLE
(LISP-UNIT:ASSERT-true (NTUPLE-EXAMPLE-READ))
(LISP-UNIT:ASSERT-true (NTUPLE-EXAMPLE-HISTOGRAMMING)))
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment