ElEve: alternative split
[gargantext.git] / src / Gargantext / Viz / Phylo / Tools.hs
index 258853e307c689759d4f051213109b426ae8c0cc..bd73bd9a196e6db041c961975ffde45bcad0ce9d 100644 (file)
@@ -20,11 +20,11 @@ module Gargantext.Viz.Phylo.Tools
   where
 
 import Control.Lens         hiding (both, Level, Empty)
-import Data.List            (filter, intersect, (++), sort, null, tail, last, tails, delete, nub, concat, sortOn, nubBy)
+import Data.List            (filter, intersect, (++), sort, null, tail, last, tails, delete, nub, sortOn, nubBy)
 import Data.Maybe           (mapMaybe,fromMaybe)
 import Data.Map             (Map, mapKeys, member, (!))
 import Data.Set             (Set)
-import Data.Text            (Text, toLower)
+import Data.Text            (Text,toLower,unwords)
 import Data.Tuple.Extra
 import Data.Vector          (Vector,elemIndex)
 import Gargantext.Prelude
@@ -100,6 +100,11 @@ keepFilled f thr l = if (null $ f thr l) && (not $ null l)
                      else f thr l
 
 
+-- | To get all combinations of a list
+listToFullCombi :: Eq a => [a] -> [(a,a)]
+listToFullCombi l = [(x,y) | x <- l, y <- l]
+
+
 -- | To get all combinations of a list
 listToDirectedCombi :: Eq a => [a] -> [(a,a)]
 listToDirectedCombi l = [(x,y) | x <- l, y <- l, x /= y]
@@ -125,6 +130,16 @@ listToUnDirectedCombiWith :: forall a b. (a -> b) -> [a] -> [(b,b)]
 listToUnDirectedCombiWith f l = [ (f x, f y) | (x:rest) <- tails l,  y <- rest ]
 
 
