Racket plot code with css grid
While rushing to finish pasting .png files into a word processor document, I noticed that plots need a title for context. Maybe if I was able to completely avoid office software and stay with generated html pages it wouldn't matter as much, but while pasting images into documents it was hard to see which semester the plots belonged too.
The generated html page was ok when printed from firefox with the Landscape setting but the “float” layout broke with my laptop screen. Looking over css grid again helped with that issue. Printing to .pdf from Firefox is helpful but the files got really big for my recent pages with plot images..
code
#lang racket
;; set the directory in which to write plot images and web page
(define working-directory
(build-path (find-system-path 'home-dir)
"FD"
"FD201802H30Z-Synoptic-cssgrid"))
(unless (directory-exists? working-directory)
(make-directory working-directory))
(define img-ext-for-pge 'svg)
(define img-fle-for-pge (path-replace-extension
(build-path working-directory
"SynopticView")
(string-append "." (symbol->string img-ext-for-pge))))
(require plot) ;; discrete-histogram, stacked-histogram etc
(require plot/utils) ;; ->plot-label
(require scribble/html/html) ;; for output-xml, html and class:
(require scribble/html) ;; for element
(require racket/require)
(require (only-in srfi/1 iota))
(define bodies '(教員 学科 大学)) ;; Teacher, Department, University
;; short keys and labels for questions and data
(define quest-symbs '(出席 発言 取組 聞取 資料 時刻 反応 熱意 理解 役立 満足))
;; データを入力し直すところ
(define ind-als ;;教員の連帯リスト associative list
'((nme (教員 TCR スモール 教養))
(smr (2018 01 H30 Z)) ;; 学期 SeMesteR
(cls (1 84)) ;; 授業、教室 CLasS
(dta ((62 13 9 0 0) ;; データ、DaTA
(19 24 28 6 6)
(23 24 27 6 4)
(53 22 9 0 0)
(35 29 19 0 1)
(64 12 7 1 0)
(54 19 10 1 0)
(69 9 6 0 0)
(34 28 16 4 1)
(43 25 12 2 1)
(35 25 20 2 1)))))
(define dep-als ;;学科 associative list
'((nme (学科 DPT 教養 大学))
(smr (2018 01 H30 Z))
(cls (7 269))
(dta ((202 41 26 0 0)
(62 68 99 22 17)
(72 74 98 14 11)
(144 67 41 9 8)
(111 78 55 13 10)
(171 60 28 5 4)
(140 65 46 10 8)
(165 62 27 9 6)
(96 98 51 14 8)
(119 76 56 8 8)
(109 79 60 9 10)))))
(define uni-als ;;大学
'((nme (大学 UVY 南九州 学園))
(smr (2018 01 H30 Z))
(cls (59 2452))
(dta ((1738 472 206 23 8)
(495 549 923 195 283)
(713 765 736 162 65)
(1400 628 296 86 35)
(1264 630 384 110 55)
(1795 446 166 25 13)
(1378 654 317 59 38)
(1573 588 230 33 20)
(976 886 438 99 42)
(1411 684 289 33 24)
(1217 740 388 58 38)))))
(define als-ref
(lambda (idx als)
(let ((tmp (assv idx als)))
(if tmp (cadr tmp) #f))))
(define counts->percents
(lambda (lon) ;; list of numbers
(let ((total (apply + lon)))
(map (lambda (count)
(* (/ count total) 100.0))
lon))))
(define pnt-w-lbl
(lambda (x n l (algn 'bottom) (sze 8) (pnt-clr 0) (lbel-angl 0))
(point-label (vector x n) l #:anchor algn #:size sze #:point-color pnt-clr #:angle lbel-angl)))
(define vline-y1-to-y2
(lambda (x y1 y2 (clr 0)) ; y1 and y2 are percents
(list
(lines (map vector (list x x) (list 0 y1)) #:width 2 #:color clr)
(lines (map vector (list x x) (list y1 y2)) #:width 4 #:color clr))))
(define line-label ;; change name to line-label
;; xlevel percents, 4's count 5's count
;; defaults to positive line with anchor 'bottom
;; over-ride anchor with 'top fo negative direction
(lambda (x p4 p5 c4 c5 (lbl-aln 'bottom) (clr 0))
;; points always given with same sign +pos or -neg
(let ((p4n5 (+ p4 p5))
(cnt-lbl (string-join (map number->string (list (abs c4) (abs c5))) ":")))
(list
(pnt-w-lbl x p4n5 (->plot-label cnt-lbl) lbl-aln)
(vline-y1-to-y2 x p4 p4n5 clr))))) ;; 1 is #:color 1 (red)
(define stck-rslts
(lambda (row (x 5.5) (lbl-aln 'bottom)(clr 0) (sign +))
(let* ((cn5 (first row))
(cn4 (second row))
;; (x 5.5) ;; #:x-max will be 5.8
(pcnts (counts->percents row))
(pr5 (first pcnts))
(pr4 (second pcnts)))
(line-label x (sign pr4) (sign pr5) (sign cn4) (sign cn5) lbl-aln clr))))
(define pos-neg-stacked-lines-labeled-row
(lambda (row x)
(list
(stck-rslts row x 'bottom 1)
(stck-rslts (reverse row) x 'top 0 -))))
(define pos-neg-stacked-lines-labeled-rows3
(lambda (3rows x)
(list
(pos-neg-stacked-lines-labeled-row (car 3rows) (- x .30))
(pos-neg-stacked-lines-labeled-row (cadr 3rows) x)
(pos-neg-stacked-lines-labeled-row (caddr 3rows) (+ x .30)))))
(define pos-neg-stacked-lines-labeled-rows3-quesN
(lambda (d1 d2 d3) ;; data sets
;; number of rows = number of questions
(let ((qn (length d1)))
(define helper
;; remainders
(lambda (r1 r2 r3 n keep)
(cond
((> n qn) (reverse (cons (hrule 0 #:color 0) keep)))
(else (helper (cdr r1) (cdr r2) (cdr r3) (+ 1 n)
(cons keep
(cons
(pos-neg-stacked-lines-labeled-row (car r1) (- n .30))
(cons
(pos-neg-stacked-lines-labeled-row (car r2) n)
(pos-neg-stacked-lines-labeled-row (car r3) (+ n .30))))))))))
(helper d1 d2 d3 1 '()))))
(define NQs (map list (range 1 12) quest-symbs))
(define label-rows3
(lambda (xmid yval labels)
(list (point-label (vector (- xmid .30) yval) (car labels) #:anchor 'bottom #:point-size 0)
(point-label (vector xmid yval) (cadr labels) #:anchor 'bottom #:point-size 0)
(point-label (vector (+ xmid .30) yval) (caddr labels) #:anchor 'bottom #:point-size 0))))
(define plot-ttle (string-join (map ->plot-label (als-ref 'smr uni-als)) ""))
;; Synoptic View
(parameterize ((plot-x-ticks (linear-ticks #:number 11))
(plot-y-ticks (linear-ticks #:number 8))
(plot-x-far-axis? #f)
(plot-y-far-axis? #f))
(plot (cons (label-rows3 1 100 (list "教員" "学科" "大学"))
(cons (label-rows3 5 100 (list "教員" "学科" "大学"))
(cons (label-rows3 10 100 (list "教員" "学科" "大学"))
(cons (map (lambda (xval)
(lines (list (vector xval 90) (vector xval 99)) #:color -2 #:style 'dot))
(list .6 1.4 4.6 5.4 9.6 10.4))
(cons (map (lambda (nq) (point-label (vector (car nq) 105) (symbol->string (cadr nq))
#:anchor 'bottom #:size 12
#:point-color -1 #:point-size 0))
NQs)
(cons
(map (lambda (xval)
(lines (list (vector xval -40) (vector xval 0)) #:color -2 #:style 'dot))
(iota 12 .5 1))
(cons
(map (lambda (nq)
(point-label (vector (car nq) -40)
(symbol->string(cadr nq))
#:anchor 'bottom #:size 14
#:point-color -1 #:point-size 0))
NQs)
(list
(pos-neg-stacked-lines-labeled-rows3-quesN
(als-ref 'dta ind-als) (als-ref 'dta dep-als) (als-ref 'dta uni-als))))))))))
#:x-label "設問 questions" #:y-label "割合 percent"
#:x-min .3 #:x-max 11.7
#:y-min -40 #:y-max 110
#:width 1500 #:height 700
#:title plot-ttle
#:out-file img-fle-for-pge
#:out-kind img-ext-for-pge))
(define questions '(
(出席 "私はこの授業によく出席した" 学生取組)
(発言 "私は授業内容について質問や発言した" 学生取組)
(取組 "私はこの科目に積極的に取り組んだ(予習と復習した)" 学生取組)
(聞取 "教員の声は聞き取りやすかった。" 教員実施)
(資料 "教員の板書（またはPPT・配布資料など）は読みやすかった（見やすかった）" 教員実施)
(時刻 "教員は授業の開始・終了の時刻を守ろうとしていた" 教員実施)
(反応 "教員は学生の反応を確かめながら授業を進めていた" 教員実施)
(熱意 "教員は熱意を持って授業をしていた" 教員実施)
(理解 "私はこの授業内容を理解できた" 総合評価)
(役立 "私はこの授業で学んだ内容はなんらかの形で将来的に役立つと感じた" 総合評価)
(満足 "私は総合的に判断してこの授業で満足が得られた" 総合評価)))
(define Q-li
(lambda (qrow)
(li class: "question" (string-append (symbol->string (car qrow)) " : "
(cadr qrow)))))
(define Qs-ol
(lambda (qs)
(ol
(map Q-li qs))))
(define lst->row
(lambda (Qrslts)
(tr
(map td Qrslts))))
(define th-row
(lambda (rsp-txt-lst)
(define helper
(lambda (l n rsps keep)
(cond
((> n l) (reverse keep))
(else (helper l (+ 1 n) (cdr rsps)
(cons
(th
(string-append (number->string n) ":"
(symbol->string(cadar rsps))))
keep))))))
(helper (length rsp-txt-lst) 1 (reverse rsp-txt-lst) '())))
(define responses '((5 特に "特にそう思う" "very much" "I really think so")
(4 多少 "多少そう思う" "fairly much" "I somewhat think so")
(3 どちも "どちらともいえない" "neither" "I can't say either way")
(2 あまり "あまりそう思わない" "not much" "I do not think so much")
(1 全く "全くそう思わない" "not at all" "I do not think so at all")))
(define lsts->table
(lambda (als)
(table class: "results"
(caption (symbol->string (car (als-ref 'nme als))))
(th-row responses)
;; (map th (iota 5 1 1))
(map lst->row (map reverse (als-ref 'dta als))))))
(define R-li
(lambda (rrow) ;; results list for one question, a row
(li (string-append (symbol->string (cadr rrow)) " : " (caddr rrow)))))
(define Rs-ol
(lambda (rs) ;; results for a body: TCR, DPT, UVY
(ol
(map R-li (reverse rs)))))
(define output-synoptic-view-page
(lambda (als)
(let* ((year-strn (string-join (map ->plot-label (als-ref 'smr als)) ""))
(pge-ttl (string-append "FD アンケート結果 Synoptic View 共観 " year-strn)))
(call-with-output-file
(build-path working-directory
(string-append "FD-Questionnaire-Results-Synoptic-View" year-strn ".html"))
#:exists 'truncate
(lambda (out)
(output-xml (xhtml
(head (title pge-ttl)
(meta http-equiv: "Content-Type" content: "text/html;charset=utf-8")
(map style (list ;; saves ink/color to map style over a list of strings
"@page { size: 210mm 297mm; margin: 4mm 4mm 6mm 4mm; }"
"h2 {margin-top: 10px; margin-bottom: 10px; font-size: 14pt;} "
"h3 {margin-top: 8px; margin-bottom: 8px; }"
"div.questions-list { float: left; }"
"div.results-explanation {float:left;}"
"h3.image-explanation { margin-top: 5em; }"
"p.image-explanation { width: 20em; }"
"div.results-tables { margin-left: 1em; }"
"table.results { float: left; margin-left: 1em; }"
"table.restuls th { text-align: right; }"
"table.results td { text-align: right; width: 4em; }"
"div.wide-view { clear: left; }")))
(body (h2 pge-ttl)
(div class: "text-section questions-list"
(h3 class: "questions" "設問の文")
(Qs-ol questions))
(div class: "text-section results-explanation"
(h3 class: "results explanation" "結果の文")
(Rs-ol responses)
(h3 class: "text-section image-explanation" "図の説明")
(p class: "image-explanation"
"肯定的回答の4と5は正号の赤線、5は太い。" (br)
"否形的回答の1と2は負号の黒線、1は太い。"))
(div class: "text-section results-tables"
(h3 class: "results" "結果の表" )
(lsts->table ind-als)
(lsts->table dep-als)
(lsts->table uni-als))
(div class: "image-section wide-view"
(h3 class: "image" "結果の図")
(element 'img src: img-fle-for-pge))))
out))))))
(output-synoptic-view-page uni-als)
#DataVisualization #Racket #Plot #Programming #facdev #FacultyDevelopment