#lang racket (provide nutrient-measurement nutrient-measurement? nutrient-measurement-id (rename-out [nutrient-measurement-measured-on nutrient-measurement-date] [nutrient-measurement-nutrient-values nutrient-measurement-values]) (contract-out [create-nutrient-measurement! (-> string? nutrient-value-hash/c nutrient-measurement?)] [get-nutrient-measurements (-> (listof nutrient-measurement?))] [get-nutrient-measurement (->* () (#:id (or/c #f exact-nonnegative-integer?) #:measured-on (or/c #f string?)) (or/c nutrient-measurement? #f))] [get-nutrient-measurement-values (-> nutrient-measurement-or-id/c nutrient-value-hash/c)] [get-nutrient-measurement-value (-> nutrient-measurement-or-id/c nutrient? (or/c real? #f))] [get-latest-nutrient-measurement-value (-> nutrient? (or/c real? #f))] [get-latest-nutrient-measurement-hash (-> nutrient-value-hash/c)] [delete-nutrient-measurement! (-> nutrient-measurement-or-id/c void?)])) (require racket/contract db sql "../db/conn.rkt" "nutrient.rkt") (struct nutrient-measurement (id measured-on nutrient-values) #:transparent #:property prop:custom-write (λ (v out _) (fprintf out "Measurement #~a on ~a\n" (nutrient-measurement-id v) (nutrient-measurement-measured-on v)) (for ([(n v) (in-hash (nutrient-measurement-nutrient-values v))]) (fprintf out "~a ~a\n" (~a (nutrient-canonical-name n) #:min-width 14) (~a v #:max-width 6 #:align 'right))))) (define nutrient-measurement-id? exact-nonnegative-integer?) (define nutrient-measurement-or-id/c (or/c nutrient-measurement? nutrient-measurement-id?)) (define (->nm-id nm-or-id) (match nm-or-id [(? nutrient-measurement-id? id) id] [(nutrient-measurement id _ _) id])) ;; CREATE (define (create-nutrient-measurement! measured-on nutrient-values) (or (get-nutrient-measurement #:measured-on measured-on) (with-tx (query-exec (current-conn) (insert #:into nutrient_measurements #:set [measured_on ,measured-on])) (define nm-id (query-value (current-conn) (select id #:from nutrient_measurements #:where (= measured_on ,measured-on)))) (query-exec (current-conn) (insert #:into nutrient_value_sets #:set [nutrient_measurement_id ,nm-id])) (define nvs-id (query-value (current-conn) (select id #:from nutrient_value_sets #:where (= nutrient_measurement_id ,nm-id)))) (for ([(n v) (in-hash nutrient-values)]) (query-exec (current-conn) (insert #:into nutrient_values #:set [value_set_id ,nvs-id] [nutrient_id ,(nutrient-id n)] [value_ppm ,v]))) (get-nutrient-measurement #:measured-on measured-on)))) ;; READ (define joined (table-expr-qq (inner-join (inner-join (inner-join (as nutrient_measurements nm) (as nutrient_value_sets nvs) #:on (= nvs.nutrient_measurement_id nm.id)) (as nutrient_values nv) #:on (= nv.value_set_id nvs.id)) (as nutrients n) #:on (= n.id nv.nutrient_id)))) (define (grouped-row->nutrient-measurement row) (match-define (vector nm-id measured-on residuals) row) (nutrient-measurement nm-id measured-on (residuals->nutrient-value-hash residuals))) (define (get-nutrient-measurements) (define grouped-rows (query-rows (current-conn) (select nm.id nm.measured_on n.id n.canonical_name n.french_name n.formula nv.value_ppm #:from (TableExpr:AST ,joined) #:order-by nm.measured_on #:desc) #:group '#(0 1))) (for/list ([row grouped-rows]) (grouped-row->nutrient-measurement row))) (define (get-nutrient-measurement #:id [nm-id #f] #:measured-on [measured-on #f]) (define where (cond [(and nm-id measured-on) (scalar-expr-qq (and (= nm.id ,nm-id) (= nm.measured_on ,measured-on)))] [nm-id (scalar-expr-qq (= nm.id ,nm-id))] [measured-on (scalar-expr-qq (= nm.measured_on ,measured-on))] [else (error 'get-nutrient-measurement "either #:id or #:measured-on must be provided")])) (define grouped-rows (query-rows (current-conn) (select nm.id nm.measured_on n.id n.canonical_name n.french_name n.formula nv.value_ppm #:from (TableExpr:AST ,joined) #:where (ScalarExpr:AST ,where) #:order-by nm.measured_on #:desc) #:group '#(0 1))) (match grouped-rows ['() #f] [(list row) (grouped-row->nutrient-measurement row)] [many (error 'get-nutrient-measurement "expected 1 nutrient measurement, got ~a" (length many))])) (define (get-nutrient-measurement-values nm-or-id) (for/hash ([(nutrient-id canonical-name french-name formula value_ppm) (in-query (current-conn) (select n.id n.canonical_name n.french_name n.formula nv.value_ppm #:from (TableExpr:AST ,joined) #:where (= nm.id ,(->nm-id nm-or-id))))]) (values (nutrient nutrient-id canonical-name french-name formula) value_ppm))) (define (get-nutrient-measurement-value nm-or-id nutrient) (query-maybe-value (current-conn) (select value_ppm #:from (TableExpr:AST ,joined) #:where (and (= nm.id ,(->nm-id nm-or-id)) (= nv.nutrient_id ,(nutrient-id nutrient)))))) (define (get-latest-nutrient-measurement-value nutrient) (query-maybe-value (current-conn) (select value_ppm #:from (TableExpr:AST ,joined) #:where (= nv.nutrient_id ,(nutrient-id nutrient)) #:order-by nm.measured_on #:desc #:limit 1))) (define (get-latest-nutrient-measurement-hash) (define grouped-rows (query-rows (current-conn) (select n.id n.canonical_name n.french_name n.formula nm.measured_on nv.value_ppm #:from (TableExpr:AST ,joined) #:order-by nm.measured_on #:desc) #:group '(#(0 1 2 3)))) (for/hash ([row grouped-rows]) (match-define (vector n-id n-canonical-name n-french-name n-formula residual-rows) row) ;; residual-rows is a non-empty list of vectors: #(measured_on value_ppm) (match-define (vector _measured-on value-ppm) (first residual-rows)) (values (nutrient n-id n-canonical-name n-french-name n-formula) value-ppm))) ;; UPDATE ;; DELETE (define (delete-nutrient-measurement! nm-or-id) (query-exec (current-conn) (delete #:from nutrient_measurements #:where (= id ,(->nm-id nm-or-id))))) (module+ test (require rackunit rackunit/text-ui "../db/conn.rkt" "../db/migrations.rkt" "../models/nutrient.rkt") (define measurement-date "2025-09-01") (run-tests (test-suite "Nutrient measurement model" #:before (λ () (connect! #:path 'memory) ;; (connect! #:path "test.sqlite3") (migrate-all!) (create-nutrient! "Nitrogen" "" "N") (create-nutrient! "Phosphorus" "" "P") (create-nutrient! "Potassium" "" "K")) #:after (λ () (disconnect!)) (test-case "Create measurement with date and values" (define nitrogen (get-nutrient #:name "Nitrogen")) (define phosphorus (get-nutrient #:name "Phosphorus")) (create-nutrient-measurement! measurement-date (hash nitrogen 12.3 phosphorus 4.5)) (check-equal? (length (get-nutrient-measurements)) 1) (define nm (get-nutrient-measurement #:measured-on measurement-date)) (check-true (nutrient-measurement? nm)) (check-equal? (nutrient-measurement-measured-on nm) measurement-date)) (test-case "Check all measurement values" (define nitrogen (get-nutrient #:name "Nitrogen")) (define phosphorus (get-nutrient #:name "Phosphorus")) (define nm (get-nutrient-measurement #:measured-on measurement-date)) (check-equal? (get-nutrient-measurement-value nm nitrogen) 12.3) (check-equal? (get-nutrient-measurement-value nm phosphorus) 4.5) (define nmv (nutrient-measurement-nutrient-values nm)) (check-equal? (get-nutrient-measurement-values nm) nmv "return value of get-nutrient-measurement-values ≠ nutrient-measurement-values struct accessor") (check-equal? (hash-count nmv) 2) (check-equal? (hash-ref nmv nitrogen) 12.3) (check-equal? (hash-ref nmv phosphorus) 4.5)) (test-case "Retrieve latest measurement values" (define nitrogen (get-nutrient #:name "Nitrogen")) (define phosphorus (get-nutrient #:name "Phosphorus")) (define second-measurement-date "2025-09-02") (create-nutrient-measurement! second-measurement-date (hash nitrogen 6.7 phosphorus 8.9)) (check-equal? (get-latest-nutrient-measurement-value nitrogen) 6.7) (check-equal? (get-latest-nutrient-measurement-value phosphorus) 8.9)) (test-case "Delete measurement and cascade to measurement values" (define nm (get-nutrient-measurement #:measured-on measurement-date)) (delete-nutrient-measurement! nm) (check-false (get-nutrient-measurement #:id (nutrient-measurement-id nm))) (check-equal? (length (get-nutrient-measurements)) 1 "wrong number of nutrient measurements were deleted") (check-true (hash-empty? (get-nutrient-measurement-values nm)))))))