Racket Plot: Faceted View of Questionnaire Data
This code was broken for a while, the .png-generation portion is still too repetitive. The code takes questionnaire results and provides a faceted (R ggplot2-like) view with an .html page that list questions with a visualization of their results for the individual, the individual's department(faculty), and the department's(faculty's) university.
Experience with Racket's path utilities over the past weeks (and today's discovery that regexp-replace works with paths!) helped to clean up the part that filters plot images.
Other work demands attention and time, but it's awful to leave code in a broken state.
code
#lang racket
(define working-directory (build-path (find-system-path 'home-dir)
"FD"
"FD201801H30K-0408-2"))
(make-directory* working-directory)
(define page-plot-type 'svg)
(define page-plot-strn (symbol->string page-plot-type))
(define shre-bmps-type 'png) ;; was bitmap-plot-type
(define shre-bmps-strn (symbol->string shre-bmps-type))
(define bmps-dir (symbol->string shre-bmps-type))
(make-directory* (path->complete-path bmps-dir working-directory))
(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
;; set the order of images in output page
(define bodies '(教員 学科 大学)) ;; Teacher, Department, University
;; short keys and labels for questions and data
(define quest-symbs '(出席 発言 取組 聞取 資料 時刻 反応 熱意 理解 役立 満足))
;; データを入力し直すところ
(define ind-als ;;教員の連帯リスト associative list
'((nme (教員 TCR スモール 教養)) ;; NaME of BoDy bod 体
(smr (2018 02 H30 K)) ;; 学期 SeMesteR
(cls (1 68)) ;; 授業、教室 CLasS
(dta ((33 28 6 1 0) ;; データ、DaTA
(8 27 19 9 5)
(8 25 22 12 1)
(37 25 6 0 0)
(21 34 11 2 0)
(49 16 3 0 0)
(47 16 5 0 0)
(56 11 1 0 0)
(25 31 7 5 0)
(17 33 15 2 1)
(19 38 8 2 1)))))
(define dep-als ;;学科 associative list
'((nme (学科 DPT 教養 大学))
(smr (2018 02 H30 K))
(cls (6 276))
(dta ((198 59 16 3 0)
(39 86 102 26 22)
(50 96 90 29 9)
(130 91 40 10 4)
(98 107 55 12 3)
(174 70 26 4 2)
(125 95 48 5 3)
(161 81 30 2 1)
(99 114 45 13 5)
(95 105 65 8 3)
(89 120 51 9 7)))))
(define uni-als ;;大学
'((nme (大学 UVY 南九州 学園))
(smr (2018 02 H30 K))
(cls (57 2403))
(dta ((1679 479 202 31 10)
(419 616 974 190 199)
(684 822 692 134 65)
(1341 670 293 69 28)
(1200 695 374 86 42)
(1702 480 169 28 17)
(1315 652 349 52 33)
(1537 585 236 21 19)
(938 940 412 73 34)
(1328 676 325 43 26)
(1172 781 356 55 34)))))
(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
(define als-ref
(lambda (key als)
(if (assoc key als)
(second (assoc key als))
#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)))
;; with too many digits #:angle 170 might help
(define vline-to-y
(lambda (x y)
(lines (map vector (list x x) (list 0 y)))))
(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 ;; replaces pos-line-label and neg-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)
;; Replaces stck-ngtv-rslts and stck-pstv-rsltrs
(define stck-rslts
(lambda (row #:x (x 5.5) #:algn (algn 'bottom) #:clr (clr 1) #:sign (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) algn clr))))
(define lines-percents-labels-counts
;; for each row of Question Results
;; get vline-to-y and pnt-w-lbl ready for plot
(lambda (lon)
(let ((pcnts (counts->percents lon))
(lvels '(5 4 3 2 1))
(tot-lab (->plot-label (apply + lon))))
(append ;; need a flat list for plot
(map (lambda (l p) ;; level percent
(vline-to-y l p))
lvels pcnts)
(map (lambda (x n l)
;; xResponse level nNumber point lLabel
(pnt-w-lbl x n l))
lvels pcnts
(map (lambda (s) (string-append s "/" tot-lab))
(map ->plot-label lon)))))))
;; get data ready for lines-percents-labels-counts
(define dta->Qss-Als
(lambda (Qss Als) ;; Question Symbols, A-list
(map list Qss (als-ref 'dta Als))))
(define plot-bod-als-to-percentlines-countlabels
(lambda (BodAls Qsyms #:kind (ext 'svg))
;; get orginal result data into associative list: QR-als
(let ((QR-als (dta->Qss-Als Qsyms BodAls))
(smr (string-join (map ->plot-label (als-ref 'smr BodAls)) ""))
(bod (->plot-label (car (als-ref 'nme BodAls)))))
(define lines-percents-titled
(lambda (QR)
(let* ((ttl (string-append smr " " bod ":" (->plot-label (car QR))))
(plt-ttl (string-append ttl " "
(string-join (map ->plot-label
(als-ref 'cls BodAls)) "T/")
"S Avg: "
(->plot-label
(round (/ (cadr (als-ref 'cls BodAls))
(car (als-ref 'cls BodAls)))))
"S"))
(fle-name (build-path working-directory ; remove space from ttle for filename
(string-append (regexp-replace* " | " ttl "")
(->plot-label (car (als-ref 'smr BodAls)))
(->plot-label (cadr (als-ref 'smr BodAls)))
"."
(symbol->string ext))))) ;; use page-plot-type later
(plot (list (hrule 0 #:color 0) ;; need this for stck-ngtv-rslts
(lines-percents-labels-counts (cadr QR))
(stck-rslts (cadr QR))
(stck-rslts (reverse (cadr QR)) #:algn 'top #:clr 0 #:sign -))
#:x-min .5 #:x-max 5.9
#:y-min -30 #:y-max 115
#:width 400 #:height 250
#:x-label "levels" #:y-label "percent"
#:title plt-ttl
#:out-file fle-name
#:out-kind ext))))
(map lines-percents-titled QR-als))))
(define anket-reslt-alist->line-labl-chrts
;; call plot-bod-als-to~~ with ink-minimizing parameters
(lambda (als Qsymbs)
(parameterize ((plot-tick-size 3)
(plot-x-far-axis? #f)
(plot-y-far-axis? #f))
(plot-bod-als-to-percentlines-countlabels als Qsymbs))))
(define working-files (directory-list working-directory)) ;; was dir-lis-strs
;; ".svg" working-directory
(define get-plot-files ;; was mthcd-files
(lambda (ext-str img-pths)
(filter (lambda (p) (path-has-extension? p ext-str))
img-pths)))
(define page-plot-files (get-plot-files page-plot-strn working-files))
(define body-quest-plot-name ; was bod-img
(lambda (B Q) ; Body Question
(let ((Brx (regexp (symbol->string B)))
(Qrx (regexp (symbol->string Q))))
(path->string
(car
(filter (lambda (p) (regexp-match Brx p))
(filter (lambda (p)
(regexp-match Qrx p))
page-plot-files)))))))
(define questions '(
(出席 "私はこの授業によく出席した" 学生取組)
(発言 "私は授業内容について質問や発言した" 学生取組)
(取組 "私はこの科目に積極的に取り組んだ(予習と復習した)" 学生取組)
(聞取 "教員の声は聞き取りやすかった。" 教員実施)
(資料 "教員の板書(またはPPT・配布資料など)は読みやすかった(見やすかった)" 教員実施)
(時刻 "教員は授業の開始・終了の時刻を守ろうとしていた" 教員実施)
(反応 "教員は学生の反応を確かめながら授業を進めていた" 教員実施)
(熱意 "教員は熱意を持って授業をしていた" 教員実施)
(理解 "私はこの授業内容を理解できた" 総合評価)
(役立 "私はこの授業で学んだ内容はなんらかの形で将来的に役立つと感じた" 総合評価)
(満足 "私は総合的に判断してこの授業で満足が得られた" 総合評価)))
(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")))
;; (sort responses #:key car <)
(define bdy-rslt-img
(lambda (imge-file)
(element 'img class: "result-image" src: imge-file)))
(define Qsym-Bdys-rslt-imgs
;; Question symbol, list of body symbols
(lambda (qsym bdys) ;; extensiong taking care of aith get-page-plots
(map (lambda (bdy-rx) ; Racket style define vs. cute lambda?
(body-quest-plot-name bdy-rx qsym))
bdys)))
(define rslt-img-div
(lambda (rslt-imgs)
(element 'div class: "result-images"
(map bdy-rslt-img rslt-imgs))))
;; (output-xml (map bdy-rslt-img (Qsym-Bdys-rslt-imgs '資料 bodies)))
;; <img class="result-image" src="20182H30K教員:資料20182.svg" /><img class="result-image" src="20182H30K学科:資料20182.svg" /><img class="result-image" src="20182H30K大学:資料20182.svg" />
(define Qsym->Qli
;; Question-Symbol to Question item <li>Q</li>
(lambda (sym Qs)
(element 'li class: "ques-txt-ja"
(als-ref sym Qs))))
(define Q-li-Rs-div
;; get Qli and image links ready for output-xml
(lambda (sym ext) ;; To do, remove ext, not needed with new Qsym-Bdys-rslt-imgs def
(list
(Qsym->Qli sym questions)
(rslt-img-div (Qsym-Bdys-rslt-imgs sym bodies)))))
(define Qs-w-Rs->ol
;; for output-xml get Qli and Rimages into ordered list
(lambda (syms ext)
(element 'ol class: "questions-with-results"
(map (lambda (sym) (Q-li-Rs-div sym ext)) syms))))
(define resp-levl-defn
(lambda (rsp-row)
(element 'li class: "response-item"
(string-join
(map ->plot-label (list
(car rsp-row)
". "
(caddr rsp-row)))
""))))
(define resp-levl-list
(lambda (defns)
(element 'ol class: "response-levels"
(map resp-levl-defn (sort responses #:key car <)))))
(define output-QsRs-page
(lambda (als plt-ext)
(let* ((yr-sr (string-join (map ->plot-label (als-ref 'smr als)) ""))
;;year semetsr
(pge-ttl (string-append "FD アンケート結果 " yr-sr)))
(call-with-output-file (build-path working-directory
(string-append "FD-Anketo-Questions-Result-" yr-sr ".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: 12pt;} "
"h3 {margin-top: 8px; margin-bottom: 8px; font-size: 10pt; }"
"ol.response-levels {margin-left: 0em; padding-left: 0; font-size: 11pt;"
"li.response-item {display: inline; margin-left: .5em; }"
"li {page-break-inside: avoid; } "
"li.ques-txt-ja { margin-left: -.7em; font-size: 13pt; }"
"div.result-images {width: 100%;} "
"img.result-image { margin: 5px 0 10px 0 ; width:32%; }")))
(body
(h2 pge-ttl)
(h3 "回答数字の文")
(resp-levl-list responses)
(h3 "設問の文と結果の図")
(Qs-w-Rs->ol quest-symbs plt-ext)
;; (element 'ol class: "questions"
;; (map (lambda (sym) (Qsym->Qli sym questions)) quest-symbs))
))
out))))))
(define generate-plot-images-and-html-page
(lambda (list-of-alists plt-ext)
(map (lambda (als)
(anket-reslt-alist->line-labl-chrts als quest-symbs))
list-of-alists)
(output-QsRs-page (last list-of-alists) plt-ext)))
(define write-plot-images-html-page-to
(lambda (pth lst-of-alsts plt-ext)
(generate-plot-images-and-html-page
lst-of-alsts plt-ext)))
;; plot-type plot extension plt-ext
(write-plot-images-html-page-to working-directory (list ind-als dep-als uni-als) (symbol->string page-plot-type))
;; End html page with .svg plots
;; Start png plots to png directory
(define plot-bod-als-to-percentlines-countlabels-to-bmps
(lambda (BodAls Qsyms #:kind (ext 'svg))
;; get orginal result data into associative list: QR-als
(let ((QR-als (dta->Qss-Als Qsyms BodAls))
(smr (string-join (map ->plot-label (als-ref 'smr BodAls)) ""))
(bod (->plot-label (car (als-ref 'nme BodAls)))))
(define lines-percents-titled
(lambda (QR)
(let* ((ttl (string-append smr " " bod ":" (->plot-label (car QR))))
(plt-ttl (string-append ttl " "
(string-join (map ->plot-label
(als-ref 'cls BodAls)) "T/")
"S Avg: "
(->plot-label
(round (/ (cadr (als-ref 'cls BodAls))
(car (als-ref 'cls BodAls)))))
"S"))
(fle-name (build-path working-directory shre-bmps-strn ; remove space from ttle for filename
(string-append (regexp-replace* " | " ttl "")
(->plot-label (car (als-ref 'smr BodAls)))
(->plot-label (cadr (als-ref 'smr BodAls)))
"."
(symbol->string ext))))) ;; use page-plot-type later
(plot (list (hrule 0 #:color 0) ;; need this for stck-ngtv-rslts
(lines-percents-labels-counts (cadr QR))
(stck-rslts (cadr QR))
(stck-rslts (reverse (cadr QR)) #:algn 'top #:clr 0 #:sign -))
#:x-min .5 #:x-max 5.9
#:y-min -30 #:y-max 115
#:width 400 #:height 250
#:x-label "levels" #:y-label "percent"
#:title plt-ttl
#:out-file fle-name
#:out-kind ext))))
(map lines-percents-titled QR-als))))
(define anket-reslt-alist->line-labl-chrts-w-ext
(lambda (als Qsymbs #:ext (ext 'png))
(parameterize ((plot-tick-size 3)
(plot-x-far-axis? #f)
(plot-y-far-axis? #f))
(plot-bod-als-to-percentlines-countlabels-to-bmps als Qsymbs #:kind ext))))
(define write-ind-dep-uni-result-plots
(lambda (ext-dir-sym)
(map (lambda (als)
(anket-reslt-alist->line-labl-chrts-w-ext als quest-symbs #:ext ext-dir-sym))
(list ind-als dep-als uni-als))
))
;;(change-directory-to wrk-dir))))
(write-ind-dep-uni-result-plots shre-bmps-type)
- previous attempt: the basis of this script