segunda-feira, 13 de dezembro de 2010

How many fume cupboards are needed? -- Scheme version




I am going through Principles of Statistics in order to build a more respectable statistical knowledge. When I got to problem 2.6 I though it was computational heavy for such a lazy person such as I. Apparently I am not alone in that thinking.

The result is that I ended building a scheme version of the code
found in the above page. It was a very interesting exercise. You
can see the problem and the code below:



#lang racket
;; In a certain survey of the work of chemical research workers, it was
;; found, on the basis of extensive data, that on average each man
;; required no fume cupboard for 60 per cent of his time, one cupboard
;; for 30 per cent and two cupboards for 10 per cent; three or more were
;; never required. If a group of four chemists worked independently of
;; one another, how many fume cupboards should be availabe in order to
;; provode adequate facilities for at least 95 per cent of the time?
(require "cartesian-product.rkt"
         rackunit
         rackunit/text-ui)

(define probability-of-cupboards
  #hash((0 . 0.6)
        (1 . 0.3)
        (2 . 0.1)))


;; how-many-cupboards-for-% : integer number hash -> number
;; given a minimum % and a table of probabilities, find the number of
;; cupboards that will be adequated for the number of people given.
(define (how-many-cupboards-for-% number-of-people
                                  minimum-%
                                  table-of-probabilities)
  (local [(define possibilities
            (sort (hash-keys table-of-probabilities) <))
          (define (accumulate-trials-probabilities
                   trials
                   accumulated-probabilities)
            (if (empty? trials)
                accumulated-probabilities
                (accumulate-trials-probabilities
                 (rest trials)
                 (update-or-insert-probability
                  accumulated-probabilities
                  (foldl (λ (x y)
                            (+ x y))
                         0 (first trials))
                  (foldl (λ (trial-event probability-of-trial)
                            (* (hash-ref table-of-probabilities
                                         trial-event)
                               probability-of-trial))
                         1.0 (first trials))))))]
         (probability-table->result-with-%-greater-than 
          (accumulate-trials-probabilities
           (cartesian-product (make-list number-of-people possibilities)) (hash))
          minimum-%)))

;; probability-table->result-with-%-greater-than : hash number -> number or false
;; takes a probability table with the accumulated results, adds up then
;; in sequence until it surpasses the threshold. False if there is no it never
;; surpasses the threshold. 
(define (probability-table->result-with-%-greater-than table minimum-%)
  (define (accumulate-result list-of-possibilities
                             acc-probability
                             (last-probability #f))
    (cond ((empty? list-of-possibilities)
           (if (< acc-probability minimum-%) #f last-probability))
          ((> acc-probability minimum-%) last-probability)
          (else (accumulate-result (rest list-of-possibilities)
                                   (+ (hash-ref table
                                                (first list-of-possibilities))
                                      acc-probability)
                                   (first list-of-possibilities)))))
  (accumulate-result (sort (hash-keys table) <) 0))

;; update-or-insert-probability : hash integer number -> hash
(define (update-or-insert-probability table
                                      cupboard-number
                                      probability)
  (hash-update table
               cupboard-number
               (λ (old-probability)
                  (+ old-probability probability))
               0))

(define-test-suite cupboards
  (check-equal? (how-many-cupboards-for-% 4 0.95 probability-of-cupboards) 4)

  (check-equal? (probability-table->result-with-%-greater-than 
                 #hash((0 . 0.1296)
                       (1 . 0.2592)
                       (2 . 0.2808)
                       (3 . 0.1944)
                       (4 . 0.094)
                       (5 . 0.0324)) 0.94)
                4)
  (check-equal? (probability-table->result-with-%-greater-than 
                 #hash() 0.0)
                #f)
  (check-equal? (probability-table->result-with-%-greater-than 
                 #hash((0 . 0.4)
                       (1 . 0.2)) 0.7)
                #f))

(run-tests cupboards)

Nenhum comentário:

Postar um comentário