Commit 12cd7853 authored by Dave Griffiths's avatar Dave Griffiths
Browse files

sharing review code for prettification of csv

parent 71cfc76a
......@@ -32,6 +32,7 @@
"group-comp-weight"
"group-comp-pup-assoc"
"group-comp-mate-guard"
"note"
))
(define pup-focal-export
......@@ -482,31 +483,11 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; review
(define (ktv-key-is-id? ktv)
(or
(equal? (ktv-key ktv) "pack")
(equal? (ktv-key ktv) "present")
(equal? (substring (ktv-key ktv) 0 3) "id-")))
;; search for a comma in a list of ids
(define (ktv-value-is-list? ktv)
(foldl
(lambda (c r)
(if (or r (eqv? c #\,)) #t r))
#f
(string->list (ktv-value ktv))))
(define (uid->name uid)
(let* ((entity-id (entity-id-from-unique db "sync" uid)))
(ktv-get (get-entity-only db "sync" entity-id
(list (list "name" "varchar")))
"name")))
(define (review-build-id ktv)
(list (medit-text-value
(string-append (ktv-value ktv) (ktv-key ktv))
(ktv-key ktv)
(uid->name (ktv-value ktv)) "normal"
(uid->name db (ktv-value ktv)) "normal"
(lambda (v)
(entity-set-value! (ktv-key ktv) (ktv-type ktv) v)
'()))))
......@@ -519,8 +500,8 @@
(foldl
(lambda (id r)
(if (equal? r "")
(uid->name id)
(string-append r ", " (uid->name id))))
(uid->name db id)
(string-append r ", " (uid->name db id))))
""
ids)
"normal"
......@@ -528,43 +509,22 @@
(entity-set-value! (ktv-key ktv) (ktv-type ktv) v)
'())))))
(define (convert-id name)
(let ((name (string-remove-whitespace name)))
;; search for unique id first
(if (entity-exists? db "sync" name)
name
(let ((new-entity (db-filter-only
db "sync" "*"
(list (list "name" "varchar" "=" name))
(list))))
(if (null? new-entity)
#f
(ktv-get (car new-entity) "unique_id"))))))
(define (convert-id-list str)
(let ((names (string-split-simple str #\,)))
(foldl
(lambda (name r)
(if (string? r)
(let ((id (convert-id name)))
(if id
(if (equal? r "") id (string-append r "," id))
#f))
#f))
"" names)))
;; replace entity with names -> uids, or name of not found
(define (review-validate-contents uid entity)
(msg "validate....")
(foldl
(lambda (ktv r)
(msg ktv)
(cond
((string? r) r) ;; we have already found an error
((ktv-key-is-id? ktv)
(msg "it's an id...")
(msg "is list=" (ktv-value-is-list? ktv))
(let ((replacement
(if (ktv-value-is-list? ktv)
(convert-id-list (ktv-value ktv))
(convert-id (ktv-value ktv)))))
(convert-id-list db (ktv-value ktv))
(convert-id db (ktv-value ktv)))))
(msg replacement)
(if replacement
(cons (list (ktv-key ktv) (ktv-type ktv) replacement) r)
;; ditch the entity and return error
......
......@@ -937,12 +937,14 @@
(list "pester" "int" "!=" 0)
)))
))))
(update-selector-colours2
(update-selector-colours3-or
"gc-oestrus-guard" "group-comp-mate-guard"
(ktv-get pup-individual "unique_id")
(list
(list "id-mongoose" "varchar" "=" (ktv-get pup-individual "unique_id"))
(list "strength" "varchar" "!=" "none")
(list "accurate" "varchar" "!=" "none")))
(list "accurate" "varchar" "!=" "none")
(list "pester" "int" "!=" 0)
))
(update-selector-colours3 "gc-oestrus-female" "group-comp-mate-guard")
(update-grid-selector-enabled "gc-oestrus-guard" (get-current 'gc-not-present '()))
))))
......
......@@ -27,4 +27,8 @@ public class PupFocalActivity extends foam.starwisp.StarwispActivity
m_Name = "pup-focal";
super.onCreate(savedInstanceState);
}
@Override
public void onBackPressed() {
}
}
......@@ -21,10 +21,73 @@
"ktv.ss"
"ktv-list.ss"
"entity-values.ss"
"entity-get.ss")
"entity-get.ss"
"eavdb.ss")
(provide (all-defined-out))
;; prettifications stuff - also used for review on the app
(define (string-remove-whitespace str)
(define (_ i)
(cond
((>= i (string-length str)) "")
((char-whitespace? (string-ref str i))
(_ (+ i 1)))
(else (string-append (string (string-ref str i))
(_ (+ i 1))))))
(_ 0))
(define (ktv-key-is-id? ktv)
(or
(equal? (ktv-key ktv) "pack")
(and (equal? (ktv-key ktv) "present")
(equal? (ktv-type ktv) "varchar"))
(equal? (ktv-key ktv) "pregnant")
(equal? (ktv-key ktv) "baby-seen")
(equal? (ktv-key ktv) "baby-byelim")
(equal? (substring (ktv-key ktv) 0 3) "id-")))
;; search for a comma in a list of ids
(define (ktv-value-is-list? ktv)
(foldl
(lambda (c r)
(if (or r (eqv? c #\,)) #t r))
#f
(string->list (ktv-value ktv))))
(define (uid->name db uid)
(let* ((entity-id (entity-id-from-unique db "sync" uid)))
(ktv-get (get-entity-only db "sync" entity-id
(list (list "name" "varchar")))
"name")))
(define (convert-id db name)
(let ((name (string-remove-whitespace name)))
;; search for unique id first
(if (entity-exists? db "sync" name)
name
(let ((new-entity (db-filter-only
db "sync" "*"
(list (list "name" "varchar" "=" name))
(list))))
(if (null? new-entity)
#f
(ktv-get (car new-entity) "unique_id"))))))
(define (convert-id-list db str)
(let ((names (string-split str (list #\,))))
(foldl
(lambda (name r)
(if (string? r)
(let ((id (convert-id db name)))
(if id
(if (equal? r "") id (string-append r "," id))
#f))
#f))
"" names)))
(define (csv-titles db table entity-type)
(foldl
(lambda (kt r)
......@@ -33,49 +96,30 @@
"id "
(get-attribute-ids/types db table entity-type)))
(define (csv-old db table entity-type)
; basic csv
(define (csv db table entity-type)
(let ((s (db-select
db (string-append
"select entity_id, unique_id from "
table "_entity where entity_type = ?") entity-type)))
(msg "CSV ------------------------------>" entity-type)
(msg s)
(if (null? s)
;; nothing here, just return titles
(csv-titles db table entity-type)
(foldl
(lambda (res r)
(msg res)
(let ((entity (get-entity-for-csv db table (vector-ref res 0))))
(string-append
r "\n"
(foldl
(lambda (ktv r)
(msg ktv)
(cond
((equal? (ktv-key ktv) "unique_id") r)
((null? (ktv-value ktv))
(msg "value not found in csv for " (ktv-key ktv))
(string-append r ", NULL"))
;; dereferences lists of ids
((and
(> (string-length (ktv-key ktv)) 8)
(equal? (substring (ktv-key ktv) 0 8) "id-list-"))
(let ((ids (string-split (ktv-value ktv) '(#\,))))
(if (null? ids)
(string-append r ", \"\"")
(string-append r ", \"" (get-entity-names db "sync" "\"")))))
;; look for unique ids and dereference them
((and
(> (string-length (ktv-key ktv)) 3)
(equal? (substring (ktv-key ktv) 0 3) "id-")
(not (equal? (ktv-value ktv) "none")))
(msg "looking up name")
(msg ktv)
(let ((name (get-entity-name db "sync" (ktv-value ktv))))
(if (null? name)
"\"nobody\""
(string-append r ", \"" name "\""))))
(else
(string-append r ", \"" (stringify-value-url ktv) "\""))))
(vector-ref res 1) ;; unique_id
......@@ -83,7 +127,8 @@
(csv-titles db table entity-type)
(cdr s)))))
(define (csv db table entity-type)
;; convert uids to names
(define (csv-pretty db table entity-type)
(let ((s (db-select
db (string-append
"select entity_id, unique_id from "
......@@ -100,7 +145,16 @@
(foldl
(lambda (ktv r)
(cond
((equal? (ktv-key ktv) "unique_id") r)
((ktv-key-is-id? ktv)
(let ((replacement
(if (ktv-value-is-list? ktv)
(string-append "\"" (convert-id-list db (ktv-value ktv)) "\"")
(convert-id db (ktv-value ktv)))))
(if replacement
replacement
;; ditch the entity and return error
(ktv-value ktv))))
((null? (ktv-value ktv))
(msg "value not found in csv for " (ktv-key ktv))
(string-append r ", NULL"))
......@@ -112,31 +166,6 @@
(csv-titles db table entity-type)
(cdr s)))))
;; exporting human editable reports
(define (deref-entity db entity)
(foldl
(lambda (ktv r)
(append
r
(list
(ktv-key ktv)
(cond
;; dereferences lists of ids
((and
(> (string-length (ktv-key ktv)) 8)
(equal? (substring (ktv-key ktv) 0 8) "id-list-"))
(get-entity-names db "sync" (string-split (ktv-value ktv) '(#\,))))
;; look for unique ids and dereference them
((and
(> (string-length (ktv-key ktv)) 3)
(equal? (substring (ktv-key ktv) 0 3) "id-"))
(get-entity-name db "sync" (ktv-value ktv)))
(else
(ktv-value ktv))))))
'()
entity))
(define (csv-convert col)
(if (number? col) (number->string col)
......@@ -174,35 +203,3 @@
(ktv-filter r key))
ktv-list
key-list))
;; meant to be general, but made for pup focal reports
;(define (export-csv db table parent-entity entity-types)
; (let* ((focal (get-entity db "sync" (get-entity-id db "sync" (ktv-get parent-entity "id-focal-subject"))))
; (pack (get-entity db "sync" (get-entity-id db "sync" (ktv-get focal "pack-id")))))
; (csvify
; (cons
; '("time" "user" "pack" "subject" "observation type" "key" "value" "key" "value")
; (sort
; (foldl
; (lambda (entity-type r)
; (append
; r (map
; (lambda (entity)
; (append
; (list
; (ktv-get entity "time")
; (ktv-get entity "user")
; (ktv-get pack "name")
; (ktv-get focal "name")
; entity-type)
; (deref-entity
; db (ktv-filter-many
; entity (list "user" "unique_id" "parent" "time")))))
; (db-all-with-parent
; db table entity-type
; (ktv-get parent-entity "unique_id")))))
; '()
; entity-types)
; (lambda (a b)
; (string<? (car a) (car b))))))))
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment