source: project/release/4/spatial-trees/trunk/tests/run.scm @ 26908

Last change on this file since 26908 was 26908, checked in by Ivan Raikov, 9 years ago

spatial-trees: incorporated vector sorting procedures in f64vector->kd-tree

File size: 4.7 KB
Line 
1;; Unit tests for kd-tree
2
3
4(use typeclass kd-tree test srfi-1 random-mtzig)
5
6
7
8(define=> (make-consistency-tests <Point> <KdTree>)
9  (lambda (pts t x k r)
10
11    (define (sort-points pts) 
12      (sort pts (lambda (a b) (negative? (compare-distance x a b)))))
13    (define sorted-points (sort-points pts))
14    (define sliced-points (sort-points (filter (lambda (p) (and (<= 0. (coord 0 p)) (<= (coord 0 p) 0.5))) pts)))
15    (define tree-points (sort-points (kd-tree->list t)))
16    (define tree-points-indices (kd-tree->list* t))
17
18    (define nn (car sorted-points))
19
20    (define knn (if (> (length sorted-points) k)
21                    (take sorted-points k) 
22                    sorted-points))
23
24    (define rnn (let ((r2 (* r r)))
25                  (sort-points
26                   (filter
27                    (lambda (y) (<= (dist2 x y) r2))
28                    sorted-points)
29                  )))
30
31#|
32    (define scale-factors '(1.0 0.5 1.0))
33
34    (define (compare-scaled-distance p a b . reltol)
35      (let ((dist2 (sdist2 scale-factors)))
36        (let ((delta (- (dist2 p a) (dist2 p b))))
37          (if (null? reltol)
38              delta
39              (if (<= delta (car reltol)) 0 delta)))))
40
41    (define (sort-scaled-points pts)
42      (sort pts (lambda (a b) (negative? (compare-scaled-distance x a b)))))
43   
44    (define srnn (let ((r2 (* r r))  (dist2 (sdist2 scale-factors)))
45                   (sort-scaled-points
46                    (filter
47                     (lambda (y) (<= (dist2 x y) r2))
48                     (sort-scaled-points sorted-points))
49                    )))
50|#
51   
52    (test-group
53     "KD tree consistency"
54     
55     (test-assert "monotonically increasing indices"
56           (sorted? tree-points-indices (lambda (x y) (< (car x) (car y)))))
57
58     (test-assert "tree-is-valid?"
59           (kd-tree-is-valid? t))
60
61     (test-assert "tree-all-subtrees-are-valid?"
62           (kd-tree-all-subtrees-are-valid? t))
63
64     (test "kd-tree->list"
65          sorted-points tree-points)
66
67     (test "nearest-neighbor"
68           nn
69           (kd-tree-nearest-neighbor t x))
70
71     (test "nearest-neighbor*"
72           (list (list-index (lambda (x) (equal? (cadr x) nn)) tree-points-indices) nn)
73           (kd-tree-nearest-neighbor* t x))
74
75     (test "k-nearest-neighbors"
76           knn
77           (sort-points (kd-tree-k-nearest-neighbors t k x)))
78     
79     (test "near-neighbors"
80           rnn
81           (sort-points (kd-tree-near-neighbors t r x)))
82
83#|
84     (test "near-neighbors scaled"
85           srnn
86           (sort-scaled-points (kd-tree-near-neighbors t r x factors: scale-factors)))
87|#
88     (test "slice"
89           sliced-points
90           (sort-points (kd-tree-slice 0 0. 0.5 t)))
91     )))
92
93(define consistency-tests/3d (make-consistency-tests Point3d KdTree3d))
94(define consistency-tests/2d (make-consistency-tests Point2d KdTree2d))
95
96
97(define (test1)
98  (let ((n 1000) (k 40) (r 0.2) (randst (random-mtzig:init)))
99 
100  (let recur ((ntrials 2))
101    (let* ((xs (random-mtzig:f64vector-randn! n randst))
102           (ys (random-mtzig:f64vector-randn! n randst))
103           (zs (random-mtzig:f64vector-randn! n randst))
104           (pts (let precur ((i (- n 1)) (ax '()))
105                  (let ((p (make-point (f64vector-ref xs i)
106                                       (f64vector-ref ys i)
107                                       (f64vector-ref zs i))))
108                    (if (positive? i)
109                        (precur (- i 1) (cons p ax))
110                        (cons p ax)))))
111           (t     (with-instance ((<KdTree> KdTree3d)) (list->kd-tree pts leaf-factor: 20)))
112           (dd    (print "tree constructed!"))
113           (xi    (inexact->exact (modulo (random-mtzig:random! randst) n)))
114           (x     (list-ref pts xi))
115           (xx    (with-instance ((<Point> Point3d)) 
116                                 (make-point (+ 0.1 (coord 0 x)) 
117                                             (- (coord 1 x) 0.1) 
118                                             (+ 0.1 (coord 2 x)))))
119           )
120
121      (consistency-tests/3d pts t xx k r)
122;;      (consistency-tests/2d pts t xx k r)
123
124      (if (positive? ntrials)
125          (recur (- ntrials 1)))
126      ))
127  ))
128
129
130(define (test2)
131  (let ((n 100000) (k 40) (r 0.2) (randst (random-mtzig:init)))
132 
133  (let recur ((ntrials 1))
134    (let ((xs (random-mtzig:f64vector-randn! n randst))
135          (ys (random-mtzig:f64vector-randn! n randst))
136          (zs (random-mtzig:f64vector-randn! n randst)))
137
138      (let* (
139             (axv   (list xs ys zs))
140             (t     (with-instance ((<KdTree> KdTree3d)) (f64vector->kd-tree axv leaf-factor: 300)))
141             (dd    (print "tree constructed!"))
142             (pts (let precur ((i (- n 1)) (ax '()))
143                  (let ((p (make-point (f64vector-ref xs i)
144                                       (f64vector-ref ys i)
145                                       (f64vector-ref zs i))))
146                    (if (positive? i)
147                        (precur (- i 1) (cons p ax))
148                        (cons p ax)))))
149             (xi    (inexact->exact (modulo (random-mtzig:random! randst) n)))
150             (x     (list-ref pts xi))
151             (xx    (with-instance ((<Point> Point3d)) 
152                                   (make-point (+ 0.1 (coord 0 x)) 
153                                               (- (coord 1 x) 0.1) 
154                                               (+ 0.1 (coord 2 x)))))
155             )
156
157;;      (print (with-instance ((<KdTree> KdTree3d)) (kd-tree->list* t)))
158        (consistency-tests/3d pts t xx k r)
159        ;;      (consistency-tests/2d pts t xx k r)
160       
161        (if (positive? ntrials)
162            (recur (- ntrials 1)))
163        )))
164  ))
165
166
167(test1)
168(test2)
Note: See TracBrowser for help on using the repository browser.