module Data.Datamining.Clustering.SOMInternal
(
adjustNode,
adjustVector,
classify,
classifyAndTrain,
diff,
diffAndTrain,
euclideanDistanceSquared,
magnitudeSquared,
normalise,
NormalisedVector,
scale,
scaleAll,
ScaledVector,
train,
trainBatch,
Pattern(..)
) where
import Data.Eq.Unicode ((≡))
import Data.List (foldl', minimumBy)
import Data.Ord (comparing)
import Math.Geometry.GridMap (GridMap, Index, BaseGrid, distance,
mapWithKey, toList)
import Math.Geometry.Grid (Grid)
import qualified Math.Geometry.GridMap as GM (map)
class Pattern p where
type Metric p
difference ∷ p → p → Metric p
makeSimilar ∷ p → Metric p → p → p
diff
∷ (GridMap gm p, Pattern p, GridMap gm m,
Metric p ~ m, BaseGrid gm p ~ BaseGrid gm m) ⇒
gm p → p → gm m
diff c pattern = GM.map (pattern `difference`) c
classify
∷ (GridMap gm p, Pattern p, GridMap gm m,
Metric p ~ m, Ord m, k ~ Index (BaseGrid gm p),
BaseGrid gm m ~ BaseGrid gm p) ⇒
gm p → p → k
classify c pattern =
fst $ minimumBy (comparing snd) $ toList $ diff c pattern
train
∷ (Ord m, GridMap gm p, GridMap gm m,
GridMap gm (Int, p), GridMap gm (m, p), Grid (gm p),
Pattern p, Metric p ~ m, Index (BaseGrid gm p) ~ Index (gm p),
BaseGrid gm m ~ BaseGrid gm p) ⇒
gm p → (Int → m) → p → gm p
train c f pattern = snd $ classifyAndTrain c f pattern
trainBatch
∷ (Ord m, GridMap gm p, GridMap gm m,
GridMap gm (Int, p), GridMap gm (m, p), Grid (gm p),
Pattern p, Metric p ~ m, Index (BaseGrid gm p) ~ Index (gm p),
BaseGrid gm m ~ BaseGrid gm p) ⇒
gm p → (Int → m) → [p] → gm p
trainBatch c f ps = foldl' (\som → train som f) c ps
classifyAndTrain
∷ (Ord m, GridMap gm p, GridMap gm m,
GridMap gm (Int, p), GridMap gm (m, p), Grid (gm p),
Pattern p, Metric p ~ m, Index (BaseGrid gm p) ~ Index (gm p),
BaseGrid gm m ~ BaseGrid gm p) ⇒
gm p → (Int → m) → p → (Index (gm p), gm p)
classifyAndTrain c f pattern = (bmu, c')
where (bmu, _, c') = reportAndTrain c f pattern
diffAndTrain
∷ (Ord m, GridMap gm p, GridMap gm m,
GridMap gm (Int, p), GridMap gm (m, p), Grid (gm p),
Pattern p, Metric p ~ m, Index (BaseGrid gm p) ~ Index (gm p),
BaseGrid gm m ~ BaseGrid gm p) ⇒
gm p → (Int → m) → p → (gm m, gm p)
diffAndTrain c f pattern = (ds, c')
where (_, ds, c') = reportAndTrain c f pattern
reportAndTrain
∷ (Ord m, GridMap gm p, GridMap gm m,
GridMap gm (Int, p), GridMap gm (m, p), Grid (gm p),
Pattern p, Metric p ~ m, Index (BaseGrid gm p) ~ Index (gm p),
BaseGrid gm m ~ BaseGrid gm p) ⇒
gm p → (Int → m) → p → (Index (gm p), gm m, gm p)
reportAndTrain c f pattern = (bmu, ds, c')
where ds = c `diff` pattern
bmu = fst $ minimumBy (comparing snd) $ toList ds
c' = trainWithBMU c f bmu pattern
trainWithBMU
∷ (GridMap gm p, GridMap gm (Int, p), GridMap gm (m, p),
Grid (gm p), Pattern p, Metric p ~ m, k ~ Index (BaseGrid gm p),
k ~ Index (gm p)) ⇒
gm p → (Int → m) → k → p → gm p
trainWithBMU c f bmu pattern = GM.map (adjustNode pattern) lrMap
where dMap = mapWithKey (\k p → (distance c k bmu, p)) c
lrMap = GM.map (\(d,p) → (f d, p)) dMap
adjustNode ∷ (Pattern p) ⇒ p → (Metric p, p) → p
adjustNode target (r,p) = makeSimilar target r p
magnitudeSquared ∷ Num a ⇒ [a] → a
magnitudeSquared xs = sum $ map (\x → x*x) xs
euclideanDistanceSquared ∷ Num a ⇒ [a] → [a] → a
euclideanDistanceSquared xs ys = magnitudeSquared $ zipWith () xs ys
adjustVector ∷ (Num a, Ord a, Eq a) ⇒ [a] → a → [a] → [a]
adjustVector xs r ys
| r < 0 = error "Negative learning rate"
| r > 1 = error "Learning rate > 1"
| r ≡ 1 = xs
| otherwise = zipWith (+) ys deltas
where ds = zipWith () xs ys
deltas = map (r *) ds
data NormalisedVector a = NormalisedVector [a] deriving Show
normalise ∷ Floating a ⇒ [a] → NormalisedVector a
normalise xs = NormalisedVector $ map (/x) xs
where x = norm xs
norm ∷ Floating a ⇒ [a] → a
norm xs = sqrt $ sum (map f xs)
where f x = x*x
instance (Floating a, Fractional a, Ord a, Eq a) ⇒
Pattern (NormalisedVector a) where
type Metric (NormalisedVector a) = a
difference (NormalisedVector xs) (NormalisedVector ys) =
euclideanDistanceSquared xs ys
makeSimilar (NormalisedVector xs) r (NormalisedVector ys) =
normalise $ adjustVector xs r ys
data ScaledVector a = ScaledVector [a] deriving Show
scale ∷ Fractional a ⇒ [(a,a)] → [a] → ScaledVector a
scale qs xs = ScaledVector $ zipWith scaleValue qs xs
scaleAll ∷ (Fractional a, Ord a) ⇒ [[a]] → [ScaledVector a]
scaleAll xss = map (scale qs) xss
where qs = quantify xss
scaleValue ∷ Fractional a ⇒ (a,a) → a → a
scaleValue (minX,maxX) x = (x minX) / (maxXminX)
quantify ∷ Ord a ⇒ [[a]] → [(a,a)]
quantify xss = foldl' quantify' qs (tail xss)
where qs = zip (head xss) (head xss)
quantify' ∷ Ord a ⇒ [(a,a)] → [a] → [(a,a)]
quantify' = zipWith f
where f (minX, maxX) x = (min minX x, max maxX x)
instance (Fractional a, Ord a, Eq a) ⇒ Pattern (ScaledVector a) where
type Metric (ScaledVector a) = a
difference (ScaledVector xs) (ScaledVector ys) =
euclideanDistanceSquared xs ys
makeSimilar (ScaledVector xs) r (ScaledVector ys) =
ScaledVector $ adjustVector xs r ys