{-|
Module      : Gargantext.Core.Viz.Phylo.PhyloMaker
Description : Maker engine for rebuilding a Phylo
Copyright   : (c) CNRS, 2017-Present
License     : AGPL + CECILL v3
Maintainer  : team@gargantext.org
Stability   : experimental
Portability : POSIX
-}


{-# OPTIONS_GHC -fno-warn-deprecations #-}
{-# LANGUAGE BangPatterns #-}

module Gargantext.Core.Viz.Phylo.PhyloMaker where


import Control.Lens hiding (Level)
import Control.Parallel.Strategies (parMap, rpar, Strategy)
import Data.Containers.ListUtils (nubOrd)
import Data.Discrimination qualified as D
import Data.List (partition, intersect)
import Data.List qualified as List
import Data.Map (fromListWith, keys, unionWith, fromList, empty, toList, elems, (!), restrictKeys, insert)
import Data.Map qualified as Map
import Data.Set qualified as Set
import Data.Text qualified as T
import Data.Vector qualified as Vector
import Data.Vector (Vector)
import Gargantext.Core.Methods.Graph.MaxClique (getMaxCliques)
import Gargantext.Core.Methods.Similarities (Similarity(Conditional))
import Gargantext.Core.Text.Metrics.FrequentItemSet (fisWithSizePolyMap, fisWithSizePolyMap', Size(..))
import Gargantext.Core.Viz.Phylo
import Gargantext.Core.Viz.Phylo.PhyloExport (toHorizon)
import Gargantext.Core.Viz.Phylo.PhyloTools
import Gargantext.Core.Viz.Phylo.SynchronicClustering (synchronicClustering)
import Gargantext.Core.Viz.Phylo.TemporalMatching (toPhyloQuality, temporalMatching, getNextPeriods, filterDocs, filterDiago, reduceDiagos, toSimilarity)
import Gargantext.Prelude hiding (empty, toList)



defaultStrategy :: Strategy a
defaultStrategy = rpar



------------------
-- | To Phylo | --
------------------

{-
-- TODO AD
data Phylo' = PhyloBase { _phylo'_phyloBase :: Phylo}
            | PhyloN    { _phylo'_flatPhylo :: Phylo}


toPhylo' :: Phylo' -> [Document] -> TermList -> PhyloConfig -> Phylo
toPhylo' (PhyloN    phylo) = toPhylo'
toPhylo' (PhyloBase phylo) = toPhylo
-}

-- TODO an adaptative synchronic clustering with a slider

toPhylo :: Phylo -> Phylo
toPhylo phylowithoutLink = traceToPhylo (phyloScale $ getConfig phylowithoutLink) $
    if (phyloScale $ getConfig phylowithoutLink) > 1
      then foldl' (\phylo' _ -> synchronicClustering phylo') phyloAncestors [2..(phyloScale $ getConfig phylowithoutLink)]
      else phyloAncestors
    where
        --------------------------------------
        phyloAncestors :: Phylo
        phyloAncestors =
            if (findAncestors $ getConfig phylowithoutLink)
              then toHorizon phyloWithLinks
              else phyloWithLinks
        --------------------------------------
        phyloWithLinks :: Phylo
        phyloWithLinks = temporalMatching (getLadder phylowithoutLink) phylowithoutLink
        --------------------------------------


-----------------------------
-- | Create a flat Phylo | --
-----------------------------


{-
-- create a square ladder
-}
squareLadder :: [Double] -> [Double]
squareLadder ladder = List.map (\x -> x * x) ladder


{-
-- create an adaptative 'sea elevation' ladder
-}
adaptSeaLadder :: Double -> Set Double -> Set Double -> [Double]
adaptSeaLadder curr similarities ladder =
  if curr <= 0 || Set.null similarities
    then Set.toList ladder
    else
      let idx = ((Set.size similarities) `div` (floor curr)) - 1
          thr = Set.elemAt idx similarities
      -- we use a sliding methods 1/10, then 1/9, then ... 1/2
      in adaptSeaLadder (curr -1) (Set.filter (> thr) similarities) (Set.insert thr ladder)


{-
-- create a constante 'sea elevation' ladder
-}
constSeaLadder :: Double -> Double -> Set Double -> [Double]
constSeaLadder curr step ladder =
  if curr > 1
    then Set.toList ladder
    else constSeaLadder (curr + step) step (Set.insert curr ladder)



{-
-- create an evolving 'sea elevation' ladder based on estimated & local quality maxima
-}
evolvSeaLadder :: Double -> Double -> Map Int Double -> Set Double -> [((PhyloGroup,PhyloGroup),Double)] -> [Double]
evolvSeaLadder nbFdt lambda freq similarities graph = map snd
                                                    $ filter fst
                                                    $ zip maxima (map fst qua')
                                                    -- 3) find the corresponding measures of similarity and create the ladder
  where
    --------
    -- 2) find the local maxima in the quality distribution
    -- TODO (seeg, #471) head throws errors when list is too short
    -- (i.e. List.head . List.tail requires at least 2 elements in the
    -- list). I propose this implementation, but I'm not sure of the
    -- length of the list
    maxima :: [Bool]
    maxima
      | List.null qua' = []
      | List.length qua' == 1 = [True]
      | otherwise = [snd (List.head qua') > snd (List.head $ List.tail qua')] ++
                    findMaxima qua' ++
                    [snd (List.head $ reverse qua') > snd (List.head $ List.tail $ reverse qua')]
    -- maxima = if List.length qua' > 1 then
    --   [snd (List.head qua') > snd (List.head $ List.tail qua')] ++
    --   (findMaxima qua') ++
    --   [snd (List.head $ reverse qua') > snd (List.head $ List.tail $ reverse qua')]
    --   else
    --     [True, True]
    -- maxima = [snd (List.head qua') > snd (List.head $ List.tail qua')] ++ (findMaxima qua') ++ [snd (List.head $ reverse qua') > snd (List.head $ List.tail $ reverse qua')]
    --------
    -- 1.2)
    qua' :: [(Double,Double)]
    qua' = foldl (\acc (s,q) ->
                    if null acc
                      then [(s,q)]
                      else if snd (List.last acc) == q
                        then acc
                      else acc ++ [(s,q)]
      ) [] $ zip (Set.toList similarities) qua
    --------
    -- 1.1) for each measure of similarity, prune the flat phylo, compute the branches and estimate the quality
    qua :: [Double]
    qua = parMap defaultStrategy (\thr ->
                let edges    = filter (\edge -> snd edge >= thr) graph
                    nodes    = nubOrd $ concatMap (\((n,n'),_) -> [n,n']) edges
                    branches = toRelatedComponents nodes edges
                 in toPhyloQuality nbFdt lambda freq branches
              ) $ Set.toList similarities


{-
-- find a similarity ladder regarding the "sea elevation" strategy
-}
findSeaLadder :: Phylo -> Phylo
findSeaLadder phylo = case getSeaElevation phylo of
    Constante  start gap -> phylo & phylo_seaLadder .~ (constSeaLadder start gap Set.empty)
    Adaptative steps     -> phylo & phylo_seaLadder .~ (squareLadder $ adaptSeaLadder steps similarities Set.empty)
    Evolving   _         -> let !ladder = evolvSeaLadder
                                           (fromIntegral $ Vector.length $ getRoots phylo)
                                           (getLevel phylo)
                                           (getRootsFreq phylo)
                                           similarities simGraph
                             in phylo & phylo_seaLadder .~ (if length ladder > 0
                                                              then ladder
                                                              -- if we don't find any local maxima with the evolving strategy
                                                              else constSeaLadder 0.1 0.1 Set.empty)
  where
    --------
    -- 2) extract the values of the kinship links
    similarities :: Set Double
    similarities = Set.fromList $ sort $ map snd simGraph
    --------
    -- 1) we process an initial calculation of the kinship links
    --    this initial calculation is used to estimate the real sea ladder
    simGraph :: [((PhyloGroup,PhyloGroup),Double)]
    simGraph = foldl' (\acc period ->
          -- 1.1) process period by period
                  let sources = getGroupsFromScalePeriods 1 [period] phylo
                      next    = getNextPeriods ToParents  3  period (keys $ phylo ^. phylo_periods)
                      targets = getGroupsFromScalePeriods 1 next phylo
                      docs    = filterDocs  (getDocsByDate phylo) ([period] ++ next)
                      diagos  = filterDiago (getCoocByDate phylo) ([period] ++ next)
          -- 1.2) compute the kinship similarities between pairs of source & target in parallel
                      pairs   = parMap defaultStrategy (\source ->
                                    let candidates = filter (\target -> (> 2) $ length
                                                   $ intersect (getGroupNgrams source) (getGroupNgrams target)) targets
                                     in map (\target ->
                                        let nbDocs = (sum . elems)
                                                   $ filterDocs docs ([idToPrd (getGroupId source), idToPrd (getGroupId target)])
                                            diago  = reduceDiagos
                                                   $ filterDiago diagos ([idToPrd (getGroupId source), idToPrd (getGroupId target)])
                                         in ((source,target),toSimilarity nbDocs diago (getSimilarity phylo) (getGroupNgrams source) (getGroupNgrams target) (getGroupNgrams target))
                                          ) candidates
                                ) sources
                   in acc ++ (concat pairs)
               ) [] $ keys $ phylo ^. phylo_periods

