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 | --
---------------------
else f thr l
-traceClique :: Map (Date, Date) [PhyloFis] -> String
+traceClique :: Map (Date, Date) [PhyloClique] -> String
traceClique mFis = foldl (\msg cpt -> msg <> show (countSup cpt cliques) <> " (>" <> show (cpt) <> ") " ) "" [1..6]
where
--------------------------------------
cliques :: [Double]
- cliques = sort $ map (fromIntegral . size . _phyloFis_clique) $ concat $ elems mFis
+ cliques = sort $ map (fromIntegral . length . _phyloClique_nodes) $ concat $ elems mFis
--------------------------------------
-traceSupport :: Map (Date, Date) [PhyloFis] -> String
+traceSupport :: Map (Date, Date) [PhyloClique] -> String
traceSupport mFis = foldl (\msg cpt -> msg <> show (countSup cpt supports) <> " (>" <> show (cpt) <> ") " ) "" [1..6]
where
--------------------------------------
supports :: [Double]
- supports = sort $ map (fromIntegral . _phyloFis_support) $ concat $ elems mFis
+ supports = sort $ map (fromIntegral . _phyloClique_support) $ concat $ elems mFis
--------------------------------------
-traceFis :: [Char] -> Map (Date, Date) [PhyloFis] -> Map (Date, Date) [PhyloFis]
+traceFis :: [Char] -> Map (Date, Date) [PhyloClique] -> Map (Date, Date) [PhyloClique]
traceFis msg mFis = trace ( "\n" <> "-- | " <> msg <> " : " <> show (sum $ map length $ elems mFis) <> "\n"
<> "Support : " <> (traceSupport mFis) <> "\n"
- <> "Clique : " <> (traceClique mFis) <> "\n" ) mFis
+ <> "Nb Ngrams : " <> (traceClique mFis) <> "\n" ) mFis
--------------------------
--- | Contextual unit | --
--------------------------
+---------------
+-- | Clique| --
+---------------
-getFisSupport :: ContextualUnit -> Int
-getFisSupport unit = case unit of
+getCliqueSupport :: Clique -> Int
+getCliqueSupport unit = case unit of
Fis s _ -> s
- -- _ -> panic ("[ERR][Viz.Phylo.PhyloTools.getFisSupport] Only Fis has a support")
+ MaxClique _ -> 0
-getFisSize :: ContextualUnit -> Int
-getFisSize unit = case unit of
+getCliqueSize :: Clique -> Int
+getCliqueSize unit = case unit of
Fis _ s -> s
- -- _ -> panic ("[ERR][Viz.Phylo.PhyloTools.getFisSupport] Only Fis has a clique size")
+ MaxClique s -> s
--------------
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 ]
getTrace :: Cooc -> Double
getTrace cooc = sum $ elems $ filterWithKey (\(k,k') _ -> k == k') cooc
+coocToDiago :: Cooc -> Cooc
+coocToDiago cooc = filterWithKey (\(k,k') _ -> k == k') cooc
-- | To build the local cooc matrix of each phylogroup
ngramsToCooc :: [Int] -> [Cooc] -> Cooc
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 = 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
+getSeaElevation :: Phylo -> SeaElevation
+getSeaElevation phylo = seaElevation (getConfig phylo)
+
getConfig :: Phylo -> Config
getConfig phylo = (phylo ^. phylo_param) ^. phyloParam_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