Portability : POSIX
-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ViewPatterns #-}
module Gargantext.Viz.Phylo.PhyloTools where
import Data.Vector (Vector, elemIndex)
import Data.List (sort, concat, null, union, (++), tails, sortOn, nub, init, tail, partition, tails, nubBy)
-import Data.Set (Set, size, disjoint)
+import Data.Set (Set, disjoint)
import Data.Map (Map, elems, fromList, unionWith, keys, member, (!), filterWithKey, fromListWith, empty)
import Data.String (String)
import Data.Text (Text, unwords)
import qualified Data.Vector as Vector
import qualified Data.List as List
import qualified Data.Set as Set
+import qualified Data.Map as Map
------------
-- | Io | --
countSup :: Double -> [Double] -> Int
countSup s l = length $ filter (>s) l
+
dropByIdx :: Int -> [a] -> [a]
dropByIdx k l = take k l ++ drop (k+1) l
Just i -> i
+commonPrefix :: Eq a => [a] -> [a] -> [a] -> [a]
+commonPrefix lst lst' acc =
+ if (null lst || null lst')
+ then acc
+ else if (head' "commonPrefix" lst == head' "commonPrefix" lst')
+ then commonPrefix (tail lst) (tail lst') (acc ++ [head' "commonPrefix" lst])
+ else acc
+
+
---------------------
-- | Foundations | --
---------------------
where
--------------------------------------
cliques :: [Double]
- cliques = sort $ map (fromIntegral . size . _phyloClique_nodes) $ concat $ elems mFis
+ cliques = sort $ map (fromIntegral . length . _phyloClique_nodes) $ concat $ elems mFis
--------------------------------------
listToMatrix :: [Int] -> Map (Int,Int) Double
listToMatrix lst = fromList $ map (\k -> (k,1)) $ listToKeys $ sort lst
+listToMatrix' :: [Ngrams] -> Map (Ngrams,Ngrams) Int
+listToMatrix' lst = fromList $ map (\k -> (k,1)) $ listToKeys $ sort lst
+
listToSeq :: Eq a => [a] -> [(a,a)]
listToSeq l = nubBy (\x y -> fst x == fst y) $ [ (x,y) | (x:rest) <- tails l, y <- rest ]
getGroupId :: PhyloGroup -> PhyloGroupId
getGroupId group = ((group ^. phylo_groupPeriod, group ^. phylo_groupLevel), group ^. phylo_groupIndex)
+idToPrd :: PhyloGroupId -> PhyloPeriodId
+idToPrd id = (fst . fst) id
+
getGroupThr :: PhyloGroup -> Double
-getGroupThr group = head' "getGroupThr" ((group ^. phylo_groupMeta) ! "thr")
+getGroupThr group = last' "getGroupThr" ((group ^. phylo_groupMeta) ! "breaks")
groupByField :: Ord a => (PhyloGroup -> a) -> [PhyloGroup] -> Map a [PhyloGroup]
groupByField toField groups = fromListWith (++) $ map (\g -> (toField g, [g])) groups
filterProximity :: Proximity -> Double -> Double -> Bool
filterProximity proximity thr local =
case proximity of
- WeightedLogJaccard _ _ _ -> local >= thr
+ WeightedLogJaccard _ -> local >= thr
Hamming -> undefined
getProximityName :: Proximity -> String
getProximityName proximity =
case proximity of
- WeightedLogJaccard _ _ _ -> "WLJaccard"
- Hamming -> "Hamming"
-
-getProximityInit :: Proximity -> Double
-getProximityInit proximity =
- case proximity of
- WeightedLogJaccard _ i _ -> i
- Hamming -> undefined
-
-
-getProximityStep :: Proximity -> Double
-getProximityStep proximity =
- case proximity of
- WeightedLogJaccard _ _ s -> s
- Hamming -> undefined
+ WeightedLogJaccard _ -> "WLJaccard"
+ Hamming -> "Hamming"
---------------
-- | Phylo | --
---------------
-addPointers :: PhyloGroup -> Filiation -> PointerType -> [Pointer] -> PhyloGroup
-addPointers group fil pty pointers =
+addPointers :: Filiation -> PointerType -> [Pointer] -> PhyloGroup -> PhyloGroup
+addPointers fil pty pointers group =
case pty of
TemporalPointer -> case fil of
ToChilds -> group & phylo_groupPeriodChilds .~ pointers
. traverse
. phylo_periodLevels ) phylo
-
-getPhyloThresholdInit :: Phylo -> Double
-getPhyloThresholdInit phylo = getThresholdInit (phyloProximity (getConfig phylo))
-
-
-getPhyloThresholdStep :: Phylo -> Double
-getPhyloThresholdStep phylo = getThresholdStep (phyloProximity (getConfig phylo))
+getSeaElevation :: Phylo -> SeaElevation
+getSeaElevation phylo = seaElevation (getConfig phylo)
getConfig :: Phylo -> Config
. phylo_levelGroups ) phylo
+getGroupsFromLevelPeriods :: Level -> [PhyloPeriodId] -> Phylo -> [PhyloGroup]
+getGroupsFromLevelPeriods lvl periods phylo =
+ elems $ view ( phylo_periods
+ . traverse
+ . filtered (\phyloPrd -> elem (phyloPrd ^. phylo_periodPeriod) periods)
+ . phylo_periodLevels
+ . traverse
+ . filtered (\phyloLvl -> phyloLvl ^. phylo_levelLevel == lvl)
+ . phylo_levelGroups ) phylo
+
+
+getGroupsFromPeriods :: Level -> Map PhyloPeriodId PhyloPeriod -> [PhyloGroup]
+getGroupsFromPeriods lvl periods =
+ elems $ view ( traverse
+ . phylo_periodLevels
+ . traverse
+ . filtered (\phyloLvl -> phyloLvl ^. phylo_levelLevel == lvl)
+ . phylo_levelGroups ) periods
+
+
updatePhyloGroups :: Level -> Map PhyloGroupId PhyloGroup -> Phylo -> Phylo
updatePhyloGroups lvl m phylo =
over ( phylo_periods
let acc' = partition (\groups' -> disjoint (Set.fromList groups') (Set.fromList groups)) acc
in (fst acc') ++ [nub $ concat $ (snd acc') ++ [groups]]) [] graph
+toRelatedComponents :: [PhyloGroup] -> [((PhyloGroup,PhyloGroup),Double)] -> [[PhyloGroup]]
+toRelatedComponents nodes edges =
+ let ref = fromList $ map (\g -> (getGroupId g, g)) nodes
+ clusters = relatedComponents $ ((map (\((g,g'),_) -> [getGroupId g, getGroupId g']) edges) ++ (map (\g -> [getGroupId g]) nodes))
+ in map (\cluster -> map (\gId -> ref ! gId) cluster) clusters
+
traceSynchronyEnd :: Phylo -> Phylo
traceSynchronyEnd phylo =
getSensibility :: Proximity -> Double
getSensibility proxi = case proxi of
- WeightedLogJaccard s _ _ -> s
- Hamming -> undefined
-
-getThresholdInit :: Proximity -> Double
-getThresholdInit proxi = case proxi of
- WeightedLogJaccard _ t _ -> t
- Hamming -> undefined
-
-getThresholdStep :: Proximity -> Double
-getThresholdStep proxi = case proxi of
- WeightedLogJaccard _ _ s -> s
- Hamming -> undefined
-
-
-traceBranchMatching :: Proximity -> Double -> [PhyloGroup] -> [PhyloGroup]
-traceBranchMatching proxi thr groups = case proxi of
- WeightedLogJaccard _ i s -> trace (
- roundToStr 2 thr <> " "
- <> foldl (\acc _ -> acc <> ".") "." [(10*i),(10*i + 10*s)..(10*thr)]
- <> " " <> show(length groups) <> " groups"
- ) groups
+ WeightedLogJaccard s -> s
Hamming -> undefined
----------------
traceTemporalMatching :: [PhyloGroup] -> [PhyloGroup]
traceTemporalMatching groups =
- trace ( "\n" <> "-- | Start temporal matching for " <> show(length groups) <> " groups" <> "\n") groups
\ No newline at end of file
+ trace ( "\n" <> "-- | Start temporal matching for " <> show(length groups) <> " groups" <> "\n") groups
+
+
+traceGroupsProxi :: Map (PhyloGroupId,PhyloGroupId) Double -> Map (PhyloGroupId,PhyloGroupId) Double
+traceGroupsProxi m =
+ trace ( "\n" <> "-- | " <> show(Map.size m) <> " computed pairs of groups proximity" <> "\n") m