diff --git a/som.cabal b/som.cabal --- a/som.cabal +++ b/som.cabal @@ -1,5 +1,5 @@ name: som -version: 3.1 +version: 4.0 synopsis: Self-Organising Maps description: A Kohonen Self-organising Map (SOM) maps input patterns onto a regular grid (usually two-dimensional) where each @@ -14,10 +14,6 @@ . The userguide is available at . - . - NOTE: Version 3.0 changed the order of parameters - for many functions. This makes it easier for the user - to write mapping and folding operations. category: Math cabal-version: >=1.8 @@ -33,19 +29,21 @@ hs-source-dirs: src build-depends: base ==4.*, base-unicode-symbols ==0.2.*, - binary == 0.5.*, + binary == 0.5.* || == 0.6.* || == 0.7.*, containers ==0.4.2.* || ==0.5.*, grid ==4.*, MonadRandom ==0.1.* ghc-options: -Wall exposed-modules: Data.Datamining.Clustering.SOM, - Data.Datamining.Clustering.SOMInternal + Data.Datamining.Clustering.SOMInternal, + Data.Datamining.Clustering.Classifier, + Data.Datamining.Pattern test-suite som-tests type: exitcode-stdio-1.0 build-depends: base ==4.*, test-framework-quickcheck2 == 0.3.*, - QuickCheck == 2.5.*, + QuickCheck ==2.5.* || ==2.6.*, test-framework == 0.8.*, som, grid ==4.*, diff --git a/src/Data/Datamining/Clustering/Classifier.hs b/src/Data/Datamining/Clustering/Classifier.hs new file mode 100644 --- /dev/null +++ b/src/Data/Datamining/Clustering/Classifier.hs @@ -0,0 +1,98 @@ +------------------------------------------------------------------------ +-- | +-- Module : Data.Datamining.Clustering.Classifier +-- Copyright : (c) Amy de Buitléir 2012-2013 +-- License : BSD-style +-- Maintainer : amy@nualeargais.ie +-- Stability : experimental +-- Portability : portable +-- +-- Tools for identifying patterns in data. +-- +------------------------------------------------------------------------ +{-# LANGUAGE UnicodeSyntax, TypeFamilies, FlexibleContexts, + MultiParamTypeClasses #-} +module Data.Datamining.Clustering.Classifier + ( + Classifier(..) + ) where + +import Data.Datamining.Pattern (Pattern, Metric) +import Data.List (minimumBy) +import Data.Ord (comparing) + +-- | A machine which learns to classify input patterns. +-- Minimal complete definition: @trainBatch@, @reportAndTrain@. +class Classifier (c ∷ * → * → *) k p where + -- | Returns a list of index\/model pairs. + toList ∷ c k p → [(k, p)] + + -- | Returns the number of models this classifier can learn. + numModels ∷ c k p → Int + + -- | Returns the current models of the classifier. + models ∷ c k p → [p] + + -- | @'differences' c target@ returns the indices of all nodes in + -- @c@, paired with the difference between @target@ and the node's + -- model. + differences ∷ (Pattern p, v ~ Metric p) ⇒ c k p → p → [(k, v)] + + -- | @classify c target@ returns the index of the node in @c@ + -- whose model best matches the @target@. + classify ∷ (Pattern p, Ord v, v ~ Metric p) ⇒ c k p → p → k + classify c p = fst . minimumBy (comparing snd) $ differences c p + + -- | @'train' c target@ returns a modified copy + -- of the classifier @c@ that has partially learned the @target@. + train + ∷ (Ord v, v ~ Metric p) ⇒ + c k p → p → c k p + train c p = c' + where (_, _, c') = reportAndTrain c p + + -- | @'trainBatch' c targets@ returns a modified copy + -- of the classifier @c@ that has partially learned the @targets@. + trainBatch ∷ c k p → [p] → c k p + + -- | @'classifyAndTrain' c target@ returns a tuple containing the + -- index of the node in @c@ whose model best matches the input + -- @target@, and a modified copy of the classifier @c@ that has + -- partially learned the @target@. Invoking @classifyAndTrain c p@ + -- may be faster than invoking @(p `classify` c, train c p)@, but they + -- should give identical results. + classifyAndTrain + ∷ (Ord v, v ~ Metric p) ⇒ + c k p → p → (k, c k p) + classifyAndTrain c p = (bmu, c') + where (bmu, _, c') = reportAndTrain c p + + -- | @'diffAndTrain' c target@ returns a tuple containing: + -- 1. The indices of all nodes in @c@, paired with the difference + -- between @target@ and the node's model + -- 2. A modified copy of the classifier @c@ that has partially + -- learned the @target@. + -- Invoking @diffAndTrain c p@ may be faster than invoking + -- @(p `diff` c, train c p)@, but they should give identical + -- results. + diffAndTrain + ∷ (Ord v, v ~ Metric p) ⇒ + c k p → p → ([(k, v)], c k p) + diffAndTrain c p = (ds, c') + where (_, ds, c') = reportAndTrain c p + + -- | @'reportAndTrain' c f target@ returns a tuple containing: + -- 1. The index of the node in @c@ whose model best matches the + -- input @target@ + -- 2. The indices of all nodes in @c@, paired with the difference + -- between @target@ and the node's model + -- 3. A modified copy of the classifier @c@ that has partially + -- learned the @target@ + -- Invoking @diffAndTrain c p@ may be faster than invoking + -- @(p `diff` c, train c p)@, but they should give identical + -- results. + reportAndTrain + ∷ (Ord v, v ~ Metric p) ⇒ + c k p → p → (k, [(k, v)], c k p) + + diff --git a/src/Data/Datamining/Clustering/SOM.hs b/src/Data/Datamining/Clustering/SOM.hs --- a/src/Data/Datamining/Clustering/SOM.hs +++ b/src/Data/Datamining/Clustering/SOM.hs @@ -23,56 +23,21 @@ -- * Kohonen, T. (1982). Self-organized formation of topologically -- correct feature maps. Biological Cybernetics, 43 (1), 59–69. -- --- NOTE: Version 3.0 changed the order of parameters for many functions. --- This makes it easier for the user to write mapping and folding --- operations. --- ------------------------------------------------------------------------ {-# LANGUAGE UnicodeSyntax #-} - module Data.Datamining.Clustering.SOM ( - -- * Patterns - Pattern(..), - -- * Using the SOM - train, - trainBatch, - classify, - classifyAndTrain, - diff, - diffAndTrain, - -- * Numeric vectors as patterns - -- ** Normalised vectors - normalise, - NormalisedVector, - -- ** Scaled vectors - scale, - ScaledVector, - -- ** Useful functions - -- $Vector - adjustVector, - euclideanDistanceSquared, - gaussian + SOM, + defaultSOM, + customSOM, + gaussian, + decayingGaussian, + toGridMap ) where -import Data.Datamining.Clustering.SOMInternal (adjustVector, classify, - classifyAndTrain, diff, diffAndTrain, - euclideanDistanceSquared, normalise, NormalisedVector, scale, - ScaledVector, train, trainBatch, Pattern(..)) - --- | Calculates @c/e/^(-d^2/2w^2)@. --- This form of the Gaussian function is useful as a learning rate --- function. In @'gaussian' c w d@, @c@ specifies the highest learning --- rate, which will be applied to the SOM node that best matches the --- input pattern. The learning rate applied to other nodes will be --- applied based on their distance @d@ from the best matching node. --- The value @w@ controls the \'width\' of the Gaussian. Higher values --- of @w@ cause the learning rate to fall off more slowly with --- distance. -gaussian ∷ Double → Double → Int → Double -gaussian c w d = c * exp (-d'*d'/(2*w*w)) - where d' = fromIntegral d +import Data.Datamining.Clustering.SOMInternal (SOM, defaultSOM, + customSOM, gaussian, decayingGaussian, toGridMap) {- $Vector If you wish to use a SOM with raw numeric vectors, use @no-warn-orphans@ diff --git a/src/Data/Datamining/Clustering/SOMInternal.hs b/src/Data/Datamining/Clustering/SOMInternal.hs --- a/src/Data/Datamining/Clustering/SOMInternal.hs +++ b/src/Data/Datamining/Clustering/SOMInternal.hs @@ -11,237 +11,162 @@ -- use @SOM@ instead. This module is subject to change without notice. -- ------------------------------------------------------------------------ -{-# LANGUAGE UnicodeSyntax, TypeFamilies, FlexibleContexts #-} +{-# LANGUAGE UnicodeSyntax, TypeFamilies, FlexibleContexts, + FlexibleInstances, MultiParamTypeClasses #-} module Data.Datamining.Clustering.SOMInternal ( - adjustNode, - adjustVector, - classify, - classifyAndTrain, - diff, - diffAndTrain, - euclideanDistanceSquared, - magnitudeSquared, - normalise, - NormalisedVector, - scale, - scaleAll, - ScaledVector, - train, - trainBatch, - Pattern(..) + SOM(..), + defaultSOM, + customSOM, + gaussian, + decayingGaussian, + toGridMap ) where -import Data.Eq.Unicode ((≡)) import Data.List (foldl', minimumBy) import Data.Ord (comparing) -import Math.Geometry.GridMap (GridMap, BaseGrid, mapWithKey, toList) -import Math.Geometry.Grid (Grid, Index, distance) -import qualified Math.Geometry.GridMap as GM (map) - --- | A pattern to be learned or classified by a self-organising map. -class Pattern p where - type Metric p - -- | Compares two patterns and returns a /non-negative/ number - -- representing how different the patterns are. A result of @0@ - -- indicates that the patterns are identical. - difference ∷ p → p → Metric p - -- | @'makeSimilar' target amount pattern@ returns a modified copy of - -- @pattern@ that is more similar to @target@ than @pattern@ is. The - -- magnitude of the adjustment is controlled by the @amount@ - -- parameter, which should be a number between 0 and 1. Larger - -- values for @amount@ permit greater adjustments. If @amount@=1, - -- the result should be identical to the @target@. If @amount@=0, - -- the result should be the unmodified @pattern@. - makeSimilar ∷ p → Metric p → p → p - --- | @'diff' c pattern@ returns the positions of all nodes in --- @c@, paired with the difference between @pattern@ and the node's --- pattern. -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 c pattern@ returns the position of the node in @c@ --- whose pattern best matches the input @pattern@. -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 - --- | If @f d@ is a function that returns the learning rate to apply to a --- node based on its distance @d@from the node that best matches the --- input pattern, then @'train' c f pattern@ returns a modified copy --- of the classifier @c@ that has partially learned the @target@. -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 +import qualified Math.Geometry.Grid as G (Grid(..)) +import qualified Math.Geometry.GridMap as GM (GridMap(..)) +import Data.Datamining.Pattern (Pattern(..)) +import Data.Datamining.Clustering.Classifier(Classifier(..)) +import Prelude hiding (lookup) --- | Same as @train@, but applied to multiple patterns. -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 +data SOM gm k p = SOM + { + sGridMap ∷ gm p, + sLearningFunction ∷ Int → Int → Metric p, + sCounter ∷ Int + } --- | If @f@ is a function that returns the learning rate to apply to a --- node based on its distance from the node that best matches the --- @target@, then @'classifyAndTrain' c f target@ returns a tuple --- containing the position of the node in @c@ whose pattern best --- matches the input @target@, and a modified copy of the classifier --- @c@ that has partially learned the @target@. --- Invoking @classifyAndTrain c f p@ may be faster than invoking --- @(p `classify` c, train c f p)@, but they should give identical --- results. -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 +currentLearningFunction ∷ SOM gm k p → (Int → Metric p) +currentLearningFunction s = (sLearningFunction s) (sCounter s) --- | If @f@ is a function that returns the learning rate to apply to a --- node based on its distance from the node that best matches the --- @target@, then @'diffAndTrain' c f target@ returns a tuple --- containing: --- 1. The positions of all nodes in @c@, paired with the difference --- between @pattern@ and the node's pattern --- 2. A modified copy of the classifier @c@ that has partially --- learned the @target@. --- Invoking @diffAndTrain c f p@ may be faster than invoking --- @(p `diff` c, train c f p)@, but they should give identical --- results. -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 +-- | Extract the grid and current models from the SOM. +toGridMap ∷ GM.GridMap gm p ⇒ SOM gm k p → gm p +toGridMap = sGridMap -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 +adjustNode + ∷ (Pattern p, G.Grid g, k ~ G.Index g) ⇒ + g → (Int → Metric p) → p → k → k → p → p +adjustNode g f target bmu k = makeSimilar target (f d) + where d = G.distance g bmu k 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 + ∷ (Pattern p, G.Grid (gm p), GM.GridMap gm p, + G.Index (GM.BaseGrid gm p) ~ G.Index (gm p)) ⇒ + SOM gm k p → G.Index (gm p) → p → SOM gm k p +trainWithBMU s bmu target = s { sGridMap=gm' } + where gm = sGridMap s + gm' = GM.mapWithKey (adjustNode gm f target bmu) gm + f = currentLearningFunction s -adjustNode ∷ (Pattern p) ⇒ p → (Metric p, p) → p -adjustNode target (r,p) = makeSimilar target r p +justTrain + ∷ (Ord (Metric p), Pattern p, G.Grid (gm p), + GM.GridMap gm (Metric p), GM.GridMap gm p, + G.Index (GM.BaseGrid gm (Metric p)) ~ G.Index (gm p), + G.Index (GM.BaseGrid gm p) ~ G.Index (gm p)) ⇒ + SOM gm k p → p → SOM gm k p +justTrain s p = trainWithBMU s bmu p + where ds = GM.toList . GM.map (p `difference`) . sGridMap $ s + bmu = fst . minimumBy (comparing snd) $ ds --- --- Using numeric vectors as patterns. --- +instance + (GM.GridMap gm p, k ~ G.Index (GM.BaseGrid gm p), Pattern p, + G.Grid (gm p), GM.GridMap gm (Metric p), k ~ G.Index (gm p), + k ~ G.Index (GM.BaseGrid gm (Metric p)), Ord (Metric p)) ⇒ + Classifier (SOM gm) k p where + toList = GM.toList . sGridMap + numModels = G.tileCount . sGridMap + models = GM.elems . sGridMap + differences s p = GM.toList . GM.map (p `difference`) . sGridMap $ s + trainBatch s ps = (foldl' justTrain s ps) {sCounter=sCounter s + 1} + reportAndTrain s p = (bmu, ds, s'') + where ds = differences s p + bmu = fst . minimumBy (comparing snd) $ ds + s' = trainWithBMU s bmu p + s'' = s' { sCounter=sCounter s + 1} -magnitudeSquared ∷ Num a ⇒ [a] → a -magnitudeSquared xs = sum $ map (\x → x*x) xs --- | Calculates the square of the Euclidean distance between two --- vectors. -euclideanDistanceSquared ∷ Num a ⇒ [a] → [a] → a -euclideanDistanceSquared xs ys = magnitudeSquared $ zipWith (-) xs ys +-- Creates a classifier with a default (bell-shaped) learning function. +defaultSOM + ∷ Floating (Metric p) ⇒ + -- | The geometry and initial models for this classifier. + -- A reasonable choice here is 'lazyGridMap g ps', where 'g' is a + -- @'Math.Geometry.Grid.HexHexGrid'@, and 'ps' is a set of + -- random patterns. + gm p → + -- | The learning rate to be applied to the BMU (Best Matching Unit) + -- at "time" zero. The BMU is the model which best matches the + -- current target pattern. + Metric p → + -- | The width of the bell curve at "time" zero. + Metric p → + -- | After this time, any learning done by the classifier will be + -- negligible. Recommend setting this parameter to the number of + -- patterns (or pattern batches) that will be presented to the + -- classifier. An estimate is fine. + Int → + -- | The result + SOM gm k p +defaultSOM gm r w t = + SOM { + sGridMap=gm, + sLearningFunction=decayingGaussian r w t, + sCounter=0 + } --- | @'adjustVector' target amount vector@ adjusts @vector@ to move it --- closer to @target@. The amount of adjustment is controlled by the --- learning rate @r@, which is a number between 0 and 1. Larger values --- of @r@ permit more adjustment. If @r@=1, the result will be --- identical to the @target@. If @amount@=0, the result will be the --- unmodified @pattern@. -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 +-- Creates a classifier with a custom learning function. +customSOM ∷ + -- | The geometry and initial models for this classifier. + -- A reasonable choice here is 'lazyGridMap g ps', where 'g' is a + -- @'Math.Geometry.Grid.HexHexGrid'@, and 'ps' is a set of + -- random patterns. + gm p → + -- | A function used to adjust the models in the classifier. + -- This function will be invoked with two parameters. + -- The first parameter will indicate how many patterns (or pattern + -- batches) have previously been presented to this classifier. + -- Typically this is used to make the learning rate decay over time. + -- The second parameter to the function is the grid distance from + -- the node being updated to the BMU (Best Matching Unit). + -- The output is the learning rate for that node (the amount by + -- which the node's model should be updated to match the target). + -- The learning rate should be between zero and one. + (Int → Int → Metric p) → + -- | The result + SOM gm k p +customSOM gm f = + SOM { + sGridMap=gm, + sLearningFunction=f, + sCounter=0 + } --- | A vector that has been normalised, i.e., the magnitude of the --- vector = 1. -data NormalisedVector a = NormalisedVector [a] deriving Show --- | Normalises a vector -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 - --- | A vector that has been scaled so that all elements in the vector --- are between zero and one. To scale a set of vectors, use --- @'scaleAll'@. Alternatively, if you can identify a maximum and --- minimum value for each element in a vector, you can scale --- individual vectors using @'scale'@. -data ScaledVector a = ScaledVector [a] deriving Show - --- | Given a vector @qs@ of pairs of numbers, where each pair represents --- the maximum and minimum value to be expected at each position in --- @xs@, @'scale' qs xs@ scales the vector @xs@ element by element, --- mapping the maximum value expected at that position to one, and the --- minimum value to zero. -scale ∷ Fractional a ⇒ [(a,a)] → [a] → ScaledVector a -scale qs xs = ScaledVector $ zipWith scaleValue qs xs - --- | Scales a set of vectors by determining the maximum and minimum --- values at each position in the vector, and mapping the maximum --- value to one, and the minimum value to zero. -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) / (maxX-minX) - -quantify ∷ Ord a ⇒ [[a]] → [(a,a)] -quantify xss = foldl' quantify' qs (tail xss) - where qs = zip (head xss) (head xss) +-- | Calculates @r/e/^(-d^2/2w^2)@. +-- This form of the Gaussian function is useful as a learning rate +-- function. In @'gaussian' r w d@, @r@ specifies the highest learning +-- rate, which will be applied to the SOM node that best matches the +-- input pattern. The learning rate applied to other nodes will be +-- applied based on their distance @d@ from the best matching node. +-- The value @w@ controls the \'width\' of the Gaussian. Higher values +-- of @w@ cause the learning rate to fall off more slowly with +-- distance @d@. +gaussian ∷ Floating a ⇒ a → a → Int → a +gaussian r w d = r * exp (-d'*d'/(2*w*w)) + where d' = fromIntegral d -quantify' ∷ Ord a ⇒ [(a,a)] → [a] → [(a,a)] -quantify' = zipWith f - where f (minX, maxX) x = (min minX x, max maxX x) +-- | Configures a typical learning function for classifiers. +-- @'decayingGaussian r w0 tMax' returns a bell curve-shaped function. +-- At time zero, the maximum learning rate (applied to the BMU) is +-- @r@, and the neighbourhood width is @w@. Over time the bell curve +-- shrinks and the learning rate tapers off, until at time @tMax@, +-- the learning rate is negligible. +decayingGaussian + ∷ Floating a ⇒ a → a → Int → (Int → Int → a) +decayingGaussian r w0 tMax = + \t d → let t' = fromIntegral t in gaussian r w0 d * exp (-t'/tMax') + where tMax' = fromIntegral tMax -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 diff --git a/src/Data/Datamining/Pattern.hs b/src/Data/Datamining/Pattern.hs new file mode 100644 --- /dev/null +++ b/src/Data/Datamining/Pattern.hs @@ -0,0 +1,149 @@ +------------------------------------------------------------------------ +-- | +-- Module : Data.Datamining.Pattern +-- Copyright : (c) Amy de Buitléir 2012-2013 +-- License : BSD-style +-- Maintainer : amy@nualeargais.ie +-- Stability : experimental +-- Portability : portable +-- +-- Tools for identifying patterns in data. +-- +------------------------------------------------------------------------ +{-# LANGUAGE UnicodeSyntax, TypeFamilies, FlexibleContexts, + MultiParamTypeClasses #-} +module Data.Datamining.Pattern + ( + -- * Patterns + Pattern(..), + -- * Numeric vectors as patterns + -- ** Normalised vectors + NormalisedVector, + normalise, + -- ** Scaled vectors + ScaledVector, + scale, + scaleAll, + -- ** Useful functions + -- $Vector + adjustVector, + euclideanDistanceSquared, + magnitudeSquared + ) where + +import Data.Eq.Unicode ((≡)) +import Data.List (foldl') + +-- | A pattern to be learned or classified. +class Pattern p where + type Metric p + -- | Compares two patterns and returns a /non-negative/ number + -- representing how different the patterns are. A result of @0@ + -- indicates that the patterns are identical. + difference ∷ p → p → Metric p + -- | @'makeSimilar' target amount pattern@ returns a modified copy of + -- @pattern@ that is more similar to @target@ than @pattern@ is. The + -- magnitude of the adjustment is controlled by the @amount@ + -- parameter, which should be a number between 0 and 1. Larger + -- values for @amount@ permit greater adjustments. If @amount@=1, + -- the result should be identical to the @target@. If @amount@=0, + -- the result should be the unmodified @pattern@. + makeSimilar ∷ p → Metric p → p → p + +-- +-- Using numeric vectors as patterns. +-- + +magnitudeSquared ∷ Num a ⇒ [a] → a +magnitudeSquared xs = sum $ map (\x → x*x) xs + +-- | Calculates the square of the Euclidean distance between two +-- vectors. +euclideanDistanceSquared ∷ Num a ⇒ [a] → [a] → a +euclideanDistanceSquared xs ys = magnitudeSquared $ zipWith (-) xs ys + +-- | @'adjustVector' target amount vector@ adjusts @vector@ to move it +-- closer to @target@. The amount of adjustment is controlled by the +-- learning rate @r@, which is a number between 0 and 1. Larger values +-- of @r@ permit more adjustment. If @r@=1, the result will be +-- identical to the @target@. If @amount@=0, the result will be the +-- unmodified @pattern@. +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 + +-- | A vector that has been normalised, i.e., the magnitude of the +-- vector = 1. +data NormalisedVector a = NormalisedVector [a] deriving Show + +-- | Normalises a vector +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 + +-- | A vector that has been scaled so that all elements in the vector +-- are between zero and one. To scale a set of vectors, use +-- @'scaleAll'@. Alternatively, if you can identify a maximum and +-- minimum value for each element in a vector, you can scale +-- individual vectors using @'scale'@. +data ScaledVector a = ScaledVector [a] deriving Show + +-- | Given a vector @qs@ of pairs of numbers, where each pair represents +-- the maximum and minimum value to be expected at each index in +-- @xs@, @'scale' qs xs@ scales the vector @xs@ element by element, +-- mapping the maximum value expected at that index to one, and the +-- minimum value to zero. +scale ∷ Fractional a ⇒ [(a,a)] → [a] → ScaledVector a +scale qs xs = ScaledVector $ zipWith scaleValue qs xs + +-- | Scales a set of vectors by determining the maximum and minimum +-- values at each index in the vector, and mapping the maximum +-- value to one, and the minimum value to zero. +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) / (maxX-minX) + +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 + +{- $Vector +If you wish to use raw numeric vectors as a pattern, use +@no-warn-orphans@ and add the following to your code: + +> instance (Floating a, Fractional a, Ord a, Eq a) ⇒ Pattern [a] a where +> difference = euclideanDistanceSquared +> makeSimilar = adjustVector +-} + diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,6 +1,7 @@ {-# LANGUAGE UnicodeSyntax #-} module Main where +import Data.Datamining.PatternQC ( test ) import Data.Datamining.Clustering.SOMQC ( test ) import Test.Framework as TF ( defaultMain, Test ) @@ -8,6 +9,7 @@ tests ∷ [TF.Test] tests = [ + Data.Datamining.PatternQC.test, Data.Datamining.Clustering.SOMQC.test ]