Want more features on Pastebin? Sign Up, it's FREE!
Guest

Linear regression and naive bayes with Laplacian smoothing

By: sukottoburaun on Nov 23rd, 2011  |  syntax: Lisp  |  size: 5.37 KB  |  views: 217  |  expires: Never
download  |  raw  |  embed  |  report abuse  |  print
Text below is selected. Please press Ctrl+C to copy to your clipboard. (⌘+C on Mac)
  1. ;Linear regression example
  2.  
  3. (defun sum (l)
  4.   (reduce #'+ l))
  5.  
  6. (defun product (l)
  7.   (reduce #'* l))
  8.  
  9. (defun square (x)
  10.   (* x x))
  11.  
  12. (defun calc-coeff(xs ys)
  13.   "Calculates the coefficients w0 and w1 for the straight line function
  14.  f(x) = w1 * x + w0 which best fits the given xs and ys"
  15.   (let* ((M (length xs))
  16.          (w1numerator (- (* M (sum (mapcar #'* xs ys)))
  17.                          (* (sum xs) (sum ys))))
  18.          (w1denominator (- (* M (sum (mapcar #'* xs xs)))
  19.                            (* (sum xs)(sum xs))))
  20.          (w1 (/ w1numerator w1denominator))
  21.          (w0 (- (* (/ 1 M) (sum ys)) (* (/ w1 M)(sum xs)))))
  22.      (list w0 w1)))
  23.  
  24. (defun linear-regression-example ()
  25.    (let* ((xs '(1 3 4 5 9))
  26.          (ys '(2 5.2 6.8 8.4 14.8))
  27.          (coefficients (calc-coeff xs ys))
  28.          (w0 (car coefficients))
  29.          (w1 (cadr coefficients)))
  30.          (progn (format t "xs: ~a~%" xs)
  31.                 (format t "ys: ~a~%" ys)
  32.                 (format t "y = ~$x + ~$~%" w1 w0) )))
  33.  
  34. ; Naive bayes with Laplacian smoothing example
  35. (defun laplace (&key num denom k x )
  36.   "Applies Laplace smoothing"
  37.   (/ (+ num k) (+ (* k x) denom)))
  38.  
  39.  
  40. (defparameter *movie*
  41.   '( movie (a perfect world)
  42.      (my perfect woman)            
  43.      (pretty woman)))
  44.  
  45. (defparameter *song*
  46.   '(song (a perfect day)
  47.          (electric storm)
  48.          (another rainy day)))  
  49.  
  50. (defparameter *old* '(old
  51.             (top gun)
  52.             (shy people)
  53.             (top hat)))
  54.  
  55. (defparameter *new* '(new
  56.              (top gear)
  57.              (gun shy)))              
  58.  
  59.  
  60.  
  61. (defun howmany (target items)
  62.   (let ((count 0))
  63.     (dolist (i items count)
  64.        (when (eql target i)
  65.           (setf count (1+ count))))))
  66.  
  67. (defun count-all-items (l)
  68.    (mapcar (lambda (x) (list x (howmany x l))) l))
  69.  
  70. (defun count-all (l)
  71.    (remove-duplicates (count-all-items (apply #'append l))
  72.          :test #'equal ))
  73.  
  74. (defun count-all-in-group (g1 g2)
  75.   (let((present (count-all g1))
  76.           (absent (not-in-other-group g2 g1)))
  77.    (append (mapcar (lambda (x) (list x 0))absent )present )))
  78.  
  79. (defun total-in-group (g)
  80.   (let ((count 0))
  81.     (dolist (i g count)
  82.         (setf count (+ count (length i))))))
  83.  
  84. (defun append-no-dups (l)
  85.    (remove-duplicates (apply #'append l) :test #'equal))
  86.  
  87. (defun total-in-groups (a b)
  88.    (length (union (append-no-dups a) (append-no-dups b))))
  89.  
  90. (defun all-probs (group other-group k total)
  91.    (let ((n (total-in-group group)))
  92.       (mapcar (lambda(x)(list (car x)
  93.                 (laplace :num (cadr x)
  94.                          :denom n
  95.                          :k k
  96.                          :x total)))
  97.                 (count-all-in-group group other-group))))
  98.  
  99. (defun not-in-other-group (g1 g2)
  100.   "Add items that are only in g1 to g2"
  101.   (set-difference (append-no-dups g1) (append-no-dups g2)))
  102.  
  103. (defun split-prob (expr)
  104.   "Takes a conditional probability in the form '(A ! B) and returns
  105.  a list of A and a list of B"
  106.    (if (eql (length expr) 1)expr
  107.        (let*((given (position '! expr))
  108.          (A (subseq expr 0 given))
  109.          (B (subseq expr (1+ given))))
  110.          (list A B))))
  111.  
  112. (defun get-probs (keys pairs )
  113.   "Takes a list of keys and a list of item-probability lists and returns
  114.   a list of probabilities"
  115.    (remove-if #'null
  116.      (mapcar (lambda (x) (when (member (first x) keys)
  117.                             (second x)))pairs )))
  118.  
  119. (defun non-normalized (probs other-probs)
  120.   (let* ((A (product probs))
  121.          (B (product other-probs))
  122.          (sum-probs (+ A B)))
  123.          (/ A sum-probs) ))
  124.  
  125. (defun prob (expr group1 group2 &optional (k 1))
  126.   "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."
  127.    (let*((g1 (cdr group1))
  128.          (g2 (cdr group2))
  129.          (g1-name (car group1))
  130.          (g2-name (car group2))
  131.          (x (total-in-groups g1 g2))
  132.          (g1-probs (all-probs g1 g2 k x))
  133.          (g2-probs (all-probs g2 g1 k x))
  134.          (g1-total (length g1))
  135.          (g2-total (length g2))
  136.          (prob-g1 (laplace :num g1-total
  137.                   :denom (+ g1-total g2-total)
  138.                   :k k
  139.                   :x 2))
  140.           (prob-g2 (laplace :num g2-total
  141.                    :denom (+ g1-total g2-total)
  142.                    :k k
  143.                    :x 2))
  144.           (A-and-B (split-prob expr))
  145.           (A (if (> (length expr) 1)(car A-and-B)(car expr) ))
  146.           (B (if (> (length expr) 1)(cadr A-and-B) '())))
  147.       (cond ((eql A g1-name)prob-g1)
  148.             ((eql A g2-name)prob-g2)
  149.              ((eql (car B) g1-name)
  150.                (product (get-probs A g1-probs )))
  151.              ((eql (car B) g2-name)
  152.                 (product(get-probs A g2-probs)))
  153.              ((eql (car A) g1-name)
  154.                 (non-normalized (cons prob-g1 (get-probs B g1-probs))
  155.                                 (cons prob-g2 (get-probs B g2-probs) )))
  156.              ((eql (car A) g2-name)
  157.                 (non-normalized (cons prob-g2 (get-probs B g2-probs))
  158.                               (cons prob-g1 (get-probs B g1-probs)))))))
  159.  
  160. (defun bayes-example()
  161.   (progn
  162.      (format t "P(OLD) : ~a~%" (prob '(old) *old* *new*) )
  163.    (format t "P(\"top\" | OLD) : ~a~%" (prob '(top ! old) *old* *new*))
  164.      (format t "P(OLD | \"top\") : ~a~%" (prob '(old ! top) *old* *new*))))
  165.  
  166.  
  167.  
  168.  
clone this paste RAW Paste Data