Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Cleanup reporting code: remove old version of pivot code

  • Loading branch information...
commit 15aa31e7141d2bf0b0e9c24fe21daa5502636d36 1 parent cb68ea3
@avodonosov avodonosov authored
View
13 reporting/distinct.lisp
@@ -4,19 +4,6 @@
(in-package #:test-grid-reporting)
-(defun distinct-old (prop-getter db &key (test #'equal) where)
- (let ((distinct (make-hash-table :test test)))
- (do-results (result db :where where)
- (let ((val (funcall prop-getter result)))
- (setf (gethash val distinct)
- val)))
- (alexandria:hash-table-keys distinct)))
-
-(defun largest-old (prop-getter db &key (count 1) (predicate #'string>) where)
- (let* ((all (distinct-old prop-getter db :where where))
- (sorted (sort all predicate)))
- (subseq sorted 0 count)))
-
(defun list-props (object prop-readers)
(mapcar (lambda (prop-reader)
(funcall prop-reader object))
View
434 reporting/pivot.lisp
@@ -4,139 +4,53 @@
(in-package #:test-grid-reporting)
-;; ========= Pivot Reports ==================
+;;; Pivot is essentially a grouping of items into cells.
+;;; Groupping is done by values of properties chosen for rows
+;;; and columns. Note that rotation of a pivot - i.e. moving
+;;; a field from rows to columns doesn't affect the grouping,
+;;; it is the same cells rotated.
+
+(defun group-by (items item-prop-readers)
+ (let ((h (make-hash-table :test #'equal)))
+ (dolist (item items)
+ (let ((key (list-props item item-prop-readers)))
+ (push item (gethash key h))))
+ h))
+
+(let ((groups (group-by '((:x 1 :y 2)
+ (:x 3 :y 2)
+ (:x 3 :y 7))
+ (list (test-grid-utils::plist-getter :x)))))
+ (assert
+ (alexandria:set-equal (gethash '(3) groups)
+ '((:x 3 :y 2)
+ (:x 3 :y 7))
+ :test #'equal))
+ (assert
+ (alexandria:set-equal (gethash '(1) groups)
+ '((:x 1 :y 2))
+ :test #'equal)))
+
+(let ((groups (group-by '((:x 1 :y 2)
+ (:x 5 :y 8)
+ (:x 5 :y 8)
+ (:x 6 :y 9))
+ (list
+ (test-grid-utils::plist-getter :x)
+ (test-grid-utils::plist-getter :y)))))
+ (assert
+ (equal (gethash '(1 2) groups)
+ '((:x 1 :y 2))))
+
+ (assert
+ (alexandria:set-equal (gethash '(5 8) groups)
+ '((:x 5 :y 8)
+ (:x 5 :y 8))
+ :test #'equal))
+ (assert
+ (equal (gethash '(6 9) groups)
+ '((:x 6 :y 9)))))
-;; Conceptualy, test results are objects with various fields:
-;; :libname, :lib-world, :lisp, :log-byte-size, :test-duration,
-;; :log-byte-length, etc.
-;;
-;; To build pivot reports, we need to access the
-;; results for the report table cells. Every table
-;; cell is lying on the crossing of the table rows
-;; and columns.
-;;
-;; In other words, we need to access test results for every
-;; combination of values for the fields we put into rows
-;; and columsn headers.
-;;
-;; Currently we want only 3 properties in the row or column
-;; headers: :lib-world, :lisp, :libname.
-;;
-;; Let's build the index - a hash table where keys are
-;; 3 element lists representing a particular combination
-;; of lib-world, libname and lisp; and the hash table value is
-;; a list of test results for that combination:
-;;
-;; ("sbcl-win-1" "quicklisp 1" "alexandria") -> (<test results>)
-;; ("sbcl-win-1" "quicklisp 1" "babel") -> (<test results>)
-;; ("sbcl-linux-1" "quicklisp 1" "alexandria") -> (<test results>)
-;; ("sbcl-linux-1" "quicklisp 2" "alexandria") -> (<test results>)
-;; ("clisp-win-1" "quicklisp 2" "flexi-streams") -> (<test results>)
-;; ...
-;;
-
-(defun build-joined-index (db &key where)
- (let ((all-results (make-hash-table :test 'equal)))
- (do-results (record db :where where)
- (push record
- (gethash (list (lisp record) (lib-world record) (libname record))
- all-results)))
- all-results))
-
-;; The pivot reports code below does not know exact form
-;; of the index key - in what order lib-world, lisp and libname
-;; values are specified in the key. Moreover, the pivot reports code
-;; does not know we chosen only these 3 properties for the pivot table
-;; headers - it receives the property names for row and column headers
-;; as parameters. All what the pivot code below knows, is that the
-;; index is a hash table where keys store field values somehow,
-;; and that the hash tabble values are lists of results.
-;;
-;; To abstract away the index format we provide the following functions:
-
-(defun make-index-key ()
- (make-sequence 'list 3))
-
-(defun make-fields-values-setter (fields)
- "Returns a function accepting index key
-as the first parameter, list of field values the second parameters,
-and destructively modifies the index key by setting the field
-values in it. Names of fields to modify in the index key,
-and their order is specified by FIELDS."
- (let ((index-key-setters (list :lisp #'(lambda (index-key lisp)
- (setf (first index-key) lisp))
- :lib-world #'(lambda (index-key lib-world)
- (setf (second index-key) lib-world))
- :libname #'(lambda (index-key libname)
- (setf (third index-key) libname)))))
- (flet ((field-setter (field)
- (or (getf index-key-setters field)
- (error "field ~A is unknown" field))))
- (let ((setters (mapcar #'field-setter fields)))
- #'(lambda (index-key field-vals)
- (mapc #'(lambda (setter field-val)
- (funcall setter index-key field-val))
- setters
- field-vals)
- index-key)))))
-
-(defun make-fields-values-getter (fields)
- "Returns a function accepting and index key as a parameter,
-and returning a list of field values from that index key.
-The field names to retrieve, and their order in the
-returned list is specified by FIELDS."
- (let ((index-key-getters (list :lisp #'first
- :lib-world #'second
- :libname #'third)))
- (flet ((field-getter (field)
- (or (getf index-key-getters field)
- (error "field ~A is unknown" field))))
- (let ((getters (mapcar #'field-getter fields)))
- #'(lambda (index-key)
- (mapcar #'(lambda (getter)
- (funcall getter index-key))
- getters))))))
-
-;; Lets introduce a notion of row and columns addresses.
-;; An address is a list with values for the fields
-;; we put into the row or column header.
-;;
-;; For example, if we want a privot report with lisp
-;; implementations as columns, and lisp-world and
-;; library name as rows, then we may have column
-;; addresses like
-;; ("sbcl-win-1.0.55")
-;; ("clisp-win-2.49")
-;; ("abcl-1.1")
-;; and row addresses like
-;; ("quickisp 2012-02-03" "alexandria")
-;; ("quickisp 2012-02-03" "babel")
-;; ("quickisp 2012-03-03" "cl-json")
-;;
-;; Order of values in the address depends on the order
-;; of grouping we chosen for pivot reports. In the above
-;; row addresses lib-worlds are larger groups, and for
-;; every lib-world we enumerate library names. In another
-;; pivot report we may want other way around: to first group
-;; data by libnames, and then subdivide these groups by
-;; lib-worlds. In this case row addresses would be
-;; ("alexandria" "quickisp 2011-12-07" )
-;; ("alexandria" "quickisp 2012-01-03" )
-;; ("alexandria" "quickisp 2012-02-03" )
-;; ("babel" "quickisp 2011-12-07" )
-;; ("babel" "quickisp 2012-02-03" )
-;;
-
-(defun distinct-addresses (joined-index address-fields)
- (let ((distinct (make-hash-table :test #'equal))
- (fields-getter (make-fields-values-getter address-fields)))
- (maphash #'(lambda (index-key unused-index-value)
- (declare (ignore unused-index-value))
- (setf (gethash (funcall fields-getter index-key)
- distinct)
- t))
- joined-index)
- (test-grid-utils::hash-table-keys distinct)))
;; Take into account the specifics of HTML tables - the
;; headers which group several rows or columns, will
@@ -164,14 +78,43 @@ returned list is specified by FIELDS."
;;
;; When printing the table row by row, cell by cell, we need to know
;; what will be rowspan or colspan for particular <th> cell,
-;; and whether the row we are currently printing should have the
+;; and whether the row we are currently printing should have the
;; <th rowspan="Y"> element, or the TH was already printed in a
-;; previous row in the same group. (Similar for <th colspan="X">
+;; previous row in the same group. (Similar for <th colspan="X">
;; elements in the rolumn headers).
;;
;; Lets precalculate some usefull information, which will allow
;; us to make the correct decision.
;;
+;; We use a notion of row and columns addresses.
+;; An address is a list with values for the fields
+;; we put into the row or column header.
+;;
+;; For example, if we want a privot report with lisp
+;; implementations as columns, and lisp-world and
+;; library name as rows, then we may have column
+;; addresses like
+;; ("sbcl-win-1.0.55")
+;; ("clisp-win-2.49")
+;; ("abcl-1.1")
+;; and row addresses like
+;; ("quickisp 2012-02-03" "alexandria")
+;; ("quickisp 2012-02-03" "babel")
+;; ("quickisp 2012-03-03" "cl-json")
+;;
+;; Order of values in the address depends on the order
+;; of grouping we chosen for pivot reports. In the above
+;; row addresses lib-worlds are larger groups, and for
+;; every lib-world we enumerate library names. In another
+;; pivot report we may want other way around: to first group
+;; data by libnames, and then subdivide these groups by
+;; lib-worlds. In this case row addresses would be
+;; ("alexandria" "quickisp 2011-12-07" )
+;; ("alexandria" "quickisp 2012-01-03" )
+;; ("alexandria" "quickisp 2012-02-03" )
+;; ("babel" "quickisp 2011-12-07" )
+;; ("babel" "quickisp 2012-02-03" )
+
;; A helper function:
(defun subaddrs (row-address)
"Subaddress is a prefix of row or column address.
@@ -182,12 +125,12 @@ Every subaddress represents some level of pivot groupping."
(subaddrs '(1 2 3))))
;; Note, that every address of length N has
-;; N subaddresses.
+;; N subaddresses.
;; E.g. (length (subaddrs '("x" "y" "z"))) == 3.
;;
-;; And note also that every subadderss is a column
+;; And note also that every subadderss is a column
;; in a row header, or a row in a column header.
-;;
+;;
;; [ ql ]
;; [ lisp]
;; [ lib ]
@@ -197,12 +140,12 @@ Every subaddress represents some level of pivot groupping."
;; and row headers need only one column.
;;
;; Column addresses contains two components:
-;; quicklisp name and lisp name:
+;; quicklisp name and lisp name:
;; ("quicklisp 2012-01-08" "ccl-1"),
-;; ("quicklisp 2012-01-08" "clisp-2"),
+;; ("quicklisp 2012-01-08" "clisp-2"),
;; and the table column headers occupy two rows.
-;; For every subaddress (group) we calculate it's span
+;; For every subaddress (group) we calculate it's span
;; (number of rows/columns in the group),
;; and store a flag, whether we already printed
;; the <th>.
@@ -305,14 +248,17 @@ Every subaddress represents some level of pivot groupping."
(format out "</tr>~%"))
(format out "</thead>~%")))
-(defun pivot-table-html (out
- joined-index
- row-fields row-fields-sort-predicates
- col-fields col-fields-sort-predicates
- cell-formatter)
+;;; Several versions of pivot-table-html, different in how the
+;;; the parameters are specified.
+
+(defun pivot-table-html2 (out
+ objects
+ row-field-getters row-fields-sort-predicates
+ col-field-getters col-fields-sort-predicates
+ cell-formatter)
- (assert (= (length row-fields) (length row-fields-sort-predicates)))
- (assert (= (length col-fields) (length col-fields-sort-predicates)))
+ (assert (= (length row-field-getters) (length row-fields-sort-predicates)))
+ (assert (= (length col-field-getters) (length col-fields-sort-predicates)))
(princ "<table border=\"1\" class=test-table>" out)
@@ -322,35 +268,51 @@ Every subaddress represents some level of pivot groupping."
(col-comparator #'(lambda (cola colb)
(test-grid-utils::list< col-fields-sort-predicates
cola colb)))
- (rows (sort (distinct-addresses joined-index row-fields)
+ (rows (sort (distinct objects row-field-getters)
row-comparator))
(row-spans (calc-spans rows))
- (cols (sort (distinct-addresses joined-index col-fields)
+ (cols (sort (distinct objects col-field-getters)
col-comparator))
- ;; this index key will be destructively modified
- ;; when we need to access the data, to avoid
- ;; consing of creation of new indexe every time
- ;; (is it a prelimenary optimization?)
- (index-key (make-index-key))
- (rows-fields-setter (make-fields-values-setter row-fields))
- (cols-fields-setter (make-fields-values-setter col-fields)))
-
- (print-col-headers (length row-fields) (length col-fields) cols out)
- (flet ((test-results-by-row-col (row-addr col-addr)
- (funcall rows-fields-setter index-key row-addr)
- (funcall cols-fields-setter index-key col-addr)
- (gethash index-key joined-index)))
+ (cells (group-by objects (append row-field-getters col-field-getters))))
+
+ (print-col-headers (length row-field-getters) (length col-field-getters) cols out)
+ (flet ((cell-objects (row-addr col-addr)
+ (gethash (append row-addr col-addr) cells)))
(dolist (row rows)
(princ "<tr>" out)
(print-row-header row row-spans out)
(dolist (col cols)
- (let ((lib-results (test-results-by-row-col row col)))
- (princ "<td>" out)
- (funcall cell-formatter out lib-results)
- (princ "</td>" out)))
+ (princ "<td>" out)
+ (funcall cell-formatter out (cell-objects row col))
+ (princ "</td>" out))
(format out "</tr>~%"))))
(princ "</table>" out))
+(defun pivot-table-html3 (out objects &key rows cols cell-printer)
+ "Another version of PIVOT-TABLE-HTML, more convenient parameters."
+ (assert (every (lambda (r) (and (first r) (second r)))
+ rows)
+ nil
+ "ROWS elements must have two elements: accessor function and sorting predicate")
+ (assert (every (lambda (c) (and (first c) (second c)))
+ cols)
+ nil
+ "COLS elements must have two elements: accessor function and sorting predicate")
+ (let ((row-field-getters (mapcar (lambda (x) (coerce (first x) 'function)) rows))
+ (row-fields-sort-predicates (mapcar #'second rows))
+ (col-field-getters (mapcar (lambda (x) (coerce (first x) 'function)) cols))
+ (col-fields-sort-predicates (mapcar #'second cols)))
+ (pivot-table-html2 out
+ objects
+ row-field-getters row-fields-sort-predicates
+ col-field-getters col-fields-sort-predicates
+ cell-printer)))
+
+(defun pivot-table-html4 (objects &key rows cols cell-printer)
+ "Another version of PIVOT-TABLE-HTML, now a function - returns STRING"
+ (with-output-to-string (s)
+ (pivot-table-html3 s objects :rows rows :cols cols :cell-printer cell-printer)))
+
(defun pivot-report (out pivot-table reports-root-dir-relative-path)
(let ((html-template:*string-modifier* #'cl:identity))
(html-template:fill-and-print-template (src-file "pivot-report-template.html")
@@ -359,7 +321,6 @@ Every subaddress represents some level of pivot groupping."
:reports-root-dir-relative-path reports-root-dir-relative-path)
:stream out)))
-;; New pivot report printing function
(defun print-pivot (file-name
objects
&key rows cols cell-printer)
@@ -370,71 +331,74 @@ Every subaddress represents some level of pivot groupping."
:cell-printer cell-printer)
(reports-root-dir-relative-path file-name))))
-(defun pivot-report-old (out
- reports-root-dir-relative-path
- joined-index
- row-fields row-fields-sort-predicates
- col-fields col-fields-sort-predicates
- &optional (cell-formatter #'format-lib-results))
-"Deprecated. Use PIVOT-REPORT."
- (pivot-report out
- (with-output-to-string (str)
- (pivot-table-html str
- joined-index
- row-fields row-fields-sort-predicates
- col-fields col-fields-sort-predicates
- cell-formatter))
- reports-root-dir-relative-path))
-
-(defun print-old-pivots (joined-index)
- (flet ((print-report (filename
- row-fields row-fields-sort-predicates
- col-fields col-fields-sort-predicates)
- (with-report-file (out filename)
- (pivot-report-old out
- (reports-root-dir-relative-path filename)
- joined-index
- row-fields row-fields-sort-predicates
- col-fields col-fields-sort-predicates))))
-
- (print-report "pivot_ql_lisp-lib.html"
- '(:lib-world) (list #'string>)
- '(:lisp :libname) (list #'string< #'string<))
- (print-report "pivot_ql_lib-lisp.html"
- '(:lib-world) (list #'string>)
- '(:libname :lisp) (list #'string< #'string<))
-
- (print-report "pivot_lisp_lib-ql.html"
- '(:lisp) (list #'string<)
- '(:libname :lib-world) (list #'string< #'string>))
- (print-report "pivot_lisp_ql-lib.html"
- '(:lisp) (list #'string<)
- '(:lib-world :libname) (list #'string> #'string<))
-
- (print-report "pivot_lib_lisp-ql.html"
- '(:libname) (list #'string<)
- '(:lisp :lib-world) (list #'string< #'string>))
- (print-report "pivot_lib_ql-lisp.html"
- '(:libname) (list #'string<)
- '(:lib-world :lisp) (list #'string> #'string<))
-
- (print-report "pivot_ql-lisp_lib.html"
- '(:lib-world :lisp) (list #'string> #'string<)
- '(:libname) (list #'string<))
- (print-report "pivot_ql-lib_lisp.html"
- '(:lib-world :libname) (list #'string> #'string<)
- '(:lisp) (list #'string<))
-
- (print-report "pivot_lisp-lib_ql.html"
- '(:lisp :libname) (list #'string< #'string<)
- '(:lib-world) (list #'string>))
- (print-report "pivot_lisp-ql_lib.html"
- '(:lisp :lib-world) (list #'string< #'string>)
- '(:libname) (list #'string<))
-
- (print-report "pivot_lib-lisp_ql.html"
- '(:libname :lisp) (list #'string< #'string<)
- '(:lib-world) (list #'string>))
- (print-report "pivot_lib-ql_lisp.html"
- '(:libname :lib-world) (list #'string< #'string>)
- '(:lisp) (list #'string<))))
+(defun print-old-pivots (db quicklisps)
+ (let* ((results (list-lib-results db
+ :where (lambda (lib-result)
+ (member (lib-world lib-result)
+ quicklisps
+ :test #'string=)))))
+ (print-pivot "pivot_ql_lisp-lib.html"
+ results
+ :rows '((lib-world string>))
+ :cols '((lisp string<) (libname string<))
+ :cell-printer #'format-lib-results)
+ (print-pivot "pivot_ql_lib-lisp.html"
+ results
+ :rows '((lib-world string>))
+ :cols '((libname string<) (lisp string<))
+ :cell-printer #'format-lib-results)
+
+ (print-pivot "pivot_lisp_lib-ql.html"
+ results
+ :rows '((lisp string<))
+ :cols '((libname string<) (lib-world string>))
+ :cell-printer #'format-lib-results)
+ (print-pivot "pivot_lisp_ql-lib.html"
+ results
+ :rows '((lisp string<))
+ :cols '((lib-world string>) (libname string<))
+ :cell-printer #'format-lib-results)
+
+ (print-pivot "pivot_lib_lisp-ql.html"
+ results
+ :rows '((libname string<))
+ :cols '((lisp string<) (lib-world string>))
+ :cell-printer #'format-lib-results)
+ (print-pivot "pivot_lib_ql-lisp.html"
+ results
+ :rows '((libname string<))
+ :cols '((lib-world string>) (lisp string<))
+ :cell-printer #'format-lib-results)
+
+ (print-pivot "pivot_ql-lisp_lib.html"
+ results
+ :rows '((lib-world string>) (lisp string<))
+ :cols '((libname string<))
+ :cell-printer #'format-lib-results)
+ (print-pivot "pivot_ql-lib_lisp.html"
+ results
+ :rows '((lib-world string>) (libname string<))
+ :cols '((lisp string<))
+ :cell-printer #'format-lib-results)
+
+ (print-pivot "pivot_lisp-lib_ql.html"
+ results
+ :rows '((lisp string<) (libname string<))
+ :cols '((lib-world string>))
+ :cell-printer #'format-lib-results)
+ (print-pivot "pivot_lisp-ql_lib.html"
+ results
+ :rows '((lisp string<) (lib-world string>))
+ :cols '((libname string<))
+ :cell-printer #'format-lib-results)
+
+ (print-pivot "pivot_lib-lisp_ql.html"
+ results
+ :rows '((libname string<) (lisp string<))
+ :cols '((lib-world string>))
+ :cell-printer #'format-lib-results)
+ (print-pivot "pivot_lib-ql_lisp.html"
+ results
+ :rows '((libname string<) (lib-world string>))
+ :cols '((lisp string<))
+ :cell-printer #'format-lib-results)))
View
108 reporting/pivot2.lisp
@@ -1,108 +0,0 @@
-;;;; -*- Mode: LISP; Syntax: COMMON-LISP; indent-tabs-mode: nil; coding: utf-8; show-trailing-whitespace: t -*-
-;;;; Copyright (C) 2011 Anton Vodonosov (avodonosov@yandex.ru)
-;;;; See LICENSE for details.
-
-(in-package #:test-grid-reporting)
-
-(defun group-by (items item-prop-readers)
- (let ((h (make-hash-table :test #'equal)))
- (dolist (item items)
- (let ((key (list-props item item-prop-readers)))
- (push item (gethash key h))))
- h))
-
-(let ((groups (group-by '((:x 1 :y 2)
- (:x 3 :y 2)
- (:x 3 :y 7))
- (list (test-grid-utils::plist-getter :x)))))
- (assert
- (alexandria:set-equal (gethash '(3) groups)
- '((:x 3 :y 2)
- (:x 3 :y 7))
- :test #'equal))
- (assert
- (alexandria:set-equal (gethash '(1) groups)
- '((:x 1 :y 2))
- :test #'equal)))
-
-(let ((groups (group-by '((:x 1 :y 2)
- (:x 5 :y 8)
- (:x 5 :y 8)
- (:x 6 :y 9))
- (list
- (test-grid-utils::plist-getter :x)
- (test-grid-utils::plist-getter :y)))))
- (assert
- (equal (gethash '(1 2) groups)
- '((:x 1 :y 2))))
-
- (assert
- (alexandria:set-equal (gethash '(5 8) groups)
- '((:x 5 :y 8)
- (:x 5 :y 8))
- :test #'equal))
- (assert
- (equal (gethash '(6 9) groups)
- '((:x 6 :y 9)))))
-
-(defun pivot-table-html2 (out
- objects
- row-field-getters row-fields-sort-predicates
- col-field-getters col-fields-sort-predicates
- cell-formatter)
-
- (assert (= (length row-field-getters) (length row-fields-sort-predicates)))
- (assert (= (length col-field-getters) (length col-fields-sort-predicates)))
-
- (princ "<table border=\"1\" class=test-table>" out)
-
- (let* ((row-comparator #'(lambda (rowa rowb)
- (test-grid-utils::list< row-fields-sort-predicates
- rowa rowb)))
- (col-comparator #'(lambda (cola colb)
- (test-grid-utils::list< col-fields-sort-predicates
- cola colb)))
- (rows (sort (distinct objects row-field-getters)
- row-comparator))
- (row-spans (calc-spans rows))
- (cols (sort (distinct objects col-field-getters)
- col-comparator))
- (cells (group-by objects (append row-field-getters col-field-getters))))
-
- (print-col-headers (length row-field-getters) (length col-field-getters) cols out)
- (flet ((cell-objects (row-addr col-addr)
- (gethash (append row-addr col-addr) cells)))
- (dolist (row rows)
- (princ "<tr>" out)
- (print-row-header row row-spans out)
- (dolist (col cols)
- (princ "<td>" out)
- (funcall cell-formatter out (cell-objects row col))
- (princ "</td>" out))
- (format out "</tr>~%"))))
- (princ "</table>" out))
-
-(defun pivot-table-html3 (out objects &key rows cols cell-printer)
- "Another version of PIVOT-TABLE-HTML, more convenient parameters."
- (assert (every (lambda (r) (and (first r) (second r)))
- rows)
- nil
- "ROWS elements must have two elements: accessor function and sorting predicate")
- (assert (every (lambda (c) (and (first c) (second c)))
- cols)
- nil
- "COLS elements must have two elements: accessor function and sorting predicate")
- (let ((row-field-getters (mapcar (lambda (x) (coerce (first x) 'function)) rows))
- (row-fields-sort-predicates (mapcar #'second rows))
- (col-field-getters (mapcar (lambda (x) (coerce (first x) 'function)) cols))
- (col-fields-sort-predicates (mapcar #'second cols)))
- (pivot-table-html2 out
- objects
- row-field-getters row-fields-sort-predicates
- col-field-getters col-fields-sort-predicates
- cell-printer)))
-
-(defun pivot-table-html4 (objects &key rows cols cell-printer)
- "Another version of PIVOT-TABLE-HTML, now a function - returns STRING"
- (with-output-to-string (s)
- (pivot-table-html3 s objects :rows rows :cols cols :cell-printer cell-printer)))
View
122 reporting/regressions.lisp
@@ -179,125 +179,3 @@ The function OF-TYPE-P below implements the described type predicates.
(assert (has-regressions-p :timeout '()))
(assert (has-regressions-p :timeout :crash))
(assert (not (has-regressions-p :fail :crash)))
-
-;; Diff item represent two results
-;; of the same library under the same lisp,
-;; but in different versions of quicklisp disto.
-(defclass quicklisp-diff-item ()
- ((libname :initarg :libname :accessor libname)
- (lisp :initarg :lisp :accessor lisp)
- (new-result :initarg :new-result :accessor new-result)
- (old-result :initarg :old-result :accessor old-result)))
-
-(defun new-status (quicklisp-diff-item)
- (status (new-result quicklisp-diff-item)))
-
-(defun old-status (quicklisp-diff-item)
- (status (old-result quicklisp-diff-item)))
-
-;; Diff of two quicklisp distro versions.
-(defclass quicklisp-diff ()
- (;; diff-items where new quicklisp distro version has regressions
- ;; comparing to old version (note, at the same time
- ;; it may have improvements.
- ;;
- ;; For example previously test-a and test-b
- ;; failed, but in the new version test-a and test-c fail.
- ;; test-c is a regression - it fails now but not previously;
- ;; test-b is an improvement - it failed previously but not now;
- ;;
- ;; Independently on improvements presense, if the library
- ;; has regressiosn in new version, the quicklisp-diff-item
- ;; is put into the have-regressions list.
- (have-regressions :type list :initform '() :accessor have-regressions)
- ;; Here we put quicklisp-diff-itmes for libraries
- ;; which have only improvements in the new quicklisp distro
- ;; version.
- (imrovements-only :type list :initform '() :accessor improvements-only)))
-
-(defun compare-quicklisps (db-index quicklisp-new quicklisp-old)
- "Returns QUICKLISP-DIFF for the two quicklisp distro versions
-specified by QUICKLISP-NEW and QUICKLISP-OLD."
- (let* ((diff (make-instance 'quicklisp-diff))
- (lib-world-getter* (make-fields-values-getter '(:lib-world)))
- (lib-world-setter* (make-fields-values-setter '(:lib-world)))
- (lisp-getter* (make-fields-values-getter '(:lisp)))
- ;; todo: use alexandria:compose
- (lib-world-getter (lambda (index-key) (car (funcall lib-world-getter* index-key))))
- (lib-world-setter (lambda (index-key lib-world)
- (funcall lib-world-setter* index-key (list lib-world))))
- (lisp-getter (lambda (index-key) (car (funcall lisp-getter* index-key))))
- (new-quicklisp-keys (remove quicklisp-new
- (test-grid-utils::hash-table-keys db-index)
- :key lib-world-getter
- :test (complement #'string=))))
- (dolist (key new-quicklisp-keys)
- (let ((key-prev (copy-list key)))
- (funcall lib-world-setter key-prev quicklisp-old)
- (let ((results (gethash key db-index))
- (results-prev (gethash key-prev db-index)))
- (dolist (joined-lib-result results)
- (let ((status (getf (lib-result joined-lib-result) :status)))
- (dolist (joined-lib-result-prev results-prev)
- (let ((status-prev (getf (lib-result joined-lib-result-prev) :status)))
- (flet ((make-diff-item ()
- (make-instance 'quicklisp-diff-item
- :libname (getf (lib-result joined-lib-result) :libname)
- :lisp (funcall lisp-getter key)
- :new-result joined-lib-result
- :old-result joined-lib-result-prev)))
- (cond ((has-regressions-p status status-prev)
- (push (make-diff-item)
- (have-regressions diff)))
- ((has-regressions-p status-prev status)
- (push (make-diff-item)
- (improvements-only diff))))))))))))
- ;; order our results-diff report by library name
- (setf (have-regressions diff)
- (sort (have-regressions diff) #'string< :key #'libname))
- (setf (improvements-only diff)
- (sort (improvements-only diff) #'string< :key #'libname))
- diff))
-
-(defun print-quicklisp-diff (destination ql-new ql-old quicklisp-diff)
- (flet ((print-diff-item (diff-item)
- (let ((*print-pretty* nil))
- (format destination "~a, ~a:~%~a: <a class=\"~a\" href=\"~a\">~a</a>~%~a: <a class=\"~A\" href=\"~a\">~a</a>~%~%"
- (string-downcase (libname diff-item))
- (lisp diff-item)
- ql-new
- (status-css-class (aggregated-status (status (new-result diff-item))))
- (log-uri (new-result diff-item))
- (status (new-result diff-item))
- ql-old
- (status-css-class (aggregated-status (status (old-result diff-item))))
- (log-uri (old-result diff-item))
- (status (old-result diff-item))))))
- (format destination "~%~%***************************************************************************~%")
- (format destination "* test results diff between ~A and ~A *~%" ql-new ql-old)
- (format destination "***************************************************************************~%~%")
- (format destination "************* Have Regressions *************~%")
- (dolist (diff-item (have-regressions quicklisp-diff))
- (print-diff-item diff-item))
- (format destination "************* Improvements Only *************~%")
- (dolist (diff-item (improvements-only quicklisp-diff))
- (print-diff-item diff-item))))
-
-(defun print-all-quicklisps-diff-report (destination joined-index)
- (format destination "<html><head>~%")
- (format destination " <title>Quicklisps Diff - CL Test Grid</title>~%")
- (format destination " <link href=\"style.css\" rel=\"stylesheet\"/><head>~%")
- (format destination "<head>~%")
- (format destination "<body><pre>~%")
- (let ((quicklisps (mapcar #'car (distinct-addresses joined-index '(:lib-world)))))
- (loop
- for qls on (sort quicklisps #'string>)
- do (let ((ql-new (first qls))
- (ql-old (second qls)))
- (when ql-old ;; not reached the end of list yet
- (print-quicklisp-diff destination
- ql-new
- ql-old
- (compare-quicklisps joined-index ql-new ql-old))))))
- (format destination "</pre></body>~%")
- (format destination "</html>~%"))
View
42 reporting/reporting.lisp
@@ -53,25 +53,24 @@
(defun filter-lib-results (db predicate)
(test-grid-data::updated-plist db :runs
(mapcar (lambda (run)
- (test-grid-data::updated-plist run :results
- (remove-if-not (lambda (lib-result)
- (funcall predicate lib-result run))
- (getf run :results))))
+ (tg-data::updated-plist run :results
+ (remove-if-not (lambda (lib-result)
+ (funcall predicate lib-result run))
+ (getf run :results))))
(getf db :runs))))
(defun generate-reports (db)
- (let* (;; Old reports can work only with lib-result objects representing
+ (let* ((all-results (my-time ("list-results...")
+ (list-results db)))
+ (last-three-quicklisps (largest #'lib-world all-results :count 3))
+ (new-quicklisp (first last-three-quicklisps))
+ (prev-quicklisp (second last-three-quicklisps))
+ ;; Old reports can work only with lib-result objects representing
;; testsuite results, but not load tests.
;; Compute filtered DB where only testsuite results are persent.
- (filtered-db (my-time ("filter-lib-results...")
- (filter-lib-results db (lambda (lib-result test-run)
- (declare (ignore test-run))
- (getf lib-result :status)))))
- (all-results (my-time ("list-results...")
- (list-results db)))
- (last-two-quicklisps (largest #'lib-world all-results :count 2))
- (new-quicklisp (first last-two-quicklisps))
- (prev-quicklisp (second last-two-quicklisps)))
+ (filtered-db (filter-lib-results db (lambda (lib-result test-run)
+ (declare (ignore test-run))
+ (getf lib-result :status)))))
(my-time ("test runs..")
(with-report-file (out "test-runs-report.html")
@@ -81,18 +80,8 @@
(with-report-file (out "export.csv")
(export-to-csv out filtered-db)))
- (let* ((last-lib-worlds (largest-old 'lib-world filtered-db :count 3))
- (joined-index (my-time ("build-joined-index...")
- (build-joined-index filtered-db :where (lambda (record)
- (member (lib-world record)
- last-lib-worlds
- :test #'string=))))))
- (my-time ("pivot reports...~%")
- (print-old-pivots joined-index))
-
- (my-time ("old Quicklisp diff report...~%")
- (with-report-file (out "quicklisp-diff-old.html")
- (print-all-quicklisps-diff-report out joined-index))))
+ (my-time ("old pivot reports...~%")
+ (print-old-pivots filtered-db last-three-quicklisps))
(my-time ("Quicklisp diff...~%")
(print-quicklisp-diff-report "quicklisp-diff.html"
@@ -103,7 +92,6 @@
(my-time ("library reports...")
(print-library-reports all-results))
- (print-demo-reports all-results)
(print-compiler-reports all-results new-quicklisp)))
(defun print-compiler-reports (all-results new-quicklisp)
View
1  test-grid-reporting.asd
@@ -22,7 +22,6 @@
(:file "test-runs")
(:file "csv")
(:file "pivot")
- (:file "pivot2")
(:file "quicklisp-diff")
(:file "library-report")
(:file "regressions")
Please sign in to comment.
Something went wrong with that request. Please try again.