Show the results of questionnaires in the survey view

This commit is contained in:
Marcus Kammer 2024-06-07 18:55:42 +02:00
parent d21ec8e4ee
commit 8becb3d8aa
5 changed files with 107 additions and 49 deletions

View file

@ -1,7 +1,9 @@
(in-package :ml-survey/handlers) (in-package :ml-survey/handlers)
(defun surveys-data-dir () (defun surveys-data-dir ()
(ensure-directories-exist (uiop:merge-pathnames* "data/surveys"))) (let ((data-dir (uiop:merge-pathnames* "data/surveys/")))
(ensure-directories-exist data-dir)
data-dir))
(defun split-uri (uri) (defun split-uri (uri)
(check-type uri string) (check-type uri string)

View file

@ -2,11 +2,10 @@
(defun questionnaire-submit-uri-p (uri) (defun questionnaire-submit-uri-p (uri)
"Check if the request URI matches the pattern '/survey/<numeric>/submit'" "Check if the request URI matches the pattern '/survey/<numeric>/submit'"
(let ((parts (split-uri uri)) (let ((parts (split-uri uri)))
(survey (make-survey uri)))
(and (= (length parts) 3) (and (= (length parts) 3)
(string= (first parts) "survey") (string= (first parts) "survey")
(funcall survey 'id) (every #'digit-char-p (second parts))
(search "submit" (third parts))))) (search "submit" (third parts)))))
(defun questionnaire-submit-uri (request) (defun questionnaire-submit-uri (request)
@ -21,7 +20,7 @@
(define-easy-handler (questionnaire-submit :uri #'questionnaire-submit-uri) nil (define-easy-handler (questionnaire-submit :uri #'questionnaire-submit-uri) nil
(let ((post-params (post-parameters* *request*)) (let ((post-params (post-parameters* *request*))
(questionnaire-id (generate-uuid)) (questionnaire-id (generate-uuid))
(survey (make-survey (request-uri*)))) (s (make-instance 'survey :id (second (split-uri (request-uri*))))))
(store-response (ensure-data-file-exist (funcall survey 'id) questionnaire-id) (store-response (ensure-data-file-exist (survey-id s) questionnaire-id)
post-params) post-params)
(ml-survey/views:questionnaire-submit))) (ml-survey/views:questionnaire-submit)))

View file

@ -2,12 +2,10 @@
(defun questionnaire-uri-p (uri) (defun questionnaire-uri-p (uri)
"Check if the request URI matches the pattern '/survey/<numeric>'" "Check if the request URI matches the pattern '/survey/<numeric>'"
(let ((parts (split-uri uri)) (let ((parts (split-uri uri)))
(survey (make-survey uri)))
(and (= (length parts) 3) (and (= (length parts) 3)
(string= (first parts) "survey") (string= (first parts) "survey")
(every #'digit-char-p (second parts)) (every #'digit-char-p (second parts)))))
(funcall survey 'id-p))))
(defun questionnaire-uri (request) (defun questionnaire-uri (request)
(questionnaire-uri-p (request-uri request))) (questionnaire-uri-p (request-uri request)))
@ -20,6 +18,6 @@
(t (error "Unsupported language: ~A" lang)))) (t (error "Unsupported language: ~A" lang))))
(define-easy-handler (questionnaire :uri #'questionnaire-uri) (lang) (define-easy-handler (questionnaire :uri #'questionnaire-uri) (lang)
(let ((survey (make-survey (request-uri*)))) (let ((s (make-instance 'survey :id (second (split-uri (request-uri*))))))
(setf *html-lang* lang) (setf *html-lang* lang)
(funcall (choose-sus-form lang) (funcall survey 'id)))) (funcall (choose-sus-form lang) (survey-id s))))

View file

@ -1,27 +1,96 @@
(in-package :ml-survey/handlers) (in-package :ml-survey/handlers)
(defun make-survey (uri) (defun extract-numbers (results)
(labels ((survey-fn (action) "Extract numbers from a questionnaire RESULTS list.
(case action Returns a list of integers."
(id (second (split-uri uri))) (check-type results list)
(mapcar (lambda (x)
(parse-integer (remove-if (complement #'digit-char-p)
(cdr x)))) results))
(id-p (let ((ids (mapcar #'car (load-response (make-surveys-db-file))))) (defun sus-calc-score (results)
(if (member (parse-integer (survey-fn 'id)) ids) t nil))) (check-type results list)
(let ((counter 0))
(mapcar (lambda (x)
(setq counter (1+ counter))
(if (evenp counter)
(- 5 x)
(1- x)))
results)))
(uri-p (let ((parts (split-uri uri))) (defun sus-calc-score-per-row (results)
(and (= (length parts) 2) (check-type results list)
(string= (first parts) "survey") (* (apply #'+ (sus-calc-score results)) 2.5))
(every #'digit-char-p (second parts))
(survey-fn 'id-p))))
(properties (first (rest (assoc (parse-integer (survey-fn 'id)) (defun sus-calc (files)
(load-response (make-surveys-db-file))))))))) (check-type files list)
#'survey-fn)) (loop for f in files
for resp = (load-response f)
collect
(sus-calc-score-per-row (extract-numbers resp))))
(defclass survey ()
((id :initarg :id :reader survey-id)
(data-dir :initarg :data-dir :reader survey-data-dir)
(properties :initarg :properties :reader survey-properties)))
(defmethod initialize-instance :after ((survey survey) &key)
(with-slots (id data-dir properties) survey
(setf data-dir (uiop:merge-pathnames*
(format nil "~a/" id)
(surveys-data-dir)))
(setf properties (first (rest (assoc (parse-integer id)
(load-response (make-surveys-db-file))))))))
(defgeneric survey-id-p (survey)
(:documentation "Check if the survey ID is present in the surveys database."))
(defgeneric survey-data-dir-files (survey)
(:documentation "Get the list of files in the survey's data directory."))
(defgeneric survey-data-dir-p (survey)
(:documentation "Check if the survey's data directory exists."))
(defmethod survey-id-p ((survey survey))
(let ((ids (mapcar #'car (load-response (make-surveys-db-file)))))
(if (member (parse-integer (survey-id survey)) ids) t nil)))
(defmethod survey-data-dir-files ((survey survey))
(uiop:directory-files (survey-data-dir survey)))
(defmethod survey-data-dir-p ((survey survey))
(uiop:directory-exists-p (survey-data-dir survey)))
(defmethod survey-html ((survey survey))
(spinneret:with-html
(:table :class "table"
(:thead :class "thead-dark"
(:tr (:th :scope "col"
"Key")
(:th :scope "col"
"Value")))
(:tbody (loop for property in (survey-properties survey)
for key = (car property)
for value = (cdr property) do
(:tr (:td key)
(:td (if (string= key "questionnaire")
(:a :href (concatenate 'string "/survey/" (survey-id survey) value)
value)
value))))))))
(defun survey-uri-p (uri)
(let* ((parts (split-uri uri))
(s (make-instance 'survey :id (second parts))))
(and (= (length parts) 2)
(string= (first parts) "survey")
(every #'digit-char-p (survey-id s))
(survey-id-p s))))
(defun survey-uri (request) (defun survey-uri (request)
(let ((survey (make-survey (request-uri request)))) (survey-uri-p (request-uri request)))
(funcall survey 'uri-p)))
(define-easy-handler (survey :uri #'survey-uri) () (define-easy-handler (survey :uri #'survey-uri) ()
(let ((survey (make-survey (request-uri*)))) (let ((s (make-instance 'survey :id (second (split-uri (request-uri*))))))
(ml-survey/views:survey (funcall survey 'id) (funcall survey 'properties)))) (ml-survey/views:survey s
(when (survey-data-dir-p s)
(sus-calc (survey-data-dir-files s))))))

View file

@ -1,24 +1,14 @@
(in-package :ml-survey/views) (in-package :ml-survey/views)
(defun survey (id properties) (defun survey (survey &optional results)
"Generates the view to show the survey created." "Generates the view to show the survey created."
(check-type id string) (with-page (:title "Survey Details")
(check-type properties list)
(with-page (:title "Surveys")
(navbar-en) (navbar-en)
(:section :class "container" (:section :class "container"
(:h2 id) (:h2 (format nil "Survey ID: ~a" (ml-survey/handlers::survey-id survey)))
(:table :class "table" (:h3 "Properties")
(:thead :class "thead-dark" (ml-survey/handlers::survey-html survey)
(:tr (:th :scope "col" (:h3 "Questionnaire Results")
"Key") (:ul
(:th :scope "col" (loop for result in results do
"Value"))) (:li result))))))
(:tbody (loop for property in properties
for key = (car property)
for value = (cdr property) do
(:tr (:td key)
(:td (if (string= key "questionnaire")
(:a :href (concatenate 'string "/survey/" id value)
value)
value)))))))))