Permalink
Browse files

Completely rewrite reports generation and output

  • Loading branch information...
pavpanchekha committed May 18, 2014
1 parent 14af78a commit 8615124ad3deb845d34fdc3e2e16e0d211f8e8ae
Showing with 188 additions and 178 deletions.
  1. +182 −172 reports/make-report.rkt
  2. +6 −6 reports/tools-common.rkt
View
@@ -1,209 +1,219 @@
#lang racket
(require reports/markdown-tools)
(require racket/match)
(require racket/date)
(require reports/make-graph)
(require reports/tools-common)
(require casio/load-bench)
(require casio/test)
(require casio/common)
(require casio/points)
(require casio/main)
(require casio/programs)
(require casio/alternative)
(require racket/date)
(provide (all-defined-out))
(define *graph-folder-name-length* 8)
(define *handle-crashes* #t)
(define *output-directory* "graphs")
(define disallowed-strings '("/" " " "(" ")"))
(define (make-report bench-dir)
(let* ([tests (univariate-tests bench-dir)]
[results (get-test-results tests)])
(define (strip-string s)
(pipe s (map (λ (p) (λ (s) (string-replace s p "")))
disallowed-strings)))
(when (not (directory-exists? *output-directory*))
(make-directory *output-directory*))
(let* ([links
(map make-graph-if-valid
results (map test-name tests) (range (length tests)))]
[table-data (get-table-data results)])
(make-report-page "graphs/report.html" table-data links))))
(define (command-result cmd) (string-trim (write-string (system cmd))))
(define (univariate-tests bench-dir)
(filter (λ (test) (= 1 (length (test-vars test))))
(load-all #:bench-path-string bench-dir)))
(define (get-test-results tests)
(progress-map get-test-result tests #:map-name "get-test-results" #:item-name-func test-name))
(define (progress-map f l #:map-name [name 'progress-map] #:item-name-func [item-name #f])
(define total (length l))
(idx-map
(λ (elt idx)
(let-values ([(results cpu-ms real-ms garbage-ms) (time-apply f (list elt))])
(println name ": " (quotient (* 100 (1+ idx)) total) "%\t"
"[" (~a real-ms #:width 8) " milliseconds]\t\t"
(if item-name (item-name elt) ""))
(car results)))
l))
(struct test-result (test start-alt end-alt points exacts time))
(define (get-test-result test)
(define (graph-folder-path tname index)
(let ([stripped-tname (strip-string tname)]
[index-label (number->string index)])
(string-append "graphs/" index-label
(substring stripped-tname 0
(min (string-length stripped-tname)
(- *graph-folder-name-length*
(string-length index-label))))
"/")))
(define (test-result test)
(define (compute-result orig)
(let-values ([(points exacts) (prepare-points orig)])
(parameterize ([*points* points] [*exacts* exacts])
(let* ([start-alt (make-alt orig)]
[end-alt (improve-with-points start-alt (*num-iterations*))])
(list start-alt end-alt points exacts)))))
(let ([start-prog (make-prog test)])
(let-values ([(start-end-points-exacts-list cpu-mil real-mil garbage-mill)
(time-apply (if *handle-crashes* (λ (orig)
(with-handlers ([(const #t) (λ _ (display "Crashed!\n") (make-list 4 '()))])
(compute-result orig)))
compute-result)
(list start-prog))])
(append (car start-end-points-exacts-list) (list real-mil)))))
(define (table-row results test)
(append (list (test-name test))
(if (null? (car results))
(append (make-list 5 "N/A") (list 'Yes))
(append (get-improvement-columns (car results) (cadr results) (test-output test)) (list 'No)))
(list (fifth results))))
(define (get-improvement-columns start end expected-output)
(let* ([start-errors (alt-errors start)]
[end-errors (alt-errors end)]
[diff (errors-difference start-errors end-errors)]
[annotated-diff (map list diff start-errors end-errors)]) ;; We use this annotated-diff because eventually we'll want to show in some way which points have inf improvement.
(let*-values ([(reals infs) (partition (compose reasonable-error? car) annotated-diff)]
[(good bad) (partition (compose positive? car) infs)])
(list (/ (apply + (map car reals)) (length reals))
(length good)
(length bad)
(alt-program end)
(if expected-output
(if (equal? expected-output (program-body (alt-program end))) 'Yes 'No)
"N/A")))))
(define (univariate-tests bench-dir)
(filter (λ (test) (= 1 (length (test-vars test))))
(load-all #:bench-path-string bench-dir)))
(define (handle-crash . _)
(println "Crashed!")
'(#f #f #f #f))
(define table-labels '("Name"
"Error Improvement"
"Points with Immeasurable Improvement"
"Points with Immeasurable Regression"
"Resulting Program"
"Passed Test"
"Crashed?"
"Time Taken (Milliseconds)"))
(define (bad? row)
(or (not (number? (list-ref row 7)))
(< 30000 (list-ref row 7))
(not (number? (list-ref row 1)))
(> -1 (list-ref row 1))
(eq? 'Yes (list-ref row 6))))
(define (good? row)
(and (not (bad? row))
(or (eq? 'Yes (list-ref row 5))
(< 5 (list-ref row 1)))))
(let ([start-prog (make-prog test)])
(define (get-test-results tests)
(progress-map test-result tests
#:map-name 'execute-tests
#:item-name-func test-name
#:show-time #t))
(define (get-table-data results tests)
(let ([rows (map table-row results tests)])
(append rows
`("Num Green", (length (filter good? rows))))))
(define (info-stamp cur-date cur-commit cur-branch)
(bold (text (date-year cur-date) " "
(date-month cur-date) " "
(date-day cur-date) ", "
(date-hour cur-date) ":"
(date-minute cur-date) ":"
(date-second cur-date)))
(newline)
(newline)
(bold (text "Commit: " cur-commit " on " cur-branch))
(newline)
(newline))
(define (strip-end num-chars string)
(substring string 0 (- (string-length string) num-chars)))
(define (command-result cmd) (strip-end 1 (write-string (system cmd))))
(define-values (start-end-points-exacts cpu-ms real-ms garbage-ms)
(time-apply
(λ (orig)
(with-handlers ([(const *handle-crashes*) handle-crash])
(compute-result orig)))
(list start-prog)))
(match (car start-end-points-exacts)
[`(,start ,end ,points ,exacts)
(test-result test start end points exacts real-ms)])))
;; Returns #t if the graph was sucessfully made, #f is we had a crash during
;; the graph making process, or the test itself crashed.
(define (make-graph-if-valid include-css result tname index)
(let ([dir (graph-folder-path tname index)])
(with-handlers ([(const #t) (λ _ #f)])
(if (not (null? (first result)))
(begin (when (not (directory-exists? dir)) (make-directory dir))
(make-graph (first result) (second result) (third result)
(fourth result) dir include-css)
#t)
#f))))
(define (make-report bench-dir)
(let ([cur-date (current-date)]
[commit (command-result "git rev-parse HEAD")]
[branch (command-result "git rev-parse --abbrev-ref HEAD")]
[tests (univariate-tests bench-dir)])
(let* ([results (get-test-results tests)]
[table-data (get-table-data results tests)])
(when (not (directory-exists? "graphs")) (make-directory "graphs"))
(let ([graph-results (map (curry make-graph-if-valid '("reports/graph.css"))
results
(map test-name tests)
(build-list (length tests) identity))])
(let* ([test-dirs (map (λ (t i) (string-append (graph-folder-path (test-name t) i) "graph.html"))
tests
(build-list (length tests) identity))]
[links (map (λ (dir result) (if result dir '()))
test-dirs graph-results)])
(write-file "report.md"
(info-stamp cur-date commit branch)
(make-table table-labels table-data
#:modifier-alist `((,bad? . red)
(,good? . green))
#:row-links links)))))))
(define (make-test-graph testpath)
(let ([result (test-result (car (load-all #:bench-path-string testpath)))]
[dir "../reports/graph/"])
(text "Making graph...\n")
(when (not (directory-exists? dir)) (make-directory dir))
(make-graph (first result) (second result) (third result) (fourth result) dir
'("../reports/graph.css"))))
;; No longer maintained
(define (make-dummy-report)
(let ([cur-date (current-date)]
[commit (with-output-to-string (lambda () (system "git rev-parse HEAD")))]
[branch (with-output-to-string (lambda () (system "git rev-parse --abbrev-ref HEAD")))])
(write-file "test.md"
(info-stamp cur-date commit branch)
(make-table '(A B C) '((1 2 3) (4 5 6) (7 8 9)) #:modifier-alist `((,(lambda (row) (> 3 (cadr row))) . green)
(,(lambda (row) (< 7 (cadr row))) . red))))))
(define (string-when test value)
(if test
value
""))
(define (progress-map f l #:map-name [name 'progress-map] #:item-name-func [item-name #f] #:show-time [show-time? #f])
(let ([total (length l)])
(let loop ([rest l] [acc '()] [done 1])
(if (null? rest)
(reverse acc)
(let-values ([(results cpu-mil real-mil garbage-mill) (time-apply f (list (car rest)))])
(println name
": "
(quotient (* 100 done) total)
"%\t["
(string-when show-time? (~a real-mil #:width 8))
(string-when show-time? " milliseconds]")
(string-when show-time? "\t\t")
(string-when item-name (item-name (car rest))))
(loop (cdr rest) (cons (car results) acc) (1+ done)))))))
(define (make-graph-if-valid result tname index)
(let* ([rdir (graph-folder-path tname index)]
[dir (build-path *output-directory* rdir)])
(with-handlers ([(const #f) (λ _ #f)])
(cond
[(test-result-end-alt result)
(when (not (directory-exists? dir))
(make-directory dir))
(make-graph (test-result-start-alt result)
(test-result-end-alt result)
(test-result-points result)
(test-result-exacts result)
(path->string dir)
'("reports/graph.css"))
(build-path rdir "graph.html")]
[else #f]))))
(define (graph-folder-path tname index)
(let* ([stripped-tname (string-replace tname #px"\\(| |\\)|/" "")]
[index-label (number->string index)]
[name-bound (- *graph-folder-name-length* (string-length index-label))]
[final-tname (substring stripped-tname 0 (min (string-length stripped-tname) name-bound))])
(string-append index-label final-tname "/")))
(struct table-row (name status delta inf- inf+ program time))
(define (get-table-data results)
(for/list ([result results])
(define name (test-name (test-result-test result)))
(cond
[(test-result-end-alt result)
(let* ([start-errors (alt-errors (test-result-start-alt result))]
[end-errors (alt-errors (test-result-end-alt result))]
[good-errors
(and (test-output (test-result-test result))
(errors (list (test-vars (test-result-test result))
(test-output (test-result-test result)))
(test-result-points result)
(test-result-exacts result)))]
[diff (errors-difference start-errors end-errors)]
[total-score (errors-score diff)]
[target-score (if good-errors (errors-diff-score end-errors good-errors) #f)])
(let*-values ([(reals infs) (partition reasonable-error? diff)]
[(good-inf bad-inf) (partition positive? infs)])
(table-row name
(cond
[(not good-errors) "no-compare"]
[(and target-score (> total-score (+ 1 target-score))) "gt-target"]
[(and target-score (< (abs (- total-score target-score)) 1)) "eq-target"]
[(< total-score -1) "lt-start"]
[(< total-score 1) "eq-start"]
[(and target-score (< total-score (- target-score 1))) "lt-target"])
(/ total-score (length diff))
(length good-inf)
(length bad-inf)
(alt-program (test-result-end-alt result))
(test-result-time result))))]
[else
(table-row name "crash" #f #f #f #f (test-result-time result))])))
(define (format-time ms)
(cond
[(< ms 1000) (format "~a ms" ms)]
[(< ms 60000) (format "~a s" (/ (round (/ ms 100.0)) 10))]
[(< ms 3600000) (format "~a m" (/ (round (/ ms 6000.0)) 10))]
[else (format "~a hr" (/ (round (/ ms 360000.0)) 10))]))
(define (make-report-page file table-data links)
(let ([commit (command-result "git rev-parse HEAD")]
[branch (command-result "git rev-parse --abbrev-ref HEAD")])
(define table-labels
'("Test" "Δ [bits]" "∞ → ℝ" "ℝ → ∞" "Program" "Time"))
(define-values (dir _name _must-be-dir?) (split-path file))
(copy-file-overwriting "reports/report.css"
(build-path dir "report.css"))
(write-file file
(printf "<!doctype html>\n")
(printf "<head>\n")
(printf "<title>Casio test results</title>\n")
(printf "<meta charset='utf-8' />")
(printf "<link rel='stylesheet' type='text/css' href='report.css' />")
(printf "</head>\n")
(printf "<body>\n")
(printf "<dl id='about'>\n")
(printf "<dt>Date:</dt><dl>~a</dl>\n" (date->string (current-date)))
(printf "<dt>Commit:</dt><dl>~a on ~a</dl>\n" commit branch)
(printf "</dl>\n")
(printf "<table id='results'>\n")
(printf "<thead><tr>")
(for ([label table-labels])
(printf "<th>~a</th>" label))
(printf "</tr></thead>\n")
(printf "<tbody>")
(for ([result table-data] [link links])
(printf "<tr class='~a'>" (table-row-status result))
(printf "<td>~a</td>" (or (table-row-name result) ""))
(printf "<td>~a</td>"
(if (table-row-delta result)
(/ (round (* (table-row-delta result) 10)) 10)
""))
(printf "<td>~a</td>" (or (table-row-inf- result) ""))
(printf "<td>~a</td>" (or (table-row-inf+ result) ""))
(printf "<td>~a</td>" (or (table-row-program result) ""))
(printf "<td>~a</td>" (format-time (table-row-time result)))
(when link
(printf "<td><a href='~a'>more</a></td>" (path->string link)))
(printf "</tr>\n"))
(printf "</tbody>\n")
(printf "</table>\n")
(printf "</body>\n")
(printf "</html>\n"))))
;(define (make-test-graph testpath)
; (let ([result (test-result (car (load-all #:bench-path-string testpath)))]
; [dir "../reports/graph/"])
; (text "Making graph...\n")
; (when (not (directory-exists? dir)) (make-directory dir))
; (make-graph (first result) (second result) (third result) (fourth result) dir
; '("../reports/graph.css"))))
(make-report
(command-line
#:program "make-report"
#:multi [("-d") "Turn On Debug Messages (Warning: Very Verbose)"
(*debug* #t)]
#:multi [("-d") "Turn On Debug Messages (Warning: Very Verbose)" (*debug* #t)]
#:args (bench-dir)
bench-dir))
Oops, something went wrong.

0 comments on commit 8615124

Please sign in to comment.