[Racket] Ferti hydroponic nutrient solver, redux.
raco fmt.
services/nnls.rkt
@@ -20,23 +20,16 @@
20
20
(define nutrients (get-nutrients))
21
21
(define fertilizer-product-matrix (get-fertilizer-product-matrix nutrients fertilizers))
22
22
(define deficits
23
Removed:
(->col-matrix
24
Removed:
(for/list ([n nutrients])
25
Removed:
(define latest-measurement (get-latest-nutrient-measurement-value n))
26
Removed:
(define latest-target (get-latest-nutrient-target-value n))
27
Removed:
(define deficit
28
Removed:
(cond
29
Removed:
[(false? latest-target)
30
Removed:
0]
31
Removed:
[(or (false? latest-measurement)
32
Removed:
(zero? latest-measurement))
33
Removed:
latest-target]
34
Removed:
[(and (number? latest-measurement)
35
Removed:
(number? latest-target))
36
Removed:
(* 100
37
Removed:
(/ (- latest-target latest-measurement)
38
Removed:
latest-measurement))]))
39
Removed:
deficit)))
23
Added:
(->col-matrix (for/list ([n nutrients])
24
Added:
(define latest-measurement (get-latest-nutrient-measurement-value n))
25
Added:
(define latest-target (get-latest-nutrient-target-value n))
26
Added:
(define deficit
27
Added:
(cond
28
Added:
[(false? latest-target) 0]
29
Added:
[(or (false? latest-measurement) (zero? latest-measurement)) latest-target]
30
Added:
[(and (number? latest-measurement) (number? latest-target))
31
Added:
(* 100 (/ (- latest-target latest-measurement) latest-measurement))]))
32
Added:
deficit)))
40
33
(define error-threshold 10e-4)
41
34
(lawson-hanson-1974 fertilizer-product-matrix deficits error-threshold))
42
35
@@ -46,16 +39,14 @@
46
39
;; Inputs
47
40
;;;;;;;;;
48
41
49
Removed:
(-> matrix? ; Real-valued matrix A of dimension m × n
42
Added:
(-> matrix? ; Real-valued matrix A of dimension m × n
50
43
col-matrix? ; Real-valued column matrix (vector) y of dimension m
51
Removed:
real? ; Real-value ɛ, tolerance for the stopping criterion
52
Removed:
col-matrix?) ; Real-valued solution column matrix x
53
Removed:
(define-values
54
Removed:
(m ; Number of nutrients
55
Removed:
n) ; Number of fertilizer products
44
Added:
real? ; Real-value ɛ, tolerance for the stopping criterion
45
Added:
col-matrix?) ; Real-valued solution column matrix x
46
Added:
(define-values (m ; Number of nutrients
47
Added:
n) ; Number of fertilizer products
56
48
(matrix-shape A))
57
49
58
Removed:
59
50
;;;;;;;;;;;;;
60
51
;; Initialize
61
52
;;;;;;;;;;;;;
@@ -70,12 +61,12 @@
70
61
71
62
;; Gradient-like vector for residual error.
72
63
(define (compute-w x)
73
Removed:
(matrix* (matrix-transpose A)
74
Removed:
(matrix- y (matrix* A x))))
64
Added:
(matrix* (matrix-transpose A) (matrix- y (matrix* A x))))
75
65
76
66
;; max over j in R of w_j, returning (values max-val j*)
77
67
(define (max-w-in-R w)
78
Removed:
(for/fold ([max-val -inf.0] [max-j #f])
68
Added:
(for/fold ([max-val -inf.0]
69
Added:
[max-j #f])
79
70
([j (in-set R)])
80
71
(define v (colv-ref w j))
81
72
(if (> v max-val)
@@ -88,24 +79,25 @@
88
79
(if (set-empty? P)
89
80
(make-matrix n 1 0)
90
81
(let* ([idxs (sort (set->list P) <)]
91
Removed:
[AP (submatrix A (::) idxs)]
92
Removed:
[sP (matrix* (matrix-inverse
93
Removed:
(matrix* (matrix-transpose AP) AP))
94
Removed:
(matrix-transpose AP)
95
Removed:
y)])
82
Added:
[AP (submatrix A (::) idxs)]
83
Added:
[sP (matrix* (matrix-inverse (matrix* (matrix-transpose AP) AP))
84
Added:
(matrix-transpose AP)
85
Added:
y)])
96
86
;; map: column index j in P -> corresponding sP entry
97
87
(define mapping
98
Removed:
(for/list ([j idxs] [k (in-naturals)])
88
Added:
(for/list ([j idxs]
89
Added:
[k (in-naturals)])
99
90
(cons j (colv-ref sP k))))
100
91
(define (s-at i)
101
92
(define p (assoc i mapping))
102
Removed:
(if p (cdr p) 0))
93
Added:
(if p
94
Added:
(cdr p)
95
Added:
0))
103
96
(build-matrix n 1 (λ (i j) (s-at i))))))
104
97
105
98
;; The "first try" x represents no addition of any fertilizer.
106
99
(define x (make-matrix n 1 0))
107
100
108
Removed:
109
101
;;;;;;;;;;;;;
110
102
;; Outer loop
111
103
;;;;;;;;;;;;;
@@ -115,16 +107,14 @@
115
107
116
108
(cond
117
109
;; If no remaining candidates in R, we're done.
118
Removed:
[(set-empty? R)
119
Removed:
x]
110
Added:
[(set-empty? R) x]
120
111
121
112
[else
122
113
(define-values (max-val j*) (max-w-in-R w))
123
114
124
115
;; Stopping criterion: max(w_R) <= ε
125
116
(cond
126
Removed:
[(or (not j*) (<= max-val ε))
127
Removed:
x]
117
Added:
[(or (not j*) (<= max-val ε)) x]
128
118
129
119
[else
130
120
;; Add j* to P, remove from R
@@ -139,8 +129,7 @@
139
129
(define min-sP
140
130
(if (set-empty? P)
141
131
+inf.0
142
Removed:
(for/fold ([mn +inf.0])
143
Removed:
([j (in-set P)])
132
Added:
(for/fold ([mn +inf.0]) ([j (in-set P)])
144
133
(min mn (colv-ref s j)))))
145
134
146
135
(cond
@@ -152,11 +141,10 @@
152
141
[else
153
142
;; Compute α = min_{i in P, s_i <= 0} x_i / (x_i - s_i)
154
143
(define α
155
Removed:
(for/fold ([a +inf.0])
156
Removed:
([j (in-set P)])
144
Added:
(for/fold ([a +inf.0]) ([j (in-set P)])
157
145
(define sj (colv-ref s j))
158
146
(if (<= sj 0)
159
Removed:
(let* ([xj (colv-ref x j)]
147
Added:
(let* ([xj (colv-ref x j)]
160
148
[den (- xj sj)])
161
149
(if (> den 0)
162
150
(min a (/ xj den))
@@ -167,8 +155,7 @@
167
155
(error 'lawson-hanson-1974 "no valid α in inner loop"))
168
156
169
157
;; x ← x + α (s − x)
170
Removed:
(define new-x
171
Removed:
(matrix+ x (matrix* α (matrix- s x))))
158
Added:
(define new-x (matrix+ x (matrix* α (matrix- s x))))
172
159
173
160
;; Move to R all indices j in P with x_j <= 0
174
161
(define to-remove '())
@@ -189,9 +176,10 @@
189
176
(λ (i j)
190
177
(define selected-nutrient (list-ref nutrients i))
191
178
(define product (list-ref fertilizers j))
192
Removed:
(define pair (assoc selected-nutrient
193
Removed:
(fertilizer-product-values product)))
194
Removed:
(if pair (cdr pair) 0))))
179
Added:
(define pair (assoc selected-nutrient (fertilizer-product-values product)))
180
Added:
(if pair
181
Added:
(cdr pair)
182
Added:
0))))
195
183
196
184
(module+ test
197
185
(require rackunit
@@ -202,35 +190,23 @@
202
190
(define test-date "2025-01-01")
203
191
204
192
(run-tests
205
Removed:
(test-suite
206
Removed:
"Nutrient measurement model"
207
Removed:
#:before (λ ()
208
Removed:
(connect! #:path 'memory)
209
Removed:
;; (connect! #:path "test.sqlite3")
210
Removed:
(migrate-all!)
193
Added:
(test-suite "Nutrient measurement model"
194
Added:
#:before
195
Added:
(λ ()
196
Added:
(connect! #:path 'memory)
197
Added:
;; (connect! #:path "test.sqlite3")
198
Added:
(migrate-all!)
211
199
212
Removed:
(define nitrogen (create-nutrient! "Nitrogen" "N"))
213
Removed:
(define phosphorus (create-nutrient! "Phosphorus" "P"))
200
Added:
(define nitrogen (create-nutrient! "Nitrogen" "N"))
201
Added:
(define phosphorus (create-nutrient! "Phosphorus" "P"))
214
202
215
Removed:
(create-nutrient-measurement! test-date
216
Removed:
`((,nitrogen . 0)
217
Removed:
(,phosphorus . 0)))
218
Removed:
(create-nutrient-target! test-date
219
Removed:
`((,nitrogen . 100)
220
Removed:
(,phosphorus . 50)))
203
Added:
(create-nutrient-measurement! test-date `((,nitrogen . 0) (,phosphorus . 0)))
204
Added:
(create-nutrient-target! test-date `((,nitrogen . 100) (,phosphorus . 50)))
221
205
222
Removed:
(create-fertilizer-product! "King Nitrogen"
223
Removed:
`((,nitrogen . 100)))
224
Removed:
(create-fertilizer-product! "Phosphorescent Baboon"
225
Removed:
`((,nitrogen . 10)
226
Removed:
(,phosphorus . 100)))
227
Removed:
(create-fertilizer-product! "John's Phosphorus"
228
Removed:
`((,nitrogen . 3)
229
Removed:
(,phosphorus . 30))))
230
Removed:
#:after (λ ()
231
Removed:
(disconnect!))
206
Added:
(create-fertilizer-product! "King Nitrogen" `((,nitrogen . 100)))
207
Added:
(create-fertilizer-product! "Phosphorescent Baboon" `((,nitrogen . 10) (,phosphorus . 100)))
208
Added:
(create-fertilizer-product! "John's Phosphorus" `((,nitrogen . 3) (,phosphorus . 30))))
209
Added:
#:after (λ () (disconnect!))
232
210
233
Removed:
(test-case "Solve for NNLS"
234
Removed:
(displayln
235
Removed:
(format "Final solution for fertilizers is combination ~a"
236
Removed:
(find-ferti-recipe)))))))
211
Added:
(test-case "Solve for NNLS"
212
Added:
(displayln (format "Final solution for fertilizers is combination ~a" (find-ferti-recipe)))))))