appendGroups :: (a -> Period -> (Text,Text) -> Scale -> Int -> [Cooc] ->  Map Int Double -> PhyloGroup) -> Scale -> Map (Date,Date) [a] -> Phylo -> Phylo
appendGroups f lvl m phylo =
  tracePhylo ("\n" <> "-- | Append "
         <> show (length $ concat $ elems m)
         <> " groups to scale "
         <> show (lvl) <> "\n" :: Text)
    $ over ( phylo_periods
           .  traverse
           . phylo_periodScales
           .  traverse)
           (\phyloLvl -> if lvl == (phyloLvl ^. phylo_scaleScale)
                         then
                            let pId  = phyloLvl ^. phylo_scalePeriod
                                pId' = phyloLvl ^. phylo_scalePeriodStr
                                phyloCUnit = m ! pId
                            in  phyloLvl
                              & phylo_scaleGroups .~ (fromList $ foldl (\groups obj ->
                                    groups ++ [ (((pId,lvl),length groups)
                                              , f obj pId pId' lvl (length groups)
                                                  -- select the cooc of the periods
                                                  (elems $ restrictKeys (getCoocByDate phylo) $ periodsToYears [pId])
                                                  -- select and merge the roots count of the periods
                                                  (foldl (\acc count -> unionWith (+) acc count) empty
                                                    $ elems $ restrictKeys (getRootsCountByDate phylo) $ periodsToYears [pId]))
                                              ] ) [] phyloCUnit)
                         else
                            phyloLvl )
           phylo


