diff --git a/src/main/clojure/conexp/fca/metrics.clj b/src/main/clojure/conexp/fca/metrics.clj index 166c0266..6b704119 100644 --- a/src/main/clojure/conexp/fca/metrics.clj +++ b/src/main/clojure/conexp/fca/metrics.clj @@ -788,7 +788,65 @@ ;; ) - +;;; From here metrics about two formal contexts + + +(defn set-based-minkowski-distance + " This function implements a set based minkowski distance function, as used by Bazin and Kahn (https://hal.science/hal-04475242)." + ([X Y] + (set-based-minkowski-distance X Y 2)) + ([X Y p] + (assert (or (not (empty? X)) (not (empty? Y))) "Not X and Y can be empty!") + (let [isect (count (intersection X Y)) + xcard (count X) + ycard (count Y) + x_m_isect_p (expt (- xcard isect) p) + y_m_isect_p (expt (- ycard isect) p) + p_root (/ 1 p) + psqr (expt (+ x_m_isect_p y_m_isect_p) p_root)] + (/ psqr (+ isect psqr))))) + +(defn lattice-object-distance + "This function implements the `lattice object distance` as defined by Bazin and Kahn (https://hal.science/hal-04475242)." + ([c1 c2] + (lattice-object-distance c1 c2 2 2)) + ([c1 c2 q] + (lattice-object-distance c1 c2 2 q)) + ([c1 c2 q p] + (let [O (objects c1) + I1 (fn [x] (object-derivation c1 #{x})) + I2 (fn [x] (object-derivation c2 #{x}))] + (/ + (expt + (reduce + (map (fn [o] + (expt + (expt + (+ (expt (- (expt 2 (count (I1 o))) + (expt 2 (count (intersection (I1 o) (I2 o))))) q) + (expt (- (expt 2 (count (I2 o))) + (expt 2 (count (intersection (I1 o) (I2 o))))) q)) + (/ 1 q)) + p)) O)) + (/ 1 p)) + (expt (count O) (/ 1 p)))))) + +(defn lattice-attribute-distance + "This function implements the `lattice object distance` as defined by Bazin and Kahn (https://hal.science/hal-04475242)." + ([c1 c2] + (lattice-attribute-distance c1 c2 2 2)) + ([c1 c2 q] + (lattice-attribute-distance c1 c2 q 2)) + ([c1 c2 q p] + (lattice-object-distance (dual-context c1) (dual-context c2) q p))) + +(defn conceptual-distance + "This function implements the `lattice object distance` as defined by Bazin and Kahn (https://hal.science/hal-04475242)." + ([c1 c2] + (conceptual-distance c1 c2 2 2)) + ([c1 c2 q] + (conceptual-distance c1 c2 q 2)) + ([c1 c2 q p] + (min (lattice-object-distance c1 c2 q p) (lattice-attribute-distance c1 c2 q p)))) diff --git a/src/test/clojure/conexp/fca/metrics_test.clj b/src/test/clojure/conexp/fca/metrics_test.clj index 21319e4a..370c9aac 100644 --- a/src/test/clojure/conexp/fca/metrics_test.clj +++ b/src/test/clojure/conexp/fca/metrics_test.clj @@ -203,6 +203,67 @@ e (rand-nth (into [] (lattice-base-set cl)))] (is (= (elements-modularity cl e) 1)))) +(deftest test-set-base-minkowski-distance + (let [ctx test-ctx-09] + (is (== (set-based-minkowski-distance (objects ctx) + (objects ctx)) 0)) + (is (== (set-based-minkowski-distance (objects ctx) + (objects ctx) 1) 0)) + (is (== (set-based-minkowski-distance (objects ctx) + (objects ctx) 0.5) 0)) + (is (== (set-based-minkowski-distance #{'a} #{}) 1)) + (is (== (set-based-minkowski-distance #{} #{'a}) 1)) + (is (== (set-based-minkowski-distance #{'a 'b} #{'a 'c} 2) 0.5857864376269051)))) + +(deftest test-lattice-attribute-distance + (let [ctx test-ctx-09 + k (count (incidence-relation ctx)) + new-incidence-rel (set (take (- k 5) (shuffle (incidence-relation ctx)))) + new-incidence-rel2 (set (take (- k 5) (incidence-relation ctx))) + ctx2 (make-context (objects ctx) (attributes ctx) + (fn [x y] (contains? new-incidence-rel [x y]))) + ctx3 (make-context (objects ctx) (attributes ctx) + (fn [x y] (contains? new-incidence-rel2 [x y])))] + (is (== (lattice-attribute-distance ctx ctx) 0)) + (is (== (lattice-attribute-distance ctx ctx 2) 0)) + (is (== (lattice-attribute-distance ctx ctx 2 2) 0)) + (is (== (lattice-attribute-distance ctx2 ctx2) 0)) + (is (== (lattice-attribute-distance ctx2 ctx2 2) 0)) + (is (== (lattice-attribute-distance ctx2 ctx2 2 2) 0)) + (is (>= (lattice-attribute-distance ctx ctx 2) 0)) + (is (>= (lattice-attribute-distance ctx ctx 2 2) 0)) + (is (>= (lattice-attribute-distance ctx ctx3) 14)))) + + +(deftest test-lattice-object-distance + (let [ctx test-ctx-09 + k (count (incidence-relation ctx)) + new-incidence-rel (set (take (- k 5) (shuffle (incidence-relation ctx)))) + new-incidence-rel2 (set (take (- k 5) (incidence-relation ctx))) + ctx2 (make-context (objects ctx) (attributes ctx) + (fn [x y] (contains? new-incidence-rel [x y]))) + ctx3 (make-context (objects ctx) (attributes ctx) + (fn [x y] (contains? new-incidence-rel2 [x y])))] + (println ctx3) + (println (lattice-object-distance ctx ctx3)) + (is (== (lattice-object-distance ctx ctx) 0)) + (is (== (lattice-object-distance ctx ctx 2) 0)) + (is (== (lattice-object-distance ctx ctx 2 2) 0)) + (is (== (lattice-object-distance ctx2 ctx2) 0)) + (is (== (lattice-object-distance ctx2 ctx2 2) 0)) + (is (== (lattice-object-distance ctx2 ctx2 2 2) 0)) + (is (>= (lattice-object-distance ctx ctx2 2 2) 0)) + (is (>= (lattice-object-distance ctx ctx3 2 2) 0)) + (is (>= (lattice-object-distance ctx ctx3 2 2) 14)))) + +(deftest test-conceptual-distance + (let [ctx test-ctx-09 + ctx2 (make-context (objects ctx) (attributes ctx) ) + ] + (is (== (lattice-object-distance ctx ctx) 0)) + (is (== (lattice-object-distance ctx ctx 2) 0)) + (is (== (lattice-object-distance ctx ctx 2 2) 0))))) + ;;; nil