FPC experiments

fpc.lisp

(defun random-population (size p)
  (loop repeat size collect (< (random 1d0) p)))

(defun population (size p)
  (let ((pop (make-array size :initial-element nil)))
    (loop for i below (round (* size p))
         do (setf (aref pop i) t))
    pop))

(defun p (population)
  "Get the actual excact p for the population."
  (float (/ (count-if #'identity population) (length population)) 0d0))

(defun random-sample (size population)
  (let ((sample (make-array size)))
    (map-into sample #'identity (nshuffle-vector population))
    sample))


(defun experiment (pop-size sample-size samples p)
  (let* ((population (population pop-size p))
         (fpc (finite-population-correction pop-size sample-size))
         (sample-values
          (loop repeat samples collect (p (random-sample sample-size population))))
         (actual-sd (standard-deviation sample-values))
         (standard-differences
          (loop for p-hat in sample-values
             for simple-standard-error = (simple-standard-error p-hat sample-size)
             for adjusted-standard-error = (* simple-standard-error fpc)
             collect (- simple-standard-error actual-sd)))
         (adjusted-differences
          (loop for p-hat in sample-values
             for simple-standard-error = (simple-standard-error p-hat sample-size)
             for adjusted-standard-error = (* simple-standard-error fpc)
             collect (- adjusted-standard-error actual-sd)))
         (mean-standard-difference (mean standard-differences))
         (mean-adjusted-difference (mean adjusted-differences)))
    (list (/ mean-standard-difference actual-sd) (/ mean-adjusted-difference actual-sd))))


(defun foo (pop-size samples p)
  (loop for i from 5 below 100 by 5
     for % = (/ i 100)
     do (destructuring-bind (std adj) (experiment pop-size (* pop-size %) samples p)
          (format t "~&~3d%: ~,2f% ~,2f%" i (* 100 std) (* 100 adj)))))






(defun simple-standard-error (p n)
  (sqrt (/ (* p (- 1 p)) n)))

(defun finite-population-correction (pop n)
  (sqrt (/ (- pop n) (- pop 1))))

(defun adjusted-standard-error (p n pop)
  (* (simple-standard-error p n)
     (finite-population-correction pop n)))