diff options
Diffstat (limited to 'models/crop-requirement.rkt')
| -rw-r--r-- | models/crop-requirement.rkt | 53 |
1 files changed, 24 insertions, 29 deletions
diff --git a/models/crop-requirement.rkt b/models/crop-requirement.rkt index 2048091..7d7b5aa 100644 --- a/models/crop-requirement.rkt +++ b/models/crop-requirement.rkt @@ -6,20 +6,19 @@ crop-requirement-profile crop-requirement-crop-id (rename-out [crop-requirement-nutrient-values crop-requirement-values]) - (contract-out - [create-crop-requirement! - (->* (string? (listof nutrient-value-pair/c)) ((or/c #f crop?)) crop-requirement?)] - [get-crop-requirements (-> (listof crop-requirement?))] - [get-crop-requirement - (->* () - (#:id (or/c #f exact-nonnegative-integer?) #:profile (or/c #f string?)) - (or/c crop-requirement? #f))] - [get-crop-requirement-values (-> crop-requirement? (listof nutrient-value-pair/c))] - [get-crop-requirement-value (-> crop-requirement? nutrient? number?)] - [delete-crop-requirement! (-> crop-requirement? void?)] - [average-crop-requirement-nutrient-values - (-> (listof (cons/c crop-requirement? (and/c real? (>=/c 0) (<=/c 100)))) - (listof nutrient-value-pair/c))])) + (contract-out [create-crop-requirement! + (->* (string? nutrient-value-hash/c) ((or/c #f crop?)) crop-requirement?)] + [get-crop-requirements (-> (listof crop-requirement?))] + [get-crop-requirement + (->* () + (#:id (or/c #f exact-nonnegative-integer?) #:profile (or/c #f string?)) + (or/c crop-requirement? #f))] + [get-crop-requirement-values (-> crop-requirement? nutrient-value-hash/c)] + [get-crop-requirement-value (-> crop-requirement? nutrient? number?)] + [delete-crop-requirement! (-> crop-requirement? void?)] + [average-crop-requirement-nutrient-values + (-> (listof (cons/c crop-requirement? (and/c real? (>=/c 0) (<=/c 100)))) + nutrient-value-hash/c)])) (require racket/contract db @@ -50,8 +49,7 @@ (define nvs-id (query-value (current-conn) (select id #:from nutrient_value_sets #:where (= crop_requirement_id ,cr-id)))) - (for ([nv nutrient-values]) - (match-define (cons n v) nv) + (for ([(n v) (in-hash nutrient-values)]) (query-exec (current-conn) (insert #:into nutrient_values #:set [value_set_id ,nvs-id] @@ -72,8 +70,7 @@ (define (grouped-row->crop-requirement row) (match-define (vector cr-id profile crop-id residuals) row) - (define nutrient-value-pairs (residuals->nutrient-value-pairs residuals)) - (crop-requirement cr-id profile crop-id nutrient-value-pairs)) + (crop-requirement cr-id profile crop-id (residuals->nutrient-value-hash residuals))) (define (get-crop-requirements) (define grouped-rows @@ -121,7 +118,7 @@ [many (error 'get-crop-requirement "expected 1 crop requirement, got ~a" (length many))])) (define (get-crop-requirement-values crop-requirement) - (for/list ([(nutrient-id name formula value_ppm) + (for/hash ([(nutrient-id name formula value_ppm) (in-query (current-conn) (select n.id n.canonical_name @@ -129,7 +126,7 @@ nv.value_ppm #:from (TableExpr:AST ,joined) #:where (= cr.id ,(crop-requirement-id crop-requirement))))]) - (cons (nutrient nutrient-id name formula) value_ppm))) + (values (nutrient nutrient-id name formula) value_ppm))) (define (get-crop-requirement-value crop-requirement nutrient) (query-maybe-value (current-conn) @@ -149,12 +146,10 @@ ;; Helpers (define (average-crop-requirement-nutrient-values mix) - (define average-values - (for/fold ([acc (hash)]) ([pair (in-list mix)]) - (match-define (cons crop-requirement percentage) pair) - (for/fold ([acc acc]) ([nv (in-list (get-crop-requirement-values crop-requirement))]) - (match-define (cons n v) nv) - (define nutrient-contribution (* v (/ percentage 100))) - (hash-update acc n (λ (old) (+ old nutrient-contribution)) (λ () nutrient-contribution))))) - (for/list ([(n v) (in-hash average-values)]) - (cons n v))) + (for/fold ([acc (hash)]) ([pair (in-list mix)]) + (match-define (cons crop-requirement percentage) pair) + (define weight (/ percentage 100.0)) + (for/fold ([acc acc]) + ([(nutrient value) (in-hash (crop-requirement-nutrient-values crop-requirement))]) + (define contribution (* value weight)) + (hash-update acc nutrient (λ (old) (+ old contribution)) (λ () contribution))))) |