association-rule.cl

;; association-rule algorithm
(defpackage :association-rule
  (:nicknames :assoc)
  (:use :cl
        :hjs.util.vector
        :hjs.learn.read-data)
  (:export :association-analyze
           :%association-analyze
	   :%association-analyze-apriori
           :%association-analyze-da
	   :%association-analyze-ap-genrule
	   :%association-analyze-da-ap-genrule
	   :%association-analyze-fp-growth
	   :%association-analyze-eclat
	   :%association-analyze-lcm
           :assoc-result-rules
           :assoc-result-header
           ))

(in-package :association-rule)

(defclass assoc-result-dataset ()
  ((rules :initarg :rules
          :accessor rules
          :accessor assoc-result-rules)
   (thresholds :initarg :thresholds :accessor thresholds)
   (rule-length :initarg :rule-length :accessor rule-length)
   (header :allocation :class
           :accessor header
           :accessor assoc-result-header
           :initform
           #("premise" "conclusion" "support" "confidence" "lift" "conviction"))))
(defmethod print-object ((d assoc-result-dataset) stream)
  (print-unreadable-object (d stream :type t :identity nil))
  (format stream "~&THRESHOLDS: ~{~A ~A~^~T| ~}~%"
          (loop for index in '("SUPPORT" "CONFIDENCE" "LIFT" "CONVICTION")
              for val in (thresholds d)
              append `(,index ,val)))
  (format stream "~&RULE-LENGTH: ~A~%" (rule-length d))
  (format stream "~&RESULT: ~A RULES~%" (length (rules d))))
(defun make-assoc-result (rules support confidence lift conviction rule-length)
  (assert (notany #'minusp `(,support ,confidence ,lift ,conviction)))
  (assert (> rule-length 1))
  (make-instance 'assoc-result-dataset
    :rules rules :thresholds `(,support ,confidence ,lift ,conviction)
    :rule-length rule-length))
(defmethod assoc-data-out ((d assoc-result-dataset) stream
                           &optional (control-string "~S"))
  (let ((*print-level* nil)
        (*print-length* nil))
    (let ((header (header d))
          (rules-list (rules d)))
      (format stream control-string (cons header rules-list))))
  d)

;; this iterater use append for save "reversed normal order" made by above.
;; if you optimize this application, please think about ordering sequence.
;; i think, they are equal that <use reverse before pass to this> and <use append here>.
(defun map-separated-two-groups (bag fn &optional passed-1 passed-2)
  (if (null bag)
      (funcall fn passed-1 passed-2)
    (progn (map-separated-two-groups (cdr bag) fn (append passed-1 (list (car bag))) passed-2)
      (map-separated-two-groups (cdr bag) fn passed-1 (append passed-2 (list (car bag)))))))

;; atom-rule == (<label-string> . <category-value>)
;; rule == (<atom-rule> {<atom-rule>}*)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (proclaim '(inline make-rule finalize-rule)))
(defun finalize-rule (atom-rule) ;; optional -- for visualize
  (format nil "~A=~A" (car atom-rule) (cdr atom-rule)))
(defun finalize-rules (rule)
  (mapcar #'(lambda (x) (finalize-rule x)) rule))
(defun make-rule (conc pre sup conf lif conv)
  (make-array 6 :initial-contents (list (finalize-rules pre)
                                        (finalize-rules conc)
                                        sup conf lif conv)))

(defun rule-indexes (conc pre rule rule-occur total)
  (let ((conc-count (gethash conc rule-occur))
        (rule-count (gethash rule rule-occur))
        (pre-count  (gethash pre  rule-occur)))
    (values (* (/ rule-count total) 100.0) ;; support
            (* (/ rule-count pre-count) 100.0) ;; confident
            (float (/ (/ rule-count pre-count) (/ conc-count total))) ;; lift
            (let ((negative (- pre-count rule-count)))
              (if (zerop negative)
                  most-positive-single-float
                (float (/ (* pre-count (- 1 (/ conc-count total))) (- pre-count rule-count))))) ;; conviction
            )))

(defun apriori-itemset-counting (transactions item-order support rule-length)
  (let* ((itemset-hash (make-hash-table :test #'equal))
         (total-transaction (hash-table-count transactions))
         (count-threshold (max 1 (* total-transaction (/ support 100)))))
    (flet ((prune-itemset-hash (itemsets)
             (loop for itemset in itemsets
                 as num = (gethash itemset itemset-hash)
                 if (and (numberp num) (>= num count-threshold))
                 collect itemset
                 else 
                 do (remhash itemset itemset-hash))))
      ;; first step, generate 1-itemsets
      (loop for trans being the hash-value in transactions
          do (loop for item in trans
                 as itemset = (cons item nil)
                 do (incf (gethash itemset itemset-hash 0))))
      ;; frequent itemset generation loop
      (loop for k from 2 to rule-length
          as itemsets =
            (if (= k 2)
                (gen-next-itemsets
                 (sort 
                  (loop for itemset being the hash-key in itemset-hash
                      for num being the hash-value in itemset-hash
                      if (>= num count-threshold)
                      collect itemset
                      else 
                      do (remhash itemset itemset-hash))
                  #'< :key #'(lambda (itemset)
                               (gethash (car itemset) item-order))))
              (gen-next-itemsets itemsets))
          do
            (loop for trans being the hash-value in transactions
                do (loop for itemset in itemsets
                       when (find-in-sorted-list itemset trans)
                       do (incf (gethash itemset itemset-hash 0))))
            (setq itemsets (prune-itemset-hash itemsets))
          finally (return itemset-hash)))))

(defun find-in-sorted-list (sorted-items sorted-list &key (test #'equal))
  (loop for item in sorted-items
      as search-result = (member item sorted-list :test test)
      if search-result
      do (setq sorted-list (cdr search-result))
      else return nil
      finally (return t)))

(defun match-except-tail (list1 list2 &key (test #'eql))
  (loop for sub1 on list1
      for sub2 on list2
      while (and (cdr sub1) (cdr sub2))
      unless (funcall test (car sub1) (car sub2))
      do (return)
      finally (return t)))

(defun gen-next-itemsets (pre-itemsets)
  (let (next-itemsets)
    (do ((itemsets pre-itemsets (cdr itemsets)))
	((null (cdr itemsets)) (nreverse next-itemsets))
      (loop for itemset in (cdr itemsets)
          as last-i = (car (last itemset))
          with target = (car itemsets)
          with last-t = (car (last target))
          when (and (not (equal last-i last-t))
		    (match-except-tail itemset target :test #'equal))
          do (push `(,@target ,last-i) next-itemsets)))))

