diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -54,8 +54,9 @@ newtype MinSize = MinSize { unMinSize :: Int } deriving (Read, Show) newtype NumEigen = NumEigen { unNumEigen :: Int } deriving (Read, Show) -data ClusteringType = Sparse | Dense deriving (Read, Show) -data Components a = Single (ClusteringTree a) | Multiple [ClusteringTree a] +data ClusteringType = Sparse | Dense | Premade String deriving (Read, Show) +data Components a = Single (GenericClusteringTree a) + | Multiple [GenericClusteringTree a] instance A.ToJSON Q where toEncoding = A.genericToEncoding A.defaultOptions @@ -67,7 +68,7 @@ -- | Command line arguments data Options = Options { clusteringType :: Maybe String - "([Dense] | Sparse) Method for clustering data." + "([Dense] | Sparse | Premade FILE) Method for clustering data. Premade points to a JSON containing the already made tree to output the leaves as clusters." , delimiter :: Maybe Char "([,] | CHAR) The delimiter of the CSV file. Format is row,column,value with no header." , minSize :: Maybe Int @@ -141,7 +142,8 @@ Dense -> do (items, mat) <- readDenseAdjMatrix decodeOpt stdin - let cluster items = HD.hierarchicalSpectralClusterAdj + let cluster items = clusteringTreeToGenericClusteringTree + . HD.hierarchicalSpectralClusterAdj eigenGroup' (fmap unNumEigen numEigen') (fmap unMinSize minSize') @@ -158,7 +160,8 @@ Sparse -> do (items, mat) <- readEigenSparseAdjMatrix decodeOpt stdin - let cluster items = HS.hierarchicalSpectralCluster + let cluster items = clusteringTreeToGenericClusteringTree + . HS.hierarchicalSpectralCluster eigenGroup' (fmap unNumEigen numEigen') (fmap unMinSize minSize') @@ -173,9 +176,12 @@ $ mat else Single $ cluster items mat + (Premade file) -> + fmap (either error Single . A.eitherDecode) . B.readFile $ file + body <- case clusteringTree of (Single ct) -> do - let clustering = zip ([1..] :: [Int]) . getClusterItemsTree $ ct + let clustering = zip ([1..] :: [Int]) . getClusterItemsGenericTree $ ct body :: [(T.Text, T.Text)] body = concatMap (\(!c, xs) -> fmap (\ !x -> (x, showt c)) . V.toList $ xs) @@ -185,13 +191,12 @@ Nothing -> return () Just (OutputTree file) -> B.writeFile file . A.encodePretty - . clusteringTreeToDendrogram $ ct return body (Multiple cts) -> do let clustering = - fmap (L.over L._2 (zip ([1..] :: [Int]) . getClusterItemsTree)) + fmap (L.over L._2 (zip ([1..] :: [Int]) . getClusterItemsGenericTree)) . zip ([1..] :: [Int]) $ cts body :: [(T.Text, T.Text)] @@ -209,19 +214,18 @@ case outputTree' of Nothing -> return () Just (OutputTree file) -> do - let getSize :: ClusteringTree a -> Int - getSize = sum . fmap V.length . getClusterItemsTree + let getSize :: GenericClusteringTree a -> Int + getSize = sum . fmap V.length . getClusterItemsGenericTree getFileName :: Int -> Int -> String getFileName t n = uncurry (File.) . L.over L._2 (\x -> intercalate "_" ["tree", show t, "size", show n, x]) . File.splitFileName $ file - write :: (A.ToJSON a) => Int -> ClusteringTree a -> IO () + write :: (A.ToJSON a) => Int -> GenericClusteringTree a -> IO () write t tree = do B.writeFile (getFileName t (getSize tree)) . A.encodePretty - . clusteringTreeToDendrogram $ tree mapM_ (uncurry write) . zip [1..] $ cts diff --git a/hierarchical-spectral-clustering.cabal b/hierarchical-spectral-clustering.cabal --- a/hierarchical-spectral-clustering.cabal +++ b/hierarchical-spectral-clustering.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: hierarchical-spectral-clustering -version: 0.3.0.1 +version: 0.4.0.0 license: GPL-3 license-file: LICENSE copyright: 2019 Gregory W. Schwartz diff --git a/src/Math/Clustering/Hierarchical/Spectral/Types.hs b/src/Math/Clustering/Hierarchical/Spectral/Types.hs --- a/src/Math/Clustering/Hierarchical/Spectral/Types.hs +++ b/src/Math/Clustering/Hierarchical/Spectral/Types.hs @@ -11,17 +11,22 @@ module Math.Clustering.Hierarchical.Spectral.Types ( ClusteringTree (..) , ClusteringVertex (..) + , GenericClusteringTree (..) + , GenericClusteringVertex (..) , EigenGroup (..) , clusteringTreeToDendrogram , clusteringTreeToDendrogramCumulative + , clusteringTreeToGenericClusteringTree , getClusterItemsDend , getClusterItemsTree + , getClusterItemsGenericTree , Q (..) , NumEigen (..) ) where -- Remote import Data.Clustering.Hierarchical (Dendrogram (..)) +import Data.Maybe (catMaybes) import Data.Monoid ((<>)) import Data.Tree (Tree (..)) import GHC.Generics (Generic) @@ -35,6 +40,7 @@ type Items a = V.Vector a type ClusteringTree a = Tree (ClusteringVertex a) +type GenericClusteringTree a = Tree (GenericClusteringVertex a) type NumEigen = Int data EigenGroup = SignGroup | KMeansGroup deriving (Read, Show, Generic) @@ -44,6 +50,11 @@ , _ngMod :: !Q } deriving (Eq, Ord, Read, Show, Generic) +data GenericClusteringVertex a = GenericClusteringVertex + { _item :: !(Maybe (Items a)) + , _distance :: !(Maybe Double) + } deriving (Eq, Ord, Read, Show, Generic) + -- | Convert a ClusteringTree to a Dendrogram. Modularity is the distance. clusteringTreeToDendrogram :: ClusteringTree a -> Dendrogram (Items a) clusteringTreeToDendrogram = go @@ -74,6 +85,29 @@ <> (show $ length xs) <> " children. Requires two or none." +-- | Convert a ClusteringTree to a GenericClusteringVertex tree (more +-- standardized for our purposes). +clusteringTreeToGenericClusteringTree :: ClusteringTree a + -> GenericClusteringTree a +clusteringTreeToGenericClusteringTree = go + where + go (Node { rootLabel = !n, subForest = []}) = + Node { rootLabel = ( GenericClusteringVertex + { _item = Just $ _clusteringItems n + , _distance = Nothing + } + ) + , subForest = [] + } + go (Node { rootLabel = !n, subForest = xs }) = + Node { rootLabel = ( GenericClusteringVertex + { _item = Nothing + , _distance = Just . unQ . _ngMod $ n + } + ) + , subForest = fmap go xs + } + -- | Gather clusters (leaves) from the dendrogram. getClusterItemsDend :: Foldable t => t (Items a) -> [Items a] getClusterItemsDend = F.toList @@ -81,6 +115,10 @@ -- | Gather clusters (leaves) from the tree. getClusterItemsTree :: ClusteringTree a -> [Items a] getClusterItemsTree = fmap _clusteringItems . leaves + +-- | Gather clusters (leaves) from the generic tree. +getClusterItemsGenericTree :: GenericClusteringTree a -> [Items a] +getClusterItemsGenericTree = catMaybes . fmap _item . leaves deriving instance (Read a) => Read (Dendrogram a) deriving instance Generic (Dendrogram a) @@ -88,3 +126,7 @@ instance (A.ToJSON a) => A.ToJSON (Dendrogram a) where toEncoding = A.genericToEncoding A.defaultOptions instance (A.FromJSON a) => A.FromJSON (Dendrogram a) + +instance (A.ToJSON a) => A.ToJSON (GenericClusteringVertex a) where + toEncoding = A.genericToEncoding A.defaultOptions +instance (A.FromJSON a) => A.FromJSON (GenericClusteringVertex a)