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
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]
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
-- | 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)
-- | 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 | --
--------------------
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
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
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
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]
lbl
(sort $ map (\x -> getIdxInRoots x p) ngrams)
(Map.empty)
- (Map.empty)
Nothing
[] [] [] []
-- | 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
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]
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 | --
--------------------------------
-- | 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
-- | 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
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) =
-- Clusters
defaultFis :: Cluster
-defaultFis = Fis (initFis Nothing Nothing)
+defaultFis = Fis (initFis Nothing Nothing Nothing)
defaultLouvain :: Cluster
defaultLouvain = Louvain (initLouvain 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