Add relational data protocol for tabular operations (#45)
ober
348eb163be90b4c1f384cb23a3d50c8087da937d
new file mode 100644 --- /dev/null +++ b/lib/std/misc/relation.sls @@ -0,0 +1,157 @@ +#!chezscheme +;;; (std misc relation) — Relational operations on tabular data +;;; +;;; A relation is a set of rows with named columns, like an in-memory table. +;;; +;;; (define r (make-relation '(name age) '(("Alice" 30) ("Bob" 25)))) +;;; (relation-select r (lambda (row) (> (relation-ref row 'age) 27))) +;;; (relation-project r '(name)) +;;; (relation-join r1 r2 'id) + +(library (std misc relation) + (export make-relation relation? relation-columns relation-rows relation-count + relation-ref relation-select relation-project relation-extend + relation-sort relation-group-by relation-join + relation->alist-list alist-list->relation + relation-aggregate) + (import (chezscheme)) + + ;; Internal representation: columns as a list of symbols, rows as a list of alists + (define-record-type rel + (fields (immutable cols) ;; list of symbols + (immutable data))) ;; list of alists: ((col . val) ...) + + (define (relation? x) + (rel? x)) + + (define (relation-columns r) + (rel-cols r)) + + (define (relation-rows r) + (rel-data r)) + + (define (relation-count r) + (length (rel-data r))) + + ;; Get a column value from a row (which is an alist) + (define (relation-ref row col) + (let ([pair (assq col row)]) + (if pair + (cdr pair) + (error 'relation-ref "column not found" col)))) + + ;; Create a relation from column names and rows. + ;; Rows can be list-of-alists or list-of-lists (positional). + (define (make-relation columns rows) + (let ([cols (map (lambda (c) + (if (symbol? c) c + (error 'make-relation "column name must be a symbol" c))) + columns)]) + (make-rel cols (map (lambda (row) (row->alist cols row)) rows)))) + + ;; Convert a row to alist form. If already an alist, validate and return. + ;; If a plain list, zip with column names. + (define (row->alist cols row) + (cond + [(and (pair? row) (pair? (car row)) (symbol? (caar row))) + ;; Looks like an alist — use as-is + row] + [(list? row) + ;; Plain list — zip with columns + (unless (= (length row) (length cols)) + (error 'make-relation "row length does not match columns" row cols)) + (map cons cols row)] + [else (error 'make-relation "row must be a list or alist" row)])) + + ;; Filter rows by predicate on the row alist + (define (relation-select r pred) + (make-rel (rel-cols r) + (filter pred (rel-data r)))) + + ;; Select specific columns + (define (relation-project r cols) + (let ([project-row (lambda (row) + (map (lambda (c) + (let ([pair (assq c row)]) + (if pair pair + (error 'relation-project + "column not found" c)))) + cols))]) + (make-rel cols (map project-row (rel-data r))))) + + ;; Add a computed column + (define (relation-extend r col-name proc) + (make-rel (append (rel-cols r) (list col-name)) + (map (lambda (row) + (append row (list (cons col-name (proc row))))) + (rel-data r)))) + + ;; Sort rows by a column using the given comparator + (define (relation-sort r col comparator) + (make-rel (rel-cols r) + (list-sort (lambda (a b) + (comparator (cdr (assq col a)) + (cdr (assq col b)))) + (rel-data r)))) + + ;; Group rows by a column. Returns alist of (key-value . sub-relation). + (define (relation-group-by r col) + (let ([groups (make-hashtable equal-hash equal?)] + [cols (rel-cols r)]) + (for-each (lambda (row) + (let* ([key (cdr (assq col row))] + [existing (hashtable-ref groups key '())]) + (hashtable-set! groups key (cons row existing)))) + (rel-data r)) + (let-values ([(keys vals) (hashtable-entries groups)]) + (map (lambda (k v) (cons k (make-rel cols (reverse v)))) + (vector->list keys) + (vector->list vals))))) + + ;; Inner join two relations on a shared key column + (define (relation-join r1 r2 key-col) + (let* ([cols1 (rel-cols r1)] + [cols2 (rel-cols r2)] + ;; Merged columns: all of r1, plus r2 cols excluding the key + [extra-cols (filter (lambda (c) (not (eq? c key-col))) cols2)] + [merged-cols (append cols1 extra-cols)] + ;; Index r2 by key for efficiency + [index (let ([ht (make-hashtable equal-hash equal?)]) + (for-each (lambda (row) + (let* ([k (cdr (assq key-col row))] + [existing (hashtable-ref ht k '())]) + (hashtable-set! ht k (cons row existing)))) + (rel-data r2)) + ht)]) + (make-rel merged-cols + (apply append + (map (lambda (row1) + (let* ([k (cdr (assq key-col row1))] + [matches (hashtable-ref index k '())]) + (map (lambda (row2) + (append row1 + (filter (lambda (pair) + (not (eq? (car pair) key-col))) + row2))) + matches))) + (rel-data r1)))))) + + ;; Export as list of alists + (define (relation->alist-list r) + (rel-data r)) + + ;; Import from list of alists + (define (alist-list->relation alist-list) + (if (null? alist-list) + (make-rel '() '()) + (let ([cols (map car (car alist-list))]) + (make-rel cols alist-list)))) + + ;; Aggregate: fold over a column's values + (define (relation-aggregate r col proc init) + (fold-left (lambda (acc row) + (proc acc (cdr (assq col row)))) + init + (rel-data r))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/tests/test-relation.ss @@ -0,0 +1,189 @@ +#!chezscheme +;;; tests/test-relation.ss -- Tests for (std misc relation) + +(import (chezscheme) (std misc relation)) + +(define pass 0) +(define fail 0) + +(define-syntax test + (syntax-rules () + [(_ name expr expected) + (guard (exn [#t (set! fail (+ fail 1)) + (printf "FAIL ~a: ~a~%" name + (if (message-condition? exn) (condition-message exn) exn))]) + (let ([got expr]) + (if (equal? got expected) + (begin (set! pass (+ pass 1)) (printf " ok ~a~%" name)) + (begin (set! fail (+ fail 1)) + (printf "FAIL ~a: got ~s expected ~s~%" name got expected)))))])) + +(printf "--- (std misc relation) tests ---~%~%") + +;; ---- Sample data ---- +(define people + (make-relation '(name age city) + '(("Alice" 30 "NYC") + ("Bob" 25 "LA") + ("Carol" 35 "NYC") + ("Dave" 25 "LA")))) + +;; ---- 1. Basic accessors ---- +(test "relation?" (relation? people) #t) +(test "relation?-neg" (relation? '()) #f) +(test "columns" (relation-columns people) '(name age city)) +(test "count" (relation-count people) 4) +(test "rows-count" (length (relation-rows people)) 4) + +;; ---- 2. relation-ref ---- +(let ([row (car (relation-rows people))]) + (test "ref-name" (relation-ref row 'name) "Alice") + (test "ref-age" (relation-ref row 'age) 30) + (test "ref-city" (relation-ref row 'city) "NYC")) + +;; ---- 3. make-relation from alists ---- +(let ([r (make-relation '(x y) + (list '((x . 1) (y . 2)) + '((x . 3) (y . 4))))]) + (test "from-alist count" (relation-count r) 2) + (test "from-alist ref" (relation-ref (car (relation-rows r)) 'x) 1)) + +;; ---- 4. relation-select ---- +(let ([nyc (relation-select people + (lambda (row) (equal? (relation-ref row 'city) "NYC")))]) + (test "select count" (relation-count nyc) 2) + (test "select cols" (relation-columns nyc) '(name age city)) + (test "select first" + (relation-ref (car (relation-rows nyc)) 'name) "Alice")) + +(let ([empty (relation-select people (lambda (row) #f))]) + (test "select-none" (relation-count empty) 0)) + +;; ---- 5. relation-project ---- +(let ([names-ages (relation-project people '(name age))]) + (test "project cols" (relation-columns names-ages) '(name age)) + (test "project count" (relation-count names-ages) 4) + (test "project row" + (relation-ref (car (relation-rows names-ages)) 'name) "Alice") + ;; Projected rows should not have city + (test "project no-city" + (assq 'city (car (relation-rows names-ages))) #f)) + +;; ---- 6. relation-extend ---- +(let ([extended (relation-extend people 'senior + (lambda (row) (>= (relation-ref row 'age) 30)))]) + (test "extend cols" (relation-columns extended) '(name age city senior)) + (test "extend count" (relation-count extended) 4) + (test "extend val-alice" + (relation-ref (car (relation-rows extended)) 'senior) #t) + (test "extend val-bob" + (relation-ref (cadr (relation-rows extended)) 'senior) #f)) + +;; ---- 7. relation-sort ---- +(let ([by-age (relation-sort people 'age <)]) + (test "sort first" (relation-ref (car (relation-rows by-age)) 'age) 25) + (test "sort last" + (relation-ref (list-ref (relation-rows by-age) 3) 'age) 35)) + +(let ([by-name (relation-sort people 'name string<?)]) + (test "sort-by-name first" + (relation-ref (car (relation-rows by-name)) 'name) "Alice") + (test "sort-by-name last" + (relation-ref (list-ref (relation-rows by-name) 3) 'name) "Dave")) + +;; ---- 8. relation-group-by ---- +(let ([groups (relation-group-by people 'city)]) + (test "group-by keys" (length groups) 2) + (let ([nyc-group (cdr (assoc "NYC" groups))] + [la-group (cdr (assoc "LA" groups))]) + (test "group-nyc count" (relation-count nyc-group) 2) + (test "group-la count" (relation-count la-group) 2) + (test "group-nyc cols" (relation-columns nyc-group) '(name age city)))) + +;; ---- 9. relation-join ---- +(let* ([depts (make-relation '(name dept) + '(("Alice" "Eng") + ("Bob" "Sales") + ("Carol" "Eng")))] + [joined (relation-join people depts 'name)]) + (test "join count" (relation-count joined) 3) ;; Dave has no dept match + (test "join cols" (relation-columns joined) '(name age city dept)) + (let ([first-row (car (relation-rows + (relation-sort joined 'name string<?)))]) + (test "join alice dept" (relation-ref first-row 'dept) "Eng") + (test "join alice age" (relation-ref first-row 'age) 30))) + +;; ---- 10. relation->alist-list / alist-list->relation ---- +(let* ([alists (relation->alist-list people)] + [roundtrip (alist-list->relation alists)]) + (test "alist-list count" (length alists) 4) + (test "alist-list first" (cdr (assq 'name (car alists))) "Alice") + (test "roundtrip count" (relation-count roundtrip) 4) + (test "roundtrip cols" (relation-columns roundtrip) '(name age city))) + +;; Empty relation roundtrip +(let ([empty (alist-list->relation '())]) + (test "alist-empty" (relation-count empty) 0) + (test "alist-empty-cols" (relation-columns empty) '())) + +;; ---- 11. relation-aggregate ---- +(test "aggregate sum-age" (relation-aggregate people 'age + 0) 115) +(test "aggregate max-age" + (relation-aggregate people 'age + (lambda (acc v) (if (> v acc) v acc)) 0) + 35) +(test "aggregate min-age" + (relation-aggregate people 'age + (lambda (acc v) (if (< v acc) v acc)) 999) + 25) +(test "aggregate count-rows" + (relation-aggregate people 'age (lambda (acc v) (+ acc 1)) 0) + 4) + +;; ---- 12. Composition: select + project + sort ---- +(let* ([step1 (relation-select people + (lambda (row) (>= (relation-ref row 'age) 30)))] + [step2 (relation-project step1 '(name age))] + [step3 (relation-sort step2 'age >)]) + (test "compose count" (relation-count step3) 2) + (test "compose first-name" + (relation-ref (car (relation-rows step3)) 'name) "Carol") + (test "compose second-name" + (relation-ref (cadr (relation-rows step3)) 'name) "Alice")) + +;; ---- 13. Edge: single-row relation ---- +(let ([r (make-relation '(x) '((42)))]) + (test "single-row count" (relation-count r) 1) + (test "single-row ref" (relation-ref (car (relation-rows r)) 'x) 42)) + +;; ---- 14. Edge: empty relation ---- +(let ([r (make-relation '(a b) '())]) + (test "empty count" (relation-count r) 0) + (test "empty cols" (relation-columns r) '(a b)) + (test "empty select" (relation-count (relation-select r (lambda (row) #t))) 0) + (test "empty project" (relation-count (relation-project r '(a))) 0) + (test "empty aggregate" (relation-aggregate r 'a + 0) 0)) + +;; ---- 15. group-by + aggregate ---- +(let ([groups (relation-group-by people 'city)]) + (let* ([nyc (cdr (assoc "NYC" groups))] + [la (cdr (assoc "LA" groups))]) + (test "group+agg nyc-sum" (relation-aggregate nyc 'age + 0) 65) + (test "group+agg la-sum" (relation-aggregate la 'age + 0) 50))) + +;; ---- 16. Join with duplicates ---- +(let* ([orders (make-relation '(customer item) + '(("Alice" "Book") + ("Alice" "Pen") + ("Bob" "Notebook")))] + [info (make-relation '(customer city) + '(("Alice" "NYC") + ("Bob" "LA")))] + [joined (relation-join orders info 'customer)]) + (test "join-dup count" (relation-count joined) 3) + (let ([alice-rows (relation-select joined + (lambda (row) (equal? (relation-ref row 'customer) "Alice")))]) + (test "join-dup alice count" (relation-count alice-rows) 2))) + +(printf "~%~a tests, ~a passed, ~a failed~%" (+ pass fail) pass fail) +(when (> fail 0) (exit 1))