;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*))))