You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
247 lines
8.1 KiB
247 lines
8.1 KiB
|
|
(define-module (yacswa data)
|
|
#:use-module (csv csv)
|
|
#:use-module (ice-9 textual-ports)
|
|
#:use-module (ice-9 threads)
|
|
#:use-module (json)
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (srfi srfi-19)
|
|
#:use-module (sxml simple)
|
|
#:use-module (sxml transform)
|
|
#:use-module (tk listlogic)
|
|
#:use-module (tk mcron)
|
|
#:use-module (tk short)
|
|
#:use-module (yacswa debugging)
|
|
#:use-module (yacswa git)
|
|
|
|
#:export (get-by-postal
|
|
get-by-hr))
|
|
|
|
;; Prevent the GC from collecting the associations
|
|
(define-once hr-syms '())
|
|
(define-once pc-syms '())
|
|
(define-once text-syms '())
|
|
|
|
(display "Updating stats repository...")
|
|
(git:init)
|
|
(display "Done.\n")
|
|
|
|
(define-once $hr-tree
|
|
(csv->sxml (open-input-file path-hr-info)
|
|
#:record-sym (lambda x "hr")))
|
|
|
|
(define-once $pc-tree
|
|
(csv->sxml (open-input-file path-hr-pc-map)
|
|
#:record-sym (lambda x "pc")))
|
|
|
|
(define-syntax hr
|
|
(syntax-rules ()
|
|
((hr (($sym) (province $prov) (province_full $prov_text)
|
|
(province_short $prov_abbr) (health_region $hr_terse)
|
|
(health_region_esri $hr_full) $pop))
|
|
(begin (set! hr-syms (cons '$sym hr-syms))
|
|
(let (($text-sym (ssa> $prov "-" $hr_terse)))
|
|
(begin (set! text-syms (cons $text-sym text-syms))
|
|
(symbol-fset! $text-sym '$sym)))
|
|
(set-symbol-property! '$sym 'prov-code $prov_abbr)
|
|
(set-symbol-property! '$sym 'province $prov)
|
|
(set-symbol-property! '$sym 'terse $hr_terse)
|
|
(set-symbol-property! '$sym 'hr-full $hr_full)
|
|
(set-symbol-property! '$sym 'population $pop)))))
|
|
|
|
(define (hrinfo!)
|
|
(for-each (lambda (x) (eval x (interaction-environment)))
|
|
(pre-post-order
|
|
(cdr $hr-tree)
|
|
`((HR_UID . ,(lambda (l x) `(,(ssa> "HR" x))))
|
|
(pop . ,(lambda (l x) (string->number x)))
|
|
(*text* . ,(lambda (l x) x))
|
|
(*default* . ,(lambda x x))))))
|
|
|
|
(define-syntax pc
|
|
(syntax-rules ()
|
|
((pc (($pc) ($sym) (Prov $prov_num) (ENGNAME $eng_name)
|
|
(FRENAME $fre_name) (EstimatedPop $pop)))
|
|
(begin (set! pc-syms (cons '$pc pc-syms))
|
|
(symbol-fset! '$pc (cons '$sym (if-some (symbol-fref '$pc))))))))
|
|
|
|
(define (pcinfo!)
|
|
(for-each (lambda (x) (eval x (interaction-environment)))
|
|
(pre-post-order
|
|
(cdr $pc-tree)
|
|
`((FSA . ,(lambda (l x) `(,(ssa> "PC" x))))
|
|
(HR_UID . ,(lambda (l x) `(,(ssa> "HR" x))))
|
|
(*text* . ,(lambda (l x) x))
|
|
(*default* . ,(lambda x x))))))
|
|
|
|
(begin (hrinfo!)
|
|
(set! hr-syms (delq! 'HR9999 hr-syms))
|
|
(if test-mode?
|
|
(begin (display "Testing hr symbols") (newline)
|
|
(for-each (lambda (s) (run-hook test-hr s)) hr-syms)))
|
|
(pcinfo!)
|
|
(if test-mode?
|
|
(begin (display "Testing pc symbols") (newline)
|
|
(for-each (lambda (s) (run-hook test-pc s)) pc-syms))))
|
|
|
|
;; Data update logic
|
|
|
|
(define-once $stat-tree
|
|
(csv->sxml (open-input-file path-hr-cases)
|
|
#:record-sym (lambda x "rec")))
|
|
(define ($stat-tree-update)
|
|
(set! $stat-tree
|
|
(csv->sxml (open-input-file path-hr-cases)
|
|
#:record-sym (lambda x "rec")))
|
|
$stat-tree)
|
|
|
|
(define (log-stats-reset)
|
|
(sxml->xml $stat-tree (open-output-file
|
|
(string-append (yesterday-date-string)
|
|
"-stats.log")))
|
|
(for-each (lambda (sym)
|
|
(set-symbol-property! sym 'reports '()))
|
|
hr-syms))
|
|
|
|
;; Time Management
|
|
(define-once $base-time
|
|
(time-second
|
|
(date->time-utc
|
|
(string->date (get-string-all (open-input-file path-update-time))
|
|
"~Y~m~d~H~M"))))
|
|
|
|
(define ($base-time!)
|
|
(let ((new-time (strf->secs (get-string-all (open-input-file path-update-time))
|
|
"~Y~m~d~H~M")))
|
|
(begin (set! $base-time new-time)
|
|
($expiry-timestamp!)))
|
|
$base-time)
|
|
|
|
(define (updated?)
|
|
(let ((prev-base $base-time)
|
|
(new-time ($base-time!)))
|
|
(if (equal? prev-base new-time)
|
|
#f
|
|
#t)))
|
|
|
|
(define $expiry-timestamp
|
|
(let ((ct (time-second (current-time))))
|
|
(step-from $base-time sec/day ct)))
|
|
(define ($expiry-timestamp!)
|
|
(let ((ct (time-second (current-time))))
|
|
(set! $expiry-timestamp (step-from $base-time sec/day ct)))
|
|
$expiry-timestamp)
|
|
|
|
(define (next-timestamp)
|
|
(- ($expiry-timestamp!)
|
|
(time-second (current-time))))
|
|
|
|
;; Data Wrangling
|
|
(define-syntax rec
|
|
(syntax-rules ()
|
|
((rec ($prov $region $date $cases $c_cases))
|
|
(let* (($sym (symbol-fref (ssa> $prov "-" $region)))
|
|
($report-stack (if-some (symbol-property $sym 'reports))))
|
|
(unless (eq? $sym 'HR9999) ; special case, HR9999 has no meaningful data
|
|
(set-symbol-property! $sym 'reports (merge! $report-stack
|
|
'(($date . $cases))
|
|
(lambda (a b)
|
|
(time<? (car a)
|
|
(car b))))))))))
|
|
|
|
(define (process-stats! $tree)
|
|
(for-each
|
|
(lambda (x)
|
|
(eval x (interaction-environment)))
|
|
(pre-post-order
|
|
(cdr $tree)
|
|
`((province . ,(lambda (l x) x))
|
|
(health_region . ,(lambda (l x) x))
|
|
(date_report . ,(lambda (l x) (date->time-utc (string->date x "~d~m~Y"))))
|
|
(cases . ,(lambda (l x) (string->number x)))
|
|
(cumulative_cases . ,(lambda (l x) (string->number x)))
|
|
(*text* . ,(lambda (l x) x))
|
|
(*default* . ,(lambda x x))))))
|
|
|
|
(define (calculate-strings!)
|
|
(define (sum-first-n n $records)
|
|
(fold + 0 (map cdr (list-tail $records (- (length $records) n)))))
|
|
(for-each
|
|
(lambda (hr-sym)
|
|
(let* ((plist (symbol-pref hr-sym))
|
|
(json (scm->json-string
|
|
`((hr . ,(substring (ss< hr-sym) 2))
|
|
(population . ,(assq-ref plist 'population))
|
|
(hr-full . ,(assq-ref plist 'hr-full))
|
|
(hr-terse . ,(assq-ref plist 'terse))
|
|
(province . ,(assq-ref plist 'province))
|
|
(prov-terse . ,(assq-ref plist 'prov-code))
|
|
(last-7 . ,(sum-first-n 7 (assq-ref plist 'reports)))
|
|
(last-14 . ,(sum-first-n 14 (assq-ref plist 'reports)))
|
|
(expires . ,$expiry-timestamp)))))
|
|
(set-symbol-property! hr-sym 'json-string json)))
|
|
hr-syms))
|
|
|
|
;;Update Thread
|
|
(define %json-lock (make-mutex))
|
|
|
|
(define mcron-locked '())
|
|
|
|
(define (who-locked?)
|
|
(if (mutex-locked? %json-lock)
|
|
(if (eqv? (mutex-owner %json-lock) mcron-locked)
|
|
'mcron
|
|
'admin)
|
|
'()))
|
|
|
|
;;(define mcron:user (getpw (if-some-else (getlogin)
|
|
;; "covInd")))
|
|
|
|
(define (job-loop)
|
|
(let loop ()
|
|
(git:fetch)
|
|
(if (updated?)
|
|
(begin (with-mutex %json-lock
|
|
(log-stats-reset)
|
|
(process-stats! ($stat-tree-update))
|
|
(calculate-strings!))
|
|
(sleep (next-timestamp)))
|
|
(begin (set! next-timestamp (+ next-timestamp (sec/mins 9)))
|
|
(sleep (sec/mins 9))))
|
|
(loop)))
|
|
|
|
;; As the git repository is no longer updated there is no need to
|
|
;; establish a job loop or populate the statistics tables asynchronously
|
|
|
|
;;(begin-thread (with-mutex %json-lock
|
|
;; (git:fetch)
|
|
;; (set! mcron-locked (mutex-owner %json-lock))
|
|
;; (process-stats! $stat-tree)
|
|
;; (calculate-strings!))
|
|
;; (sleep (next-timestamp))
|
|
;; (job-loop))
|
|
|
|
;;(sleep 1)
|
|
;;(while (mutex-locked? %json-lock)
|
|
;; (sleep 1))
|
|
|
|
|
|
;; Functional parts of the asynchronous code above
|
|
|
|
(display "Processing stats...")
|
|
(process-stats! $stat-tree)
|
|
(display "and calculating json strings...")
|
|
(calculate-strings!)
|
|
(display "Done.\n")
|
|
|
|
;; Public Interface
|
|
(define (get-by-postal code)
|
|
(let* ((pc-sym (ssa> "PC" code))
|
|
(hr-sym (car (if-some-else (symbol-fref pc-sym) '(ndef)))))
|
|
(symbol-property hr-sym 'json-string)))
|
|
|
|
(define (get-by-hr code)
|
|
(let ((hr-sym (ssa> "HR" code)))
|
|
(symbol-property hr-sym 'json-string)))
|
|
|