#lang racket (provide nutrient-measurement nutrient-measurement? nutrient-measurement-id (rename-out [nutrient-measurement-measurement-date 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 db-id? #:date 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? maybe-nutrient-value?)] [get-latest-nutrient-measurement (-> (or/c nutrient-measurement? #f))] [get-latest-nutrient-measurement-value (-> nutrient? maybe-nutrient-value?)] [get-latest-nutrient-measurement-values (-> nutrient-value-hash/c)] [delete-nutrient-measurement! (-> nutrient-measurement-or-id/c void?)])) (require racket/contract db sql "../db/conn.rkt" "nutrient.rkt" "nutrient-value.rkt" "utils.rkt") (struct nutrient-measurement (id measurement-date nutrient-values) #:transparent #:property prop:custom-write (λ (v out _) (fprintf out "Measurement #~a on ~a\n" (nutrient-measurement-id v) (nutrient-measurement-measurement-date 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-or-id/c (or/c nutrient-measurement? db-id?)) (define (->nm-id nm-or-id) (match nm-or-id [(? db-id? id) id] [(nutrient-measurement id _ _) id])) ;; CREATE (define (create-nutrient-measurement! measurement-date nutrient-values) (with-tx (define nm-id (insert-id (query (current-conn) (insert #:into nutrient_measurements #:set [measurement_date ,measurement-date])))) (define nvs-id (insert-id (query (current-conn) (insert #:into nutrient_value_sets #:set [nutrient_measurement_id ,nm-id])))) (insert-nutrient-values (current-conn) nvs-id nutrient-values) (nutrient-measurement nm-id measurement-date nutrient-values))) ;; 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 grouped-row) (match-define (vector nm-id measurement-date residuals) grouped-row) (nutrient-measurement nm-id measurement-date (residuals->nutrient-value-hash residuals))) (define (get-nutrient-measurements) (define grouped-rows (query-rows (current-conn) (select nm.id nm.measurement_date n.id n.canonical_name n.french_name n.formula nv.value_ppm #:from (TableExpr:AST ,joined) #:order-by nm.measurement_date #:desc) #:group '#(0 1))) (map grouped-row->nutrient-measurement grouped-rows)) (define (get-nutrient-measurement #:id [nm-id #f] #:date [measurement-date #f]) (define where (cond [(and nm-id measurement-date) (scalar-expr-qq (and (= nm.id ,nm-id) (= nm.measurement_date ,measurement-date)))] [nm-id (scalar-expr-qq (= nm.id ,nm-id))] [measurement-date (scalar-expr-qq (= nm.measurement_date ,measurement-date))] [else (error 'get-nutrient-measurement "either #:id or #:date must be provided")])) (define grouped-rows (query-rows (current-conn) (select nm.id nm.measurement_date n.id n.canonical_name n.french_name n.formula nv.value_ppm #:from (TableExpr:AST ,joined) #:where (ScalarExpr:AST ,where) #:order-by nm.measurement_date #:desc) #:group '#(0 1))) (match grouped-rows ['() #f] [(list grouped-row) (grouped-row->nutrient-measurement grouped-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) (define measurements (get-nutrient-measurements)) (if (null? measurements) #f (first measurements))) (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.measurement_date #:desc #:limit 1))) (define (get-latest-nutrient-measurement-values) (define grouped-rows (query-rows (current-conn) (select n.id n.canonical_name n.french_name n.formula nm.measurement_date nv.value_ppm #:from (TableExpr:AST ,joined) #:order-by nm.measurement_date #:desc) #:group '(#(0 1 2 3)))) (for/hash ([grouped-row grouped-rows]) (match-define (vector n-id n-canonical-name n-french-name n-formula residual-rows) grouped-row) ;; residual-rows is a non-empty list of vectors: #(measurement_date value_ppm) (match-define (vector _ 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 #:date measurement-date)) (check-true (nutrient-measurement? nm)) (check-equal? (nutrient-measurement-measurement-date 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 #:date 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 #:date 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)))))))