Introduce crop rotations.

These will probably replace nutrient targets as the main entry point
for nutrient requirement calculations.

1 files changed, 138 insertions, 0 deletions

diff --git a/models/crop-rotation.rkt b/models/crop-rotation.rkt
new file mode 100644
index 0000000..abff080
--- /dev/null
+++ b/models/crop-rotation.rkt
@@ -0,0 +1,138 @@
+#lang racket
+
+(provide crop-rotation
+         crop-rotation?
+         crop-rotation-id
+         (rename-out [crop-rotation-rotation-date crop-rotation-date]
+                     [crop-rotation-requirement-proportions crop-rotation-requirements]
+                     [crop-rotation-nutrient-measurement-id crop-rotation-measurement-id])
+         (contract-out [create-crop-rotation!
+                        (->* (string? requirement-proportion-hash/c)
+                             (#:nutrient-measurement exact-nonnegative-integer?)
+                             crop-rotation?)]
+                       [get-crop-rotations (-> (listof crop-rotation?))]
+                       [get-crop-rotation
+                        (->* () (#:id crop-rotation-id? #:date string?) (or/c crop-rotation? #f))]
+                       [get-latest-crop-rotation (-> (or/c crop-rotation? #f))]
+                       [delete-crop-rotation! (-> crop-rotation-or-id/c void?)]))
+
+(require racket/contract
+         db
+         sql
+         "../db/conn.rkt"
+         "nutrient.rkt"
+         "crop-requirement.rkt")
+
+(struct crop-rotation (id rotation-date requirement-proportions nutrient-measurement-id)
+  #:transparent
+  #:guard (λ (id rotation-date requirement-proportions nutrient-measurement-id _)
+            (values id
+                    rotation-date
+                    requirement-proportions
+                    (if (sql-null? nutrient-measurement-id) #f nutrient-measurement-id))))
+
+(define crop-rotation-id? exact-nonnegative-integer?)
+(define crop-rotation-or-id/c (or/c crop-rotation? crop-rotation-id?))
+(define requirement-proportion-hash/c (hash/c crop-requirement? (between/c 0 100) #:immutable #t))
+
+(define (->cr-id cr-or-id)
+  (match cr-or-id
+    [(? crop-rotation-id? id) id]
+    [(crop-rotation id _ _ _) id]
+    [#f (error '->nt-id "#f can not be converted to an id")]))
+
+;; CREATE
+
+(define (create-crop-rotation! rotation-date
+                               requirement-proportions
+                               #:nutrient-measurement [nutrient-measurement-id #f])
+  (or (get-crop-rotation #:date rotation-date)
+      (with-tx
+       (if nutrient-measurement-id
+           (query-exec (current-conn)
+                       (insert #:into crop_rotations
+                               #:set [rotation_date ,rotation-date]
+                               [nutrient_measurement_id ,nutrient-measurement-id]))
+           (query-exec (current-conn)
+                       (insert #:into crop_rotations #:set [rotation_date ,rotation-date])))
+       (define cr-id
+         (query-value (current-conn)
+                      (select id #:from crop_rotations #:where (= rotation_date ,rotation-date))))
+       (for ([(r p) (in-hash requirement-proportions)])
+         (query-exec (current-conn)
+                     (insert #:into crop_rotation_requirements
+                             #:set [crop_rotation_id ,cr-id]
+                             [crop_requirement_id ,(crop-requirement-id r)]
+                             [proportion_percent ,p])))
+       (get-crop-rotation #:date rotation-date))))
+
+;; READ
+
+(define joined
+  (table-expr-qq (inner-join (as crop_rotations cr)
+                             (as crop_rotation_requirements crr)
+                             #:on (= crr.crop_rotation_id cr.id))))
+
+(define (residuals->requirement-proportion-hash residuals)
+  (for/hash ([r (in-list residuals)])
+    (match-define (vector requirement-id proportion) r)
+    (values requirement-id proportion)))
+
+(define (grouped-row->crop-rotation grouped-row)
+  (match-define (vector cr-id cr-rotation-date cr-nutrient-measurement-id residuals) grouped-row)
+  (crop-rotation cr-id
+                 cr-rotation-date
+                 (residuals->requirement-proportion-hash residuals)
+                 cr-nutrient-measurement-id))
+
+(define (get-crop-rotations)
+  (define grouped-rows
+    (query-rows (current-conn)
+                (select cr.id
+                        cr.rotation_date
+                        cr.nutrient_measurement_id
+                        crr.crop_requirement_id
+                        crr.proportion_percent
+                        #:from (TableExpr:AST ,joined)
+                        #:order-by cr.rotation_date
+                        #:desc)
+                #:group '#(0 1 2)))
+  (map grouped-row->crop-rotation grouped-rows))
+
+(define (get-crop-rotation #:id [cr-id #f] #:date [rotation-date #f])
+  (define where
+    (cond
+      [(and cr-id rotation-date)
+       (scalar-expr-qq (and (= cr.id ,cr-id) (= cr.rotation_date ,rotation-date)))]
+      [cr-id (scalar-expr-qq (= cr.id ,cr-id))]
+      [rotation-date (scalar-expr-qq (= cr.rotation_date ,rotation-date))]
+      [else (error 'get-crop-rotation "either #:id or #:date must be provided")]))
+  (define grouped-rows
+    (query-rows (current-conn)
+                (select cr.id
+                        cr.rotation_date
+                        cr.nutrient_measurement_id
+                        crr.crop_requirement_id
+                        crr.proportion_percent
+                        #:from (TableExpr:AST ,joined)
+                        #:where (ScalarExpr:AST ,where)
+                        #:order-by cr.rotation_date
+                        #:desc)
+                #:group '#(0 1 2)))
+  (match grouped-rows
+    ['() #f]
+    [(list grouped-row) (grouped-row->crop-rotation grouped-row)]
+    [many (error 'get-crop-rotation "expected 1 nutrient target, got ~a" (length many))]))
+
+(define (get-latest-crop-rotation)
+  (define rotations (get-crop-rotations))
+  (if (null? rotations)
+      #f
+      (first rotations)))
+
+;; UPDATE
+
+;; DELETE
+
+(define (delete-crop-rotation! cr-or-id)
+  (query-exec (current-conn) (delete #:from crop_rotations #:where (= id ,(->cr-id cr-or-id)))))