Browse Source

graphviz!

master
eta 3 months ago
parent
commit
2bf266e607
  1. 2
      deploy.txt
  2. 125
      trackernet.lisp

2
deploy.txt

@ -1,4 +1,4 @@
(ql:quickload '(drakma cl-conspack cxml cl-statsd cl-redis qbase64 archive cl-ansi-text gzip-stream))
(ql:quickload '(drakma cl-conspack cxml cl-statsd cl-redis qbase64 archive cl-ansi-text gzip-stream bobbin))
(load "trackernet.lisp")
(sb-ext:save-lisp-and-die "./intertube-scraper" :toplevel #'trackernet::main :executable t)

125
trackernet.lisp

@ -1008,3 +1008,128 @@ Stop if *TRACKERNET-KILL-SWITCH* is set to T."
"Returns a list of all trains active on the given LINE-CODE right now."
(get-all (format nil "~A-active-*"
line-code)))
(defparameter *track-links-set* (make-hash-table
:test 'equal))
(defun reset-track-links-set ()
(setf *track-links-set* (make-hash-table
:test 'equal)))
(defun populate-track-links-set (archived-train)
"Create links between subsequent observed track codes in ARCHIVED-TRAIN's history."
(destructuring-bind (filename archived-universal-ts train-key history)
archived-train
(loop
with first = (pop history)
for next = (pop history)
while next
do (let ((track-code-1 (track-code (third first)))
(track-code-2 (track-code (third next))))
(unless (gethash (list track-code-1 track-code-2) *track-links-set*)
(setf (gethash (list track-code-1 track-code-2) *track-links-set*) 0))
(incf (gethash (list track-code-1 track-code-2) *track-links-set*)))
do (setf first next))))
(defun calculate-exponential-base (max top)
(expt top
(/ 1 max)))
(defun track-links-third-quartile (&key (cutoff 0))
(let ((data (sort (loop
for v being the hash-values of *track-links-set*
unless (< v cutoff)
collect v)
#'<)))
(values
(elt data
(* 3
(floor (length data) 4)))
data)))
(defun squish-link-length (in max top &optional (base (calculate-exponential-base max top)))
(cond
((> in max) top)
(t (expt base in))))
(defun write-track-links-graphviz (&optional (out *standard-output*))
"Write the track links out in graphviz format."
(princ "digraph {" out)
(format out "node [shape=box margin=\"0.1,0.1\"];")
(terpri out)
(loop
for key in (get-all "D-track-desc-*")
for actual = (subseq key 13)
for value = (red:get key)
do (format out "\"~A\" [label=<<B>~A</B><BR /><I><FONT POINT-SIZE=\"10\">~{~A~^<BR ALIGN=\"LEFT\"/>~}</FONT></I>>]~%"
actual
actual
(if (eql (length value) 0)
'("???")
(bobbin:wrap (list value) 20))))
(let* ((q3 (track-links-third-quartile :cutoff 5))
(base (calculate-exponential-base q3 3)))
(loop
for (a b) being the hash-keys of *track-links-set*
using (hash-value v)
unless (or (< v 5)
(string= a b))
do (let* ((score-2 (1- (squish-link-length v q3 3 base)))
(score-perc (floor (* 50 score-2))))
(format out "\"~A\" -> \"~A\" [weight=~A len=~F label=\"~A (~A%)\" color=\"0.0 0.0 ~F\" fontcolor=\"0.0 0.0 ~F\" style=\"~A\"];~%"
a
b
score-perc
(- 3.5 score-2)
v
score-perc
(+ 0.2 (/ (- 100 score-perc) 120))
(/ (- 100 score-perc) 100)
(cond
((> score-perc 80) "bold")
((< score-perc 20) "dotted")
(t "solid"))))))
(princ "}" out))
(defun write-track-links-graphviz-clustered (&optional (out *standard-output*))
"Write the track links out in graphviz format."
(princ "digraph {" out)
(terpri out)
(format out " overlap = false;
splines = polyline;
")
(let ((descs-ht (make-hash-table :test 'equal)))
(loop
for key in (get-all "D-track-desc-*")
for actual = (subseq key 13)
for value = (red:get key)
do (when (and
(> (length value) 0)
(not (uiop:string-prefix-p "Approaching" value))
(not (uiop:string-prefix-p "Left" value))
(not (string= value "At Platform")))
(unless (gethash value descs-ht)
(setf (gethash value descs-ht) nil))
(push actual (gethash value descs-ht))))
(loop
for description being the hash-keys of descs-ht
using (hash-value track-codes)
for i from 0
do (format out "subgraph cluster_~A {
label=\"~A\";
style=\"filled\";
color=lightblue;
~{\"~A\";~^~%~}
}
"
i
description
track-codes)))
(loop
for (a b) being the hash-keys of *track-links-set*
using (hash-value v)
unless (or (< v 5)
(string= a b))
do (format out "\"~A\" -> \"~A\" [weight=~A label=\"~A\"];~%" a b v v))
(princ "}" out))
Loading…
Cancel
Save