+-- | To transform a list of Ngrams Indexes into a Label
+ngramsToLabel :: Vector Ngrams -> [Int] -> Text
+ngramsToLabel ngrams l = unwords $ ngramsToText ngrams l
+
+
+-- | To transform a list of Ngrams Indexes into a list of Text
+ngramsToText :: Vector Ngrams -> [Int] -> [Text]
+ngramsToText ngrams l = map (\idx -> ngrams Vector.! idx) l
+
+
 -- | To unify the keys (x,y) that Map 1 share with Map 2 such as: (x,y) <=> (y,x)
 unifySharedKeys :: Eq a => Ord a => Map (a,a) b -> Map (a,a) b -> Map (a,a) b
 unifySharedKeys m1 m2 = mapKeys (\(x,y) -> if member (y,x) m2
@@ -136,34 +151,22 @@ unifySharedKeys m1 m2 = mapKeys (\(x,y) -> if member (y,x) m2
 -- | Phylo | --
 ---------------
 
-
 -- | An analyzer ingests a Ngrams and generates a modified version of it
 phyloAnalyzer :: Ngrams -> Ngrams
 phyloAnalyzer n = toLower n
 
--- | To init the foundation of the Phylo as a Vector of Ngrams
-initFoundations :: [Ngrams] -> Vector Ngrams
-initFoundations l = Vector.fromList $ map phyloAnalyzer l
+-- | To init the foundation roots of the Phylo as a Vector of Ngrams
+initFoundationsRoots :: [Ngrams] -> Vector Ngrams
+initFoundationsRoots l = Vector.fromList $ map phyloAnalyzer l
 
 -- | To init the base of a Phylo from a List of Periods and Foundations
-initPhyloBase :: [(Date, Date)] -> Vector Ngrams -> PhyloRoots -> PhyloParam -> Phylo
-initPhyloBase pds fds pks prm = Phylo ((fst . (head' "initPhyloBase")) pds, (snd . last) pds) fds pks (map (\pd -> initPhyloPeriod pd []) pds) prm
+initPhyloBase :: [(Date, Date)] -> PhyloFoundations -> PhyloParam -> Phylo
+initPhyloBase pds fds prm = Phylo ((fst . (head' "initPhyloBase")) pds, (snd . last) pds) fds (map (\pd -> initPhyloPeriod pd []) pds) prm
 
 -- | To init the param of a Phylo
 initPhyloParam :: Maybe Text -> Maybe Software -> Maybe PhyloQueryBuild -> PhyloParam
 initPhyloParam (def defaultPhyloVersion -> v) (def defaultSoftware -> s) (def defaultQueryBuild -> q) = PhyloParam v s q
 
--- | To get the foundations of a Phylo
-getFoundations :: Phylo -> Vector Ngrams
-getFoundations = _phylo_foundations
-
--- | To get the Index of a Ngrams in the Foundations of a Phylo
-getIdxInFoundations :: Ngrams -> Phylo -> Int
-getIdxInFoundations n p = case (elemIndex n (getFoundations p)) of
-    Nothing  -> panic "[ERR][Viz.Phylo.Tools.getIdxInFoundations] Ngrams not in Foundations"
-    Just idx -> idx
-
-
 -- | To get the last computed Level in a Phylo
 getLastLevel :: Phylo -> Level
 getLastLevel p = (last . sort)
@@ -177,54 +180,20 @@ getLastLevel p = (last . sort)
 -- | PhyloRoots | --
 --------------------
 
--- | To apply a fonction to each label of a Ngrams Tree
-alterLabels :: (Ngrams -> Ngrams) -> Tree Ngrams -> Tree Ngrams
-alterLabels f (Node lbl ns) = Node (f lbl) (map (\n -> alterLabels f n) ns)
-alterLabels _ Empty         = panic "[ERR][Viz.Phylo.Tools.alterLabels] Empty"
-
--- | To transform a forest of trees into a map (node,root)
-forestToMap :: [Tree Ngrams] -> Map Ngrams Ngrams
-forestToMap trees = Map.fromList $ concat $ map treeToTuples' trees
-  where
-    treeToTuples' (Node lbl ns) = treeToTuples (Node lbl ns) lbl
-    treeToTuples' Empty         = panic "[ERR][Viz.Phylo.Tools.forestToMap] Empty"
-
--- | To get the foundationsRoots of a Phylo
-getRoots :: Phylo -> PhyloRoots
-getRoots = _phylo_foundationsRoots
+-- | To get the foundations of a Phylo
+getFoundations :: Phylo -> PhyloFoundations
+getFoundations = _phylo_foundations
 
--- | To get the RootsLabels of a Phylo
-getRootsLabels :: Phylo -> Vector Ngrams
-getRootsLabels p = (getRoots p) ^. phylo_rootsLabels
+-- | To get the foundations roots of a Phylo
+getFoundationsRoots :: Phylo -> Vector Ngrams
+getFoundationsRoots p = (getFoundations p) ^. phylo_foundationsRoots
 
 -- | To get the Index of a Ngrams in the foundationsRoots of a Phylo
 getIdxInRoots :: Ngrams -> Phylo -> Int
-getIdxInRoots n p = case (elemIndex n (getRootsLabels p)) of
+getIdxInRoots n p = case (elemIndex n (getFoundationsRoots p)) of
     Nothing  -> panic "[ERR][Viz.Phylo.Tools.getIdxInRoots] Ngrams not in foundationsRoots"
     Just idx -> idx
 
--- | To init the PhyloRoots of a Phylo
-initRoots :: [Tree Ngrams] -> Vector Ngrams -> PhyloRoots
-initRoots trees ns = PhyloRoots labels trees
-  where
-    --------------------------------------
-    labels :: Vector Ngrams
-    labels = Vector.fromList
-           $ nub
-           $ Vector.toList
-           $ map (\n -> if member n mTrees
-                        then mTrees Map.! n
-                        else n ) ns
-    --------------------------------------
-    mTrees :: Map Ngrams Ngrams
-    mTrees = forestToMap trees
-    --------------------------------------
-
--- | To transform a Ngrams Tree into a list of (node,root)
-treeToTuples :: Tree Ngrams -> Ngrams -> [(Ngrams,Ngrams)]
-treeToTuples (Node lbl ns) root = [(lbl,root)] ++ (concat $ map (\n -> treeToTuples n root) ns)
-treeToTuples Empty         _    = panic "[ERR][Viz.Phylo.Tools.treeToTuples] Empty"
-
 --------------------
 -- | PhyloGroup | --
 --------------------
@@ -273,11 +242,6 @@ getGroupId :: PhyloGroup -> PhyloGroupId
 getGroupId = _phylo_groupId
 
 
--- | To get the Cooc Matrix of a PhyloGroup
-getGroupCooc :: PhyloGroup -> Map (Int,Int) Double
-getGroupCooc = _phylo_groupCooc
-
-
 -- | To get the level out of the id of a PhyloGroup
 getGroupLevel :: PhyloGroup -> Int
 getGroupLevel = snd . fst . getGroupId
@@ -303,6 +267,15 @@ getGroupLevelParentsId :: PhyloGroup -> [PhyloGroupId]
 getGroupLevelParentsId g = map fst $ getGroupLevelParents g
 
 
+-- | To get the PhyloGroups Level Parents Ids of a PhyloGroup
+getGroupLevelParentId :: PhyloGroup -> PhyloGroupId
+getGroupLevelParentId g = (head' "getGroupLevelParentId") $ getGroupLevelParentsId g
+
+-- | To get the Meta value of a PhyloGroup
+getGroupMeta :: Text -> PhyloGroup -> Double
+getGroupMeta k g = (g ^. phylo_groupMeta) ! k
+
+
 -- | To get the Ngrams of a PhyloGroup
 getGroupNgrams :: PhyloGroup -> [Int]
 getGroupNgrams =  _phylo_groupNgrams
@@ -343,6 +316,24 @@ getGroupPeriodParentsId :: PhyloGroup -> [PhyloGroupId]
 getGroupPeriodParentsId g = map fst $ getGroupPeriodParents g
 
 
+-- | To get the pointers of a given Phylogroup
+getGroupPointers :: EdgeType -> Filiation -> PhyloGroup -> [Pointer]
+getGroupPointers t f g = case t of
+                          PeriodEdge -> case f of 
+                                          Ascendant  -> getGroupPeriodParents g
+                                          Descendant -> getGroupPeriodChilds g
+                                          _          -> panic "[ERR][Viz.Phylo.Tools.getGroupPointers] wrong filiation"
+                          LevelEdge  -> case f of 
+                                          Ascendant  -> getGroupLevelParents g
+                                          Descendant -> getGroupLevelChilds g
+                                          _          -> panic "[ERR][Viz.Phylo.Tools.getGroupPointers] wrong filiation"
+
+
+-- | To get the roots labels of a list of group ngrams
+getGroupText :: PhyloGroup -> Phylo -> [Text] 
+getGroupText g p = ngramsToText (getFoundationsRoots p) (getGroupNgrams g) 
+
+
 -- | To get all the PhyloGroup of a Phylo
 getGroups :: Phylo -> [PhyloGroup]
 getGroups = view ( phylo_periods
@@ -357,6 +348,10 @@ getGroups = view ( phylo_periods
 getGroupsFromIds :: [PhyloGroupId] -> Phylo -> [PhyloGroup]
 getGroupsFromIds ids p = filter (\g -> elem (getGroupId g) ids) $ getGroups p
 
+-- | To get a PhyloGroup matching a PhyloGroupId in a Phylo
+getGroupFromId :: PhyloGroupId -> Phylo -> PhyloGroup
+getGroupFromId id p = (head' "getGroupFromId") $ getGroupsFromIds [id] p
+
 
 -- | To get the corresponding list of PhyloGroups from a list of PhyloNodes
 getGroupsFromNodes :: [PhyloNode] -> Phylo -> [PhyloGroup]
@@ -387,7 +382,6 @@ initGroup ngrams lbl idx lvl from' to' p = PhyloGroup
   lbl
   (sort $ map (\x -> getIdxInRoots x p) ngrams)
   (Map.empty)
-  (Map.empty)
   Nothing
   [] [] [] []
 
@@ -485,12 +479,12 @@ getSupport = _phyloFis_support
 
 
 -- | To filter some GroupEdges with a given threshold
-filterGroupEdges :: Double -> GroupEdges -> GroupEdges
+filterGroupEdges :: Double -> [GroupEdge] -> [GroupEdge]
 filterGroupEdges thr edges = filter (\((_s,_t),w) -> w > thr) edges
 
 
 -- | To get the neighbours (directed/undirected) of a PhyloGroup from a list of GroupEdges
-getNeighbours :: Bool -> PhyloGroup -> GroupEdges -> [PhyloGroup]
+getNeighbours :: Bool -> PhyloGroup -> [GroupEdge] -> [PhyloGroup]
 getNeighbours directed g e = case directed of
   True  -> map (\((_s,t),_w) -> t)
              $ filter (\((s,_t),_w) -> s == g) e
@@ -564,6 +558,13 @@ getTargetId e = e ^. pe_target
 getBranchId :: PhyloBranch -> PhyloBranchId
 getBranchId b = b ^. pb_id
 
+-- | To get a list of PhyloBranchIds
+getBranchIds :: Phylo -> [PhyloBranchId]
+getBranchIds p = sortOn snd
+               $ nub 
+               $ mapMaybe getGroupBranchId
+               $ getGroups p
+
 
 -- | To get a list of PhyloBranchIds given a Level in a Phylo
 getBranchIdsWith :: Level -> Phylo -> [PhyloBranchId]
@@ -582,6 +583,20 @@ getViewBranchIds :: PhyloView -> [PhyloBranchId]
 getViewBranchIds v = map getBranchId $ v ^. pv_branches
 
 
+-- | To get a list of PhyloGroup sharing the same PhyloBranchId
+getGroupsByBranches :: Phylo -> [(PhyloBranchId,[PhyloGroup])]
+getGroupsByBranches p = zip (getBranchIds p) 
+                      $ map (\id -> filter (\g -> (fromJust $ getGroupBranchId g) == id)
+                                    $ getGroupsInBranches p) 
+                      $ getBranchIds p 
+
+
+-- | To get the sublist of all the PhyloGroups linked to a branch
+getGroupsInBranches :: Phylo -> [PhyloGroup]
+getGroupsInBranches p = filter (\g -> isJust $ g ^. phylo_groupBranchId)
+                      $ getGroups p
+
+
 --------------------------------
 -- | PhyloQuery & QueryView | --
 --------------------------------
@@ -679,6 +694,13 @@ getPeriodSteps q = q ^. q_periodSteps
 -- | PhyloQueryBuild & PhyloQueryView Constructors | --
 --------------------------------------------------
 
+-- | To get the threshold of a Proximity
+getThreshold :: Proximity -> Double
+getThreshold prox = case prox of 
+  WeightedLogJaccard (WLJParams thr _) -> thr
+  Hamming (HammingParams thr)          -> thr
+  Filiation                            -> panic "[ERR][Viz.Phylo.Tools.getThreshold] Filiation"
+
 
 -- | To get the Proximity associated to a given Clustering method
 getProximity :: Cluster -> Proximity
@@ -689,14 +711,20 @@ getProximity cluster = case cluster of
 
 
 -- | To initialize all the Cluster / Proximity with their default parameters
-initFis :: Maybe Bool -> Maybe Support -> FisParams
-initFis (def True -> kmf) (def 1 -> min') = FisParams kmf min'
+initFis :: Maybe Bool -> Maybe Support -> Maybe Int -> FisParams
+initFis (def True -> kmf) (def 1 -> min') (def 1 -> thr) = FisParams kmf min' thr
 
 initHamming :: Maybe Double -> HammingParams
 initHamming (def 0.01 -> sens) = HammingParams sens
 
-initSmallBranch :: Maybe Int -> Maybe Int -> Maybe Int -> SBParams
-initSmallBranch (def 2 -> periodsInf) (def 2 -> periodsSup) (def 1 -> minNodes) = SBParams periodsInf periodsSup minNodes
+initLonelyBranch :: Maybe Int -> Maybe Int -> Maybe Int -> LBParams
+initLonelyBranch (def 2 -> periodsInf) (def 2 -> periodsSup) (def 1 -> minNodes) = LBParams periodsInf periodsSup minNodes
+
+initSizeBranch :: Maybe Int -> SBParams
+initSizeBranch (def 1 -> minSize) = SBParams minSize
+
+initLonelyBranch' :: Maybe Int -> Maybe Int -> Maybe Int -> LBParams
+initLonelyBranch' (def 0 -> periodsInf) (def 0 -> periodsSup) (def 1 -> minNodes) = LBParams periodsInf periodsSup minNodes
 
 initLouvain :: Maybe Proximity -> LouvainParams
 initLouvain (def defaultWeightedLogJaccard -> proxi) = LouvainParams proxi
@@ -715,6 +743,7 @@ initPhyloQueryBuild name desc (def 5 -> grain) (def 3 -> steps) (def defaultFis
     PhyloQueryBuild name desc grain steps cluster metrics filters matching' nthLevel nthCluster
 
 
+
 -- | To initialize a PhyloQueryView default parameters
 initPhyloQueryView :: Maybe Level -> Maybe Filiation -> Maybe Bool -> Maybe Level -> Maybe [Metric] -> Maybe [Filter] -> Maybe [Tagger] -> Maybe (Sort, Order) -> Maybe ExportMode -> Maybe DisplayMode -> Maybe Bool -> PhyloQueryView
 initPhyloQueryView (def 2 -> lvl) (def Descendant -> f) (def False -> c) (def 1 -> d) (def [] -> ms) (def [] -> fs) (def [] -> ts) s (def Json -> em) (def Flat -> dm) (def True -> v) =
@@ -732,7 +761,7 @@ shouldKeepMinorFis = _fis_keepMinorFis
 -- Clusters
 
 defaultFis :: Cluster
-defaultFis = Fis (initFis Nothing Nothing)
+defaultFis = Fis (initFis Nothing Nothing Nothing)
 
 defaultLouvain :: Cluster
 defaultLouvain = Louvain (initLouvain Nothing)
@@ -742,8 +771,11 @@ defaultRelatedComponents = RelatedComponents (initRelatedComponents Nothing)
 
 -- Filters
 
-defaultSmallBranch :: Filter
-defaultSmallBranch = SmallBranch (initSmallBranch Nothing Nothing Nothing)
+defaultLonelyBranch :: Filter
+defaultLonelyBranch = LonelyBranch (initLonelyBranch Nothing Nothing Nothing)
+
+defaultSizeBranch :: Filter
+defaultSizeBranch = SizeBranch (initSizeBranch Nothing)
 
 -- Params