Linear regression and naive bayes with Laplacian smoothing

;Linear regression example

(defun sum (l)
  (reduce #'+ l))

(defun product (l)
  (reduce #'* l))

(defun square (x)
  (* x x))

(defun calc-coeff(xs ys)
  "Calculates the coefficients w0 and w1 for the straight line function
  f(x) = w1 * x + w0 which best fits the given xs and ys"
  (let* ((M (length xs))
         (w1numerator (- (* M (sum (mapcar #'* xs ys)))
                         (* (sum xs) (sum ys))))
         (w1denominator (- (* M (sum (mapcar #'* xs xs)))
                           (* (sum xs)(sum xs))))
         (w1 (/ w1numerator w1denominator))
         (w0 (- (* (/ 1 M) (sum ys)) (* (/ w1 M)(sum xs)))))
     (list w0 w1)))

(defun linear-regression-example ()
   (let* ((xs '(1 3 4 5 9))
         (ys '(2 5.2 6.8 8.4 14.8))
         (coefficients (calc-coeff xs ys))
         (w0 (car coefficients))
         (w1 (cadr coefficients)))
         (progn (format t "xs: ~a~%" xs)
                (format t "ys: ~a~%" ys)
                (format t "y = ~$x + ~$~%" w1 w0) )))

; Naive bayes with Laplacian smoothing example
(defun laplace (&key num denom k x )
  "Applies Laplace smoothing"
  (/ (+ num k) (+ (* k x) denom)))


(defparameter *movie*
  '( movie (a perfect world)
     (my perfect woman)
     (pretty woman)))

(defparameter *song*
  '(song (a perfect day)
         (electric storm)
         (another rainy day)))

(defparameter *old* '(old
            (top gun)
            (shy people)
            (top hat)))

(defparameter *new* '(new
             (top gear)
             (gun shy)))



(defun howmany (target items)
  (let ((count 0))
    (dolist (i items count)
       (when (eql target i)
          (setf count (1+ count))))))

(defun count-all-items (l)
   (mapcar (lambda (x) (list x (howmany x l))) l))

(defun count-all (l)
   (remove-duplicates (count-all-items (apply #'append l))
         :test #'equal ))

(defun count-all-in-group (g1 g2)
  (let((present (count-all g1))
          (absent (not-in-other-group g2 g1)))
   (append (mapcar (lambda (x) (list x 0))absent )present )))

(defun total-in-group (g)
  (let ((count 0))
    (dolist (i g count)
        (setf count (+ count (length i))))))

(defun append-no-dups (l)
   (remove-duplicates (apply #'append l) :test #'equal))

(defun total-in-groups (a b)
   (length (union (append-no-dups a) (append-no-dups b))))

(defun all-probs (group other-group k total)
   (let ((n (total-in-group group)))
      (mapcar (lambda(x)(list (car x)
                (laplace :num (cadr x)
                         :denom n
                         :k k
                         :x total)))
                (count-all-in-group group other-group))))

(defun not-in-other-group (g1 g2)
  "Add items that are only in g1 to g2"
  (set-difference (append-no-dups g1) (append-no-dups g2)))

(defun split-prob (expr)
  "Takes a conditional probability in the form '(A ! B) and returns
  a list of A and a list of B"
   (if (eql (length expr) 1)expr
       (let*((given (position '! expr))
         (A (subseq expr 0 given))
         (B (subseq expr (1+ given))))
         (list A B))))

(defun get-probs (keys pairs )
  "Takes a list of keys and a list of item-probability lists and returns
   a list of probabilities"
   (remove-if #'null
     (mapcar (lambda (x) (when (member (first x) keys)
                            (second x)))pairs )))

(defun non-normalized (probs other-probs)
  (let* ((A (product probs))
         (B (product other-probs))
         (sum-probs (+ A B)))
         (/ A sum-probs) ))

(defun prob (expr group1 group2 &optional (k 1))
  "Takes an expression in the form '(A | B), and two groups containing items and an optional laplacian smoothing value, and returns the probability of A given B."
   (let*((g1 (cdr group1))
         (g2 (cdr group2))
         (g1-name (car group1))
         (g2-name (car group2))
         (x (total-in-groups g1 g2))
         (g1-probs (all-probs g1 g2 k x))
         (g2-probs (all-probs g2 g1 k x))
         (g1-total (length g1))
         (g2-total (length g2))
         (prob-g1 (laplace :num g1-total
                  :denom (+ g1-total g2-total)
                  :k k
                  :x 2))
          (prob-g2 (laplace :num g2-total
                   :denom (+ g1-total g2-total)
                   :k k
                   :x 2))
          (A-and-B (split-prob expr))
          (A (if (> (length expr) 1)(car A-and-B)(car expr) ))
          (B (if (> (length expr) 1)(cadr A-and-B) '())))
      (cond ((eql A g1-name)prob-g1)
            ((eql A g2-name)prob-g2)
             ((eql (car B) g1-name)
               (product (get-probs A g1-probs )))
             ((eql (car B) g2-name)
                (product(get-probs A g2-probs)))
             ((eql (car A) g1-name)
                (non-normalized (cons prob-g1 (get-probs B g1-probs))
                                (cons prob-g2 (get-probs B g2-probs) )))
             ((eql (car A) g2-name)
                (non-normalized (cons prob-g2 (get-probs B g2-probs))
                              (cons prob-g1 (get-probs B g1-probs)))))))

(defun bayes-example()
  (progn
     (format t "P(OLD) : ~a~%" (prob '(old) *old* *new*) )
   (format t "P(\"top\" | OLD) : ~a~%" (prob '(top ! old) *old* *new*))
     (format t "P(OLD | \"top\") : ~a~%" (prob '(old ! top) *old* *new*))))