clusterToGroup :: Clustering -> Period -> (Text,Text) -> Scale ->  Int -> [Cooc] -> Map Int Double -> PhyloGroup
clusterToGroup fis pId pId' lvl idx coocs rootsCount = PhyloGroup pId pId' lvl idx ""
                   (fis ^. clustering_support )
                   (fis ^. clustering_visWeighting)
                   (fis ^. clustering_visFiltering)
                   (fis ^. clustering_roots)
                   (ngramsToCooc (fis ^. clustering_roots) coocs)
                   (ngramsToDensity (fis ^. clustering_roots) coocs rootsCount)
                   (1,[0]) -- branchid (lvl,[path in the branching tree])
                   (fromList [("breaks",[0]),("seaLevels",[0])])
                   rootsCount [] [] [] [] [] [] []


-----------------------
-- | To Phylo Step | --
-----------------------


indexDates' :: Map (Date,Date) [Document] -> Map (Date,Date) (Text,Text)
indexDates' m = map (\docs ->
  let ds = map (\d -> date' d) docs
      f = if (null ds || all T.null ds)
            then ""
            else toFstDate ds
      l = if (null ds || all T.null ds)
            then ""
            else toLstDate ds
   in (f,l)) m


-- create a map of roots and group ids
joinRoots :: Phylo -> Phylo
joinRoots phylo = set (phylo_foundations . foundations_rootsInGroups) rootsMap phylo
  where
    --------------------------------------
    rootsMap :: Map Int [PhyloGroupId]
    rootsMap = fromListWith (++)
             $ concatMap (\g ->
                        map (\n -> (n,[getGroupId g])) $ _phylo_groupNgrams g)
             $ getGroupsFromScale 1 phylo


