src/elicit-predictions.lisp

   1 (uiop:define-package #:lw2.elicit-predictions
   2   (:use #:cl #:iterate #:lw2.utils #:lw2.html-reader #:lw2.backend #:lw2.graphql))
   3
   4 (in-package #:lw2.elicit-predictions)
   5
   6 (named-readtables:in-readtable html-reader)
   7
   8 (declaim (inline normal-pdf))
   9 (defun normal-pdf (x u o)
  10   (* (/ 1 (sqrt (* 2 pi o))) (exp (/ (- (expt (- x u) 2)) (* 2 o)))))
  11
  12 (defun render-elicit-block (question-id)
  13   (let ((elicit-data
  14          (lw2-graphql-query (graphql-query-string "ElicitBlockData" (alist :question-id question-id) '(:title :notes :resolves-by :resolution (:predictions :prediction (:creator (:lw-user :display-name)))))
  15                             :decoder (lambda (x) (cdadr (assoc :data (lw2.backend::deserialize-query-result x)))))))
  16     (alist-bind (title notes resolves-by resolution predictions) elicit-data
  17                 <figure class="prediction-poll">
  18                 <svg xmlns="http://www.w3.org/2000/svg" version="1.1" viewbox="0 0 700 115">
  19                 (let* ((width 700)
  20                        (height 100)
  21                        (prediction-count (length predictions))
  22                        (bandwidth-scale (/ (float (* 3 width)) (sqrt prediction-count)))
  23                        (histogram (make-array 99 :element-type 'fixnum :initial-element 0))
  24                        (density (make-array (1+ (* 98 (/ width 100))) :element-type 'single-float :initial-element 0f0))
  25                        (max-bin 0)
  26                        (max-density 0f0))
  27                   (with-html-stream-output (:stream stream)
  28                     (iter (for prediction-data in predictions)
  29                           (alist-bind (prediction) prediction-data
  30                                       (when (and prediction (< 0 prediction 100))
  31                                         (let ((n (incf (aref histogram (1- prediction)))))
  32                                           (when (> n max-bin) (setf max-bin n))))))
  33                     (let* ((hist-scale (/ (float height) (1+ max-bin))))
  34                       (iter (for bin from 1 to 99)
  35                             (let ((hval (aref histogram (1- bin))))
  36                               (when (> hval 0)
  37                                 (format stream "<rect x=~D y=~5F width=4 height=~5F fill='currentColor' opacity='0.2' />"
  38                                         (- (* (/ width 100) bin) 2)
  39                                         (- height (* hist-scale hval))
  40                                         (* hist-scale hval)))))
  41                       (write-string "<path fill='none' stroke='currentColor' stroke-width='0.6667px' d='M " stream)
  42                       (iter (for x from (/ width 100) to (* 99 (/ width 100)))
  43                             (let ((y
  44                                    (iter (for prediction-data in predictions)
  45                                          (alist-bind (prediction) prediction-data
  46                                                      (sum (coerce (normal-pdf (float x) (* prediction (float (/ width 100))) bandwidth-scale) 'single-float))))))
  47                               (setf (aref density (- x (/ width 100))) y)
  48                               (when (> y max-density) (setf max-density y))))
  49                       (let ((height-scale (/ (1- height) (max (* (1+ max-bin) (normal-pdf 0f0 0f0 bandwidth-scale))
  50                                                               max-density))))
  51                         (iter (for x from (/ width 100) to (* 99 (/ width 100)))
  52                               (let ((y (aref density (- x (/ width 100)))))
  53                                 (format stream "~D,~5F " x (- height (* y height-scale))))))
  54                       (write-string "' />" stream)
  55                       (iter (for x from 1 to 9)
  56                             (format stream "<text x=~5F y=~D font-size='12px' fill='currentColor'>~D%</text>" (* x (/ width 10)) (+ height 14) (* x 10))))))
  57                 </svg>
  58                 (when (nonempty-string title) <figcaption>(progn title)</figcaption>)
  59                 </figure>)))