#|***************************************************************************** F U N C T I O N S T H A T C H A N G E F O R C O B W E B A N D C L A S S I T (D E A L I N G W I T H A T T R I B U T E S) *****************************************************************************|# (provide "node-atts") (require "struct") (require "globals") (defmacro not-present (attribute-value) `(eq ,attribute-value '?)) (defmacro is-present (attribute-value) `(not (eq ,attribute-value '?))) (defmacro numeric (index) `(eq (elt *TYPE-LIST* ,index) :numeric)) (defmacro numericp (attr) `(eq (basic-att-key ,attr) :numeric)) #|***************************************************************************** F U N C T I O N S S P E C I F I C T O C L A S S I T O N L Y *****************************************************************************|# #|----------------------------------------------------------------15/Jun/88---- (CLASSIT only) Function - DETERMINE-VARIANCE Inputs -> an att with acount, sum, and sum2 set. Returns -> the variance ------------------------------------------------------------------Pyoung----|# (defun determine-variance (att) (if (zerop (NumAtt-acount att)) 0 ;don't use at level above. (let* ((avg (/ (NumAtt-sum att) (NumAtt-acount att))) (numerator (+ (* (square avg) (NumAtt-acount att)) (- (* 2 avg (NumAtt-sum att))) (NumAtt-sum2 att))) (variance (/ numerator (NumAtt-acount att)))) (if (< variance *ACUITY*) *ACUITY* variance)))) #|----------------------------------------------------------------15/Jun/88---- Function - PROB-ATT=VALUE Inputs -> a node in the tree, with its atts updated. Returns -> the attscore to be kept at that node, representing the 1/sigma (for CLASSIT) or P(A=V/c) for that node. Is this correct to divide by att-acount and not node-count at all? 03/Jun/88---- In answer to above, yes. But need to multiply by att-acount/node-count also. This is salience weight; see p. 127 Fisher's thesis. So this function returns a slightly different number now. But how come this isn't done for CLASSIT? In answer to above, Classit never had many missing attributes. -JHG OPTIMIZED - 8/89 by JHG -------------------------------------------------------------------KThompso--|# (defmacro salience (att node) ;will be 1 if no missing attribute value. `(/ (basic-att-acount ,att) (node-count ,node))) (defun prob-att=value (node) (loop for attribute in (node-atts node) when (plusp (basic-att-acount attribute)) collect (* (salience attribute node) (if (numericp attribute) ;CLASSIT (inverse (sqrt (NumAtt-variance attribute))) ;COBWEB (loop for value-pair in (NomAtt-values attribute) sum (square (/ (cdr value-pair) (NomAtt-acount attribute))) ) )) into list-of-scores finally (return (/ (apply #'+ list-of-scores) (length list-of-scores))) )) #|----------------------------------------------------------------09/Jun/88---- INTEGRATE-INTO-ATTS This function integrates a new obj into the atts list of a node. Inputs: the atts list, (OBJ), and a list of attribute names. Outputs: the new att list (note: each att should be an explicit copy, not a copy of the pointer). ------------------------------------------------------------------Pyoung----|# (defun integrate-into-atts (old-atts att-names) (loop for attname in att-names for old-att in old-atts for new-value = (get 'OBJ attname) collect (if (numericp old-att) (if (is-present new-value) ; Numeric Attribute (let ((new-NumAtt (make-NumAtt :acount (1+ (NumAtt-acount old-att)) :name (NumAtt-name old-att) :sum (+ new-value (NumAtt-sum old-att)) :sum2 (+ (square new-value) (NumAtt-sum2 old-att))))) (setf (NumAtt-variance new-NumAtt) (determine-variance new-NumAtt)) new-NumAtt) (copy-NumAtt old-att)) (if (is-present new-value) ; Nominal Attribute (let ((new-NomAtt (make-NomAtt :acount (1+ (NomAtt-acount old-att)) :name (NomAtt-name old-att) :values (add-to-values-list (NomAtt-values old-att) new-value)))) new-NomAtt) (copy-NomAtt old-att)) ) )) #|----------------------------------------------------------------09/Jun/88---- CREATE-ATTS creates a new att list for a given obj Inputs: The attribute name list (and OBJ, the instance). Outputs: The new atts list. ------------------------------------------------------------------Pyoung----|# (defun create-atts (att-list) (loop for attname in att-list for index = 0 then (1+ index) for new-value = (get 'OBJ attname) collect (if (numeric index) (if (is-present new-value) ;CLASSIT (make-NumAtt :name attname ;if value exists :acount 1 :sum new-value :sum2 (square new-value) :variance *ACUITY*) (make-NumAtt :name attname ;if value missing :acount 0 :sum 0.0 :sum2 0.0 :variance *ACUITY*)) (if (is-present new-value) ;COBWEB (make-NomAtt :name attname ;if value exists :acount 1 :values `((,new-value . 1))) (make-NomAtt :name attname ;if value missing :acount 0 :values nil)) ) )) #|----------------------------------------------------------------09/Jun/88---- Function - COMBINE-ATTS combine atts for merged node Inputs -> two attribute structures. Returns -> a new structure, with the proper fields merged. "proper fields" is: acount for both CLASSIT and COBWEB, sum, sum2, and variance for CLASSIT values for COBWEB name is just copied. -------------------------------------------------------------------KThompso--|# (defun combine-atts (att-list1 att-list2) (loop for att1 in att-list1 for att2 in att-list2 collect (if (numericp att1) (let ((new-NumAtt ;CLASSIT (make-NumAtt :name (NumAtt-name att1) :acount (+ (NumAtt-acount att1) (NumAtt-acount att2)) :sum (+ (NumAtt-sum att1) (NumAtt-sum att2)) :sum2 (+ (NumAtt-sum2 att1) (NumAtt-sum2 att2))))) (setf (NumAtt-variance new-NumAtt) (determine-variance new-NumAtt)) new-NumAtt) (let ((new-NomAtt ;COBWEB (make-NomAtt :name (NomAtt-name att1) :acount (+ (NomAtt-acount att1) (NomAtt-acount att2))))) (setf (NomAtt-values new-NomAtt) (combine-values (NomAtt-values att1) (NomAtt-values att2))) new-NomAtt) ))) #|***************************************************************************** F U N C T I O N S S P E C I F I C T O C O B W E B O N L Y *****************************************************************************|# #|----------------------------------------------------------------09/Jun/88---- (COBWEB only) Function - COMBINE-VALUES takes 2 new value lists and combines them pairwise e.g. (combine-values '((red . 3) (blue . 2) (black . 1)) '((blue . 3) (red . 1))) returns ((black . 1) (blue . 5) (red . 4)) Inputs -> two value-lists. Returns -> the combined list -------------------------------------------------------------------KThompso--|# (defun combine-values (list1 list2) (let ((all-values (union (mapcar #'car list1) (mapcar #'car list2)))) (loop for value in all-values collect (let ((val1 (assoc value list1)) (val2 (assoc value list2))) (cons value (+ (if val1 (cdr val1) 0) (if val2 (cdr val2) 0))))))) #|----------------------------------------------------------------11/May/88---- (COBWEB only) Function - ADD-TO-VALUES-LIST increment the count of the appropriate value, or add a new pair (new-value . 1). Inputs -> existing value list, new value value-lists look like ((red . 3) (blue . 2) (black . 1)) new-value could be red, or blue. Returns -> new value list -------------------------------------------------------------------KThompso--|# (defun add-to-values-list (value-list new-value) (let* ((new-list (copy-tree value-list)) (pair (assoc new-value new-list))) (if pair (progn (incf (cdr pair)) new-list) (cons `(,new-value . 1) new-list))))