;; fcn. for obtaining the transactions and the order of items
(defun scan-input-data (unsp-dataset target-variables key-variable)
  (let ((transactions (make-hash-table :test #'equal))
        (item-order (make-hash-table :test #'equal))
        (order 0)
        (targets (choice-dimensions
                  target-variables unsp-dataset))
        (keys (choice-a-dimension key-variable unsp-dataset)))
    (do-vecs ((target targets)
              (k keys))
      (loop for x across target
          for l in target-variables
          for item = (cons l x) do
            (unless (gethash item item-order)
              (setf (gethash item item-order) (incf order)))
            (pushnew item (gethash k transactions nil) :test #'equal)))
    (maphash #'(lambda (key items)
                 (setf (gethash key transactions)
                   (sort items #'< :key #'(lambda (item)
                                             (gethash item item-order)))))
             transactions)
    (values transactions item-order)))

(defun %association-analyze (unsp-dataset target-variables key-variable rule-length
                                             &key (support 0) (confident 0) (lift 0) (conviction 0))
  (assert (and (<= 0 support 100) (<= 0 confident 100) (<= 0 lift) (<= 0 conviction)))
  (assert (and (integerp rule-length) (<= 2 rule-length)))
  (multiple-value-bind (transactions item-order)
      (scan-input-data unsp-dataset target-variables key-variable)
    (let ((rule-occur (apriori-itemset-counting
                       transactions item-order support rule-length)))
      (loop with ans = nil
          with count = (hash-table-count transactions)
          for rule being the hash-key in rule-occur do
            (map-separated-two-groups
             rule
             #'(lambda (conc pre)
                 (when (and conc pre)
                   (multiple-value-bind (sup conf lif conv) (rule-indexes conc pre rule
                                                                          rule-occur count)
                     (when (and (>= sup support) (>= conf confident) (>= lif lift) (>= conv conviction))
                       (push (make-rule conc pre
                                        sup conf lif conv) ans))))))
          finally (return (make-assoc-result ans support confident 
                                             lift conviction rule-length))))))

;; ap-genrule
;; pass fn such that push rule into some variable to this ap-maprule
;; count-lookup-fn: lookup itemset count
(defun ap-maprule (fn parent-itemset itemset-length count-lookup-fn max-precount
		   &optional (set-of-itemsets (mapcar #'(lambda (x) (list x)) parent-itemset))
			     (set-of-itemsets-length 1))
  (dolist (conc set-of-itemsets)
    (let ((pre (ordered-set-difference parent-itemset conc)))
      (if (<= (funcall count-lookup-fn pre) max-precount)
	  (funcall fn conc pre)
	(setf set-of-itemsets (delete conc set-of-itemsets)))))
  (when (and (> itemset-length (1+ set-of-itemsets-length)) set-of-itemsets)
    (ap-maprule fn parent-itemset itemset-length count-lookup-fn max-precount
		(gen-next-itemsets set-of-itemsets) (1+ set-of-itemsets-length))))

(defun ordered-set-difference (sorted-item1 sorted-item2 &key (test #'equal))
  (loop for item in sorted-item1
      as search-result = (member item sorted-item2 :test test)
      unless search-result
	     collect item))

;; if confident == 0, then max-count is most-positive-fixnum
(defun confident->max-precount (rule-count confident)
  (if (zerop confident)
      most-positive-fixnum
    (* (/ rule-count confident) 100.0)))

(defun %association-analyze-ap-genrule (unsp-dataset target-variables key-variable rule-length
					&key (support 0) (confident 0) (lift 0) (conviction 0))
  (assert (and (<= 0 support 100) (<= 0 confident 100) (<= 0 lift) (<= 0 conviction)))
  (assert (and (integerp rule-length) (<= 2 rule-length)))
  (multiple-value-bind (transactions item-order)
      (scan-input-data unsp-dataset target-variables key-variable)
    (let ((rule-occur (apriori-itemset-counting
                       transactions item-order support rule-length)))
      (let ((ans nil)
	    (count (hash-table-count transactions)))
	(maphash #'(lambda (rule rule-count)
		     (let ((rule-length (length rule)))
		       (when (> rule-length 1)
			 (ap-maprule
			  #'(lambda (conc pre)
			      (multiple-value-bind (sup conf lif conv) (rule-indexes conc pre rule
										 rule-occur count)
				(when (and (>= sup support) (>= conf confident) (>= lif lift) (>= conv conviction))
				  (push (make-rule conc pre
						   sup conf lif conv) ans))))
			  rule (length rule)
			  #'(lambda (itemset) (gethash itemset rule-occur))
			  (confident->max-precount rule-count confident)))))
		 rule-occur)
        (make-assoc-result ans support confident 
			   lift conviction rule-length)))))

(defun gen-next-itemset-trie (pre-itemsets)
  (let ((next-trie (cons nil nil)))
    (do ((itemsets pre-itemsets (cdr itemsets)))
	((null (cdr itemsets)) next-trie)
      (loop for itemset in (cdr itemsets)
	  as last-i = (car (last itemset))
	  with target = (car itemsets)
	  with last-t = (car (last target))
	  when (and (not (equal last-i last-t))
		    (match-except-tail itemset target :test #'equal))
	  do (assign-trie target last-i next-trie)))))

;; apriori counting trie has leaf at only last-i
(defun assign-trie (target last-i root)
  (loop for i in target do
	(setf root (let ((found (find
				 i (cdr root) :key #'car :test #'equal)))
		     (if found
			 found
		       (let ((new (cons i nil)))
			 (push new (cdr root))
			 new)))))
  ;; never found last-i in last-leaf
  (push (cons last-i 0) (cdr root)))

(defun update-trie-count-apriori (trie transaction)
  (let ((remain (member (car trie) transaction :test #'equal)))
    (when remain
      (if (consp (cdr trie))
	  (loop for branch in (cdr trie) do
		(update-trie-count-apriori branch remain))
	(incf (cdr trie))))))

;; push itemset into some variable by fn
;; reversed twice (1: building counting-trie, 2: accumrating by fn)
;; so order of itemsets is protected as a result.
(defun dump-itemset-hash (trie itemset-hash minimum-count fn
			  &optional (passed nil))
  (if (consp (cdr trie))
      (loop for branch in (cdr trie) do
	    (dump-itemset-hash branch itemset-hash minimum-count fn
			       (cons (car trie) passed)))
    (let ((count (cdr trie)))
      (when (>= count minimum-count)
	(let ((new-itemset (reverse (cons (car trie) passed))))
	  (funcall fn new-itemset)
	  (setf (gethash new-itemset itemset-hash) count))))))

(defun apriori-itemset-counting-trie (transactions item-order support rule-length)
  (let* ((itemset-hash (make-hash-table :test #'equal))
	 (total-transaction (hash-table-count transactions))
	 (count-threshold (max 1 (* total-transaction (/ support 100)))))
    ;; first setp, generate 1-itemsets
    (loop for trans being the hash-value in transactions
	do (loop for item in trans
	       as itemset = (list item)
	       do (incf (gethash itemset itemset-hash 0))))
    ;; frequent itemset generation loop
    (let ((itemsets (sort
		     (loop for itemset being the hash-key in itemset-hash
			 for num being the hash-value in itemset-hash
			 if (>= num count-threshold)
			 collect itemset
			 else
			 do (remhash itemset itemset-hash))
		     #'< :key #'(lambda (itemset)
				  (gethash (car itemset) item-order)))))
      (loop for k from 2 to rule-length
	  as counting-trie = (gen-next-itemset-trie itemsets)
	  do
	    (loop for trans being the hash-value in transactions do
		  (loop for branch in (cdr counting-trie) do
			(update-trie-count-apriori branch trans)))
	    (setf itemsets nil)
	    (loop for branch in (cdr counting-trie) do
		  (dump-itemset-hash branch itemset-hash count-threshold
				     #'(lambda (itemset)
					 (push itemset itemsets))))
	  finally (return itemset-hash)))))

(defun %association-analyze-apriori (unsp-dataset target-variables key-variable rule-length
				     &key (support 0) (confident 0) (lift 0) (conviction 0))
  (assert (and (<= 0 support 100) (<= 0 confident 100) (<= 0 lift) (<= 0 conviction)))
  (assert (and (integerp rule-length) (<= 2 rule-length)))
  (multiple-value-bind (transactions item-order)
      (scan-input-data unsp-dataset target-variables key-variable)
    (let ((rule-occur (apriori-itemset-counting-trie
                       transactions item-order support rule-length)))
      (let ((ans nil)
	    (count (hash-table-count transactions)))
	(maphash #'(lambda (rule rule-count)
		     (let ((rule-length (length rule)))
		       (when (> rule-length 1)
			 (ap-maprule
			  #'(lambda (conc pre)
			      (multiple-value-bind (sup conf lif conv) (rule-indexes conc pre rule
										     rule-occur count)
				(when (and (>= sup support) (>= conf confident) (>= lif lift) (>= conv conviction))
				  (push (make-rule conc pre
						   sup conf lif conv) ans))))
			  rule (length rule)
			  #'(lambda (itemset) (gethash itemset rule-occur))
			  (confident->max-precount rule-count confident)))))
		 rule-occur)
        (make-assoc-result ans support confident 
			   lift conviction rule-length)))))


;; interface
(defun association-analyze (infile outfile target-variables key-variable rule-length
                            &key (support 0) (confident 0) (lift 0) (conviction 0) (external-format :default)
                                 (file-type :sexp) (csv-type-spec '(string double-float))
                                 (algorithm :lcm))
  (assert (member algorithm `(:apriori :da :fp-growth :eclat :lcm)))
  (let ((assoc-result
         (case algorithm
           (:apriori
            (%association-analyze-apriori 
             (read-data-from-file infile :external-format external-format
                                  :type file-type :csv-type-spec csv-type-spec)
             target-variables key-variable rule-length
             :support support :confident confident :lift lift :conviction conviction))
           (:da
            (%association-analyze-da-ap-genrule
             (read-data-from-file infile :external-format external-format
                                  :type file-type :csv-type-spec csv-type-spec)
             target-variables key-variable rule-length
             :support support :confident confident :lift lift :conviction conviction))
           (:fp-growth
            (%association-analyze-fp-growth
             (read-data-from-file infile :external-format external-format
                                  :type file-type :csv-type-spec csv-type-spec)
             target-variables key-variable rule-length
             :support support :confident confident :lift lift :conviction conviction))
           (:eclat
            (%association-analyze-eclat
             (read-data-from-file infile :external-format external-format
                                  :type file-type :csv-type-spec csv-type-spec)
             target-variables key-variable rule-length
             :support support :confident confident :lift lift :conviction conviction))
           (:lcm
            (%association-analyze-lcm
             (read-data-from-file infile :external-format external-format
                                  :type file-type :csv-type-spec csv-type-spec)
             target-variables key-variable rule-length
             :support support :confident confident :lift lift :conviction conviction)))))
    (with-open-file (stream outfile :direction :output :if-exists :supersede
                     :external-format external-format)
      (with-standard-io-syntax
        (let ((*read-default-float-format* 'double-float))
          (assoc-data-out assoc-result stream))))))