maybeDefaultParams :: Phylo -> Phylo
maybeDefaultParams phylo =  if (defaultMode (getConfig phylo))
                           then findDefaultLevel phylo
                           else phylo


-- To build the first phylo step from docs and terms
-- QL: backend entre phyloBase et Clustering
toPhyloWithoutLink :: [Document] -> PhyloConfig -> Phylo
toPhyloWithoutLink docs conf = joinRoots
                             $ findSeaLadder
                             $ maybeDefaultParams
                             $ appendGroups clusterToGroup 1 seriesOfClustering (updatePeriods (indexDates' docs') phyloBase)
    where
        --------------------------------------
        seriesOfClustering :: Map (Date,Date) [Clustering]
        seriesOfClustering =  toSeriesOfClustering phyloBase docs'
        --------------------------------------
        docs' :: Map (Date,Date) [Document]
        -- QL: Time Consuming here
        docs' =  groupDocsByPeriodRec date (getPeriodIds phyloBase) (sortOn date docs) empty
        --------------------------------------
        phyloBase :: Phylo
        phyloBase = initPhylo docs conf
        --------------------------------------

---------------------------
-- | Frequent Item Set | --
---------------------------


--  To apply a filter with the possibility of keeping some periods non empty (keep : True|False)
filterClique :: Bool -> Int -> (Int -> [Clustering] -> [Clustering]) -> Map (Date, Date) [Clustering] -> Map (Date, Date) [Clustering]
filterClique keep thr f m = case keep of
  False -> map (\l -> f thr l) m
  True  -> map (\l -> keepFilled (f) thr l) m


--  To filter Fis with small Support
filterCliqueBySupport :: Int -> [Clustering] -> [Clustering]
filterCliqueBySupport thr l = filter (\clq -> (clq ^. clustering_support ) >= thr) l


--  To filter Fis with small Clique size
filterCliqueBySize :: Int -> [Clustering] -> [Clustering]
filterCliqueBySize thr l = filter (\clq -> (length $ clq ^. clustering_roots) >= thr) l


--  To filter nested Fis
filterCliqueByNested :: Map (Date, Date) [Clustering] -> Map (Date, Date) [Clustering]
filterCliqueByNested m =
  let clq  = parMap defaultStrategy (\l ->
                foldl (\mem f -> if (any (\f' -> isNested (f' ^. clustering_roots) (f ^. clustering_roots)) mem)
                                 then mem
                                 else
                                    let fMax = filter (\f' -> not $ isNested (f ^. clustering_roots) (f' ^. clustering_roots)) mem
                                    in  fMax ++ [f] ) [] l)
           $ elems m
  in  fromList $ zip (keys m) clq


-- | To transform a time map of docs into a time map of Fis with some filters
toSeriesOfClustering :: Phylo -> Map (Date, Date) [Document] -> Map (Date,Date) [Clustering]
toSeriesOfClustering phylo phyloDocs = case clique $ getConfig phylo of
    Fis s s'    -> -- traceFis "Filtered Fis"
                   filterCliqueByNested
                 {- \$ traceFis "Filtered by clique size" -}
                 $ filterClique True s' filterCliqueBySize
                 {- \$ traceFis "Filtered by support" -}
                 $ filterClique True s filterCliqueBySupport
                 {- \$ traceFis "Unfiltered Fis" -}
                 (toSeriesOfClusteringFis phylo phyloDocs)
    MaxClique s thr filterType -> filterClique True s filterCliqueBySize
                       (toSeriesOfClusteringMaxClique phylo phyloDocs (thr, filterType))

        --------------------------------------

toSeriesOfClusteringFis :: Phylo -> Map (Date, Date) [Document] -> Map (Date,Date) [Clustering]
toSeriesOfClusteringFis phylo phyloDocs = fromList $ parMap rpar (func (corpusParser $ getConfig phylo)) (toList phyloDocs)
  where
    func (Tsv' _) (prd, docs) =
      let lst = toList
            $ fisWithSizePolyMap' (Segment 1 20) 1
            $ map (\d -> ( ngramsToIdx (text d) (getRoots phylo)
                         , ( weight d, sourcesToIdx (sources d) (getSources phylo)) )
                  ) docs
      in ( prd
         , map (\f -> Clustering { _clustering_roots = Set.toList $ fst f
                                 , _clustering_support = (fst . snd) f
                                 , _clustering_period = prd
                                 , _clustering_visWeighting = (fst . snd . snd) f
                                 , _clustering_visFiltering = (snd . snd . snd) f } ) lst)
    func _ (prd, docs) =
      let lst = toList $
            fisWithSizePolyMap (Segment 1 20) 1
            $ map (\d -> ngramsToIdx (text d) (getRoots phylo)) docs
      in ( prd
         , map (\f -> Clustering { _clustering_roots = Set.toList $ fst f
                                 , _clustering_support = snd f
                                 , _clustering_period = prd
                                 , _clustering_visWeighting = Just $ fromIntegral $ snd f
                                 , _clustering_visFiltering = [] }) lst)


toSeriesOfClusteringMaxClique :: Phylo -> Map (Date, Date) [Document] -> (Double, MaxCliqueFilter) -> Map (Date,Date) [Clustering]
toSeriesOfClusteringMaxClique phylo phyloDocs (thr, filterType) = fromList mcl
 where
   -- This looks innocent but is a big performance
   -- improvement. Suppose there are few docs but many periods (like
   -- when one computes phylo with second or minute
   -- resolution). Without pattern matching on empty docs (many
   -- periods will have no docs associated), one will fire
   -- `getMaxCliques` with all the Accelerate machinery.
   mapFunc (prd, []) = (prd, [])
   mapFunc (prd, docs) = 
               let cooc = map round
                        $ foldl sumCooc empty
                        $ map (\d -> listToMatrix $ ngramsToIdx (text d) (getRoots phylo)) docs
                in ( prd
                   , map (\cl -> Clustering { _clustering_roots = cl
                                            , _clustering_support = 0
                                            , _clustering_period = prd
                                            , _clustering_visWeighting = Nothing
                                            , _clustering_visFiltering = [] })
                         $ getMaxCliques filterType Conditional thr cooc)
   mcl  = parMap rpar mapFunc $ toList phyloDocs
--------------------------------------

        -- dev viz graph maxClique getMaxClique


--------------------
-- | Coocurency | --
--------------------


--  To transform the docs into a time map of coocurency matrix
docsToTimeScaleCooc :: [Document] -> Vector Ngrams -> Map Date Cooc
docsToTimeScaleCooc docs fdt =
    let mCooc  = fromListWith sumCooc
               $ map (\(_d,l) -> (_d, listToMatrix l))
               $ map (\doc -> (date doc, D.sort $ ngramsToIdx (text doc) fdt)) docs
        mCooc' = fromList
               $ map (\t -> (t,empty))
               $ toTimeScale (map date docs) 1
    in  tracePhylo ("\n" <> "-- | Build the coocurency matrix for "
               <> show (length $ keys mCooc')
               <> " unit of time" <> "\n" :: Text)
       $ unionWith sumCooc mCooc mCooc'


-----------------------
-- | to Phylo Base | --
-----------------------

-- TODO anoe
groupDocsByPeriodRec :: (NFData doc, Ord date, Enum date) => (doc -> date) -> [(date,date)] -> [doc] -> Map (date, date) [doc] -> Map (date, date) [doc]
groupDocsByPeriodRec f prds docs acc =
  case (prds, docs) of
    ([], _) -> acc
    (_, []) -> acc
    (prd:prds', _) ->
        let docs' = partition (\d -> (f d >= fst prd) && (f d <= snd prd)) docs
         in groupDocsByPeriodRec f prds' (snd docs') (insert prd (fst docs') acc)


--  To group a list of Documents by fixed periods
groupDocsByPeriod' :: (NFData doc, Ord date, Enum date) => (doc -> date) -> [(date,date)] -> [doc] -> Map (date, date) [doc]
groupDocsByPeriod' f pds docs =
  let docs'    = groupBy (\d d' -> f d == f d') $ sortOn f docs
      periods  = parMap defaultStrategy (inPeriode f docs') pds
   in tracePhylo ("\n" <> "-- | Group "
             <> show (length docs)
             <> " docs by "
             <> show (length pds) <> " periods" <> "\n" :: Text)
    $ fromList $ zip pds periods
  where
    --------------------------------------
    inPeriode :: Ord b => (t -> b) -> [[t]] -> (b, b) -> [t]
    inPeriode f' h (start,end) =
      concat $ fst $ partition (\d -> f' (head' "inPeriode" d) >= start && f' (head' "inPeriode" d) <= end) h



--  To group a list of Documents by fixed periods
groupDocsByPeriod :: (NFData doc, Ord date, Enum date) => (doc -> date) -> [(date,date)] -> [doc] -> Map (date, date) [doc]
groupDocsByPeriod _ _   [] = panic "[ERR][Viz.Phylo.PhyloMaker] Empty [Documents] can not have any periods"
groupDocsByPeriod f pds es =
  let periods  = parMap defaultStrategy (inPeriode f es) pds

  in  tracePhylo ("\n" <> "-- | Group "
             <> show (length es) <> " docs by "
             <> show (length pds) <> " periods" <> "\n" :: Text)
    $ fromList $ zip pds periods
  where
    --------------------------------------
    inPeriode :: Ord b => (t -> b) -> [t] -> (b, b) -> [t]
    inPeriode f' h (start,end) =
      fst $ partition (\d -> f' d >= start && f' d <= end) h
    --------------------------------------


docsToTermFreq :: [Document] -> Vector Ngrams -> Map Int Double
docsToTermFreq docs fdt =
  let nbDocs = fromIntegral $ length docs
      freqs = map (/(nbDocs))
             $ fromList
             $ map (\lst -> (head' "docsToTermFreq" lst, fromIntegral $ length lst))
             $ group $ D.sort $ concat $ map (\d -> D.nub $ ngramsToIdx (text d) fdt) docs
      sumFreqs = sum $ elems freqs
   in map (/sumFreqs) freqs


docsToTermCount :: [Document] -> Vector Ngrams -> Map Int Double
docsToTermCount docs roots = fromList
             $ map (\lst -> (head' "docsToTermCount" lst, fromIntegral $ length lst))
             $ group $ D.sort $ concat $ map (\d -> D.nub $ ngramsToIdx (text d) roots) docs



docsToTimeTermCount :: [Document] -> Vector Ngrams  -> (Map Date (Map Int Double))
docsToTimeTermCount docs roots =
    let docs' = Map.map (\l -> fromList $ map (\lst -> (head' "docsToTimeTermCount" lst, fromIntegral $ length lst))
                             $ group $ D.sort l)
              $ fromListWith (++)
              $ map (\d -> (date d, D.nub $ ngramsToIdx (text d) roots)) docs
        time  = fromList $ map (\t -> (t,Map.empty)) $ toTimeScale (keys docs') 1
     in unionWith (Map.union) time docs'


docsToLastTermFreq :: Int -> [Document] -> Vector Ngrams -> Map Int Double
docsToLastTermFreq n docs fdt =
  let last   = take n $ reverse $ D.sort $ map date docs
      nbDocs = fromIntegral $ length $ filter (\d -> elem (date d) last) docs
      freqs  = map (/(nbDocs))
             $ fromList
             $ map (\lst -> (head' "docsToLastTermFreq" lst, fromIntegral $ length lst))
             $ group $ D.sort $ concat $ map (\d -> D.nub $ ngramsToIdx (text d) fdt) $ filter (\d -> elem (date d) last) docs
      sumFreqs = sum $ elems freqs
   in map (/sumFreqs) freqs


--  To count the number of docs by unit of time
docsToTimeScaleNb :: [Document] -> Map Date Double
docsToTimeScaleNb docs =
    let docs' = fromListWith (+) $ map (\d -> (date d,1)) docs
        time  = fromList $ map (\t -> (t,0)) $ toTimeScale (keys docs') 1
    in  tracePhylo ("\n" <> "-- | Group "
               <> show (length docs)
               <> " docs by "
               <> show (length time)
               <> " unit of time" <> "\n" :: Text)
      $ unionWith (+) time docs'


initPhyloScales :: Int -> Period -> Map PhyloScaleId PhyloScale
initPhyloScales lvlMax pId =
    fromList $ map (\lvl -> ((pId,lvl),PhyloScale pId ("","") lvl empty)) [1..lvlMax]



setDefault :: PhyloConfig -> TimeUnit -> Int -> PhyloConfig
setDefault conf timeScale nbDocs = defaultConfig
                                          { corpusPath   = (corpusPath conf)
                                          , listPath     = (listPath conf)
                                          , outputPath   = (outputPath conf)
                                          , corpusParser = (corpusParser conf)
                                          , listParser   = (listParser conf)
                                          , phyloName    = (phyloName conf)
                                          , defaultMode  = True
                                          , timeUnit     = timeScale
                                          , clique       = Fis (toSupport nbDocs) 3}
  where
    --------------------------------------
    toSupport :: Int -> Support
    toSupport n
      | n < 500  = 1
      | n < 1000 = 2
      | n < 2000 = 3
      | n < 3000 = 4
      | n < 5000 = 5
      | otherwise = 6
    --------------------------------------                                                          


--  Init the basic elements of a Phylo
--
initPhylo :: [Document] -> PhyloConfig -> Phylo
initPhylo docs conf =
    let roots = Vector.fromList $ D.nubWith T.unpack $ concatMap text docs
        timeScale = head' "initPhylo" $ map docTime docs
        foundations = PhyloFoundations { _foundations_roots = roots
                                       , _foundations_rootsInGroups = empty }
        docsSources = PhyloSources {_sources = Vector.fromList $ nubOrd $ concatMap sources docs }
        docsCounts  = PhyloCounts { coocByDate = docsToTimeScaleCooc docs roots
                                  , docsByDate = docsToTimeScaleNb docs
                                  , rootsCountByDate = docsToTimeTermCount docs roots
                                  , rootsCount = docsToTermCount docs roots
                                  , rootsFreq = docsToTermFreq docs roots
                                  , lastRootsFreq = docsToLastTermFreq (getTimePeriod timeScale) docs roots }
        params = if defaultMode conf
                 then defaultPhyloParam { _phyloParam_config = setDefault conf timeScale (length docs) }
                 else defaultPhyloParam { _phyloParam_config = conf }
        periods = toPeriods (D.sort $ D.nub $ map date docs) (getTimePeriod timeScale) (getTimeStep timeScale)
    in tracePhylo ("\n" <> "-- | Init a phylo out of "
              <> show (length docs) <> " docs \n" :: Text)
       $ tracePhylo ("\n" <> "-- | lambda "
                <> show (_qua_granularity $ phyloQuality $ _phyloParam_config params) :: Text)
       $ Phylo { _phylo_foundations = foundations
               , _phylo_sources = docsSources
               , _phylo_counts = docsCounts
               , _phylo_seaLadder = []
               , _phylo_param = params
               , _phylo_periods =
                   fromList $ map (\prd -> (prd, PhyloPeriod { _phylo_periodPeriod = prd
                                                             , _phylo_periodPeriodStr = ("", "")
                                                             , _phylo_periodScales = initPhyloScales 1 prd })) periods
               , _phylo_quality = 0
               , _phylo_level = _qua_granularity $ phyloQuality $ _phyloParam_config params
               , _phylo_computeTime = Nothing }
