Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- ;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*))))
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement