Portability : POSIX
-}
-
module Gargantext.Core.Viz.Phylo.PhyloMaker where
+import Control.DeepSeq (NFData)
+import Control.Lens hiding (Level)
+import Control.Parallel.Strategies (parList, rdeepseq, using)
import Data.List (concat, nub, partition, sort, (++), group, intersect, null, sortOn, groupBy, tail)
import Data.Map (Map, fromListWith, keys, unionWith, fromList, empty, toList, elems, (!), restrictKeys, foldlWithKey, insert)
+import Data.Text (Text)
import Data.Vector (Vector)
+import Debug.Trace (trace)
-import Gargantext.Prelude
-import Gargantext.Core.Viz.AdaptativePhylo
+import Gargantext.Core.Methods.Distances (Distance(Conditional))
+import Gargantext.Core.Methods.Graph.MaxClique (getMaxCliques)
+import Gargantext.Core.Text.Context (TermList)
+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.TemporalMatching (adaptativeTemporalMatching, constanteTemporalMatching, getNextPeriods, filterDocs, filterDiago, reduceDiagos, toProximity)
import Gargantext.Core.Viz.Phylo.SynchronicClustering (synchronicClustering)
-import Gargantext.Core.Text.Context (TermList)
-import Gargantext.Core.Text.Metrics.FrequentItemSet (fisWithSizePolyMap, Size(..))
-import Gargantext.Core.Viz.Graph.MaxClique (getMaxCliques)
-import Gargantext.Core.Viz.Graph.Distances (Distance(Conditional))
-
-import Control.DeepSeq (NFData)
-import Control.Parallel.Strategies (parList, rdeepseq, using)
-import Debug.Trace (trace)
-import Control.Lens hiding (Level)
+import Gargantext.Core.Viz.Phylo.TemporalMatching (adaptativeTemporalMatching, constanteTemporalMatching, getNextPeriods, filterDocs, filterDiago, reduceDiagos, toProximity)
+import Gargantext.Prelude
-import qualified Data.Vector as Vector
import qualified Data.Set as Set
+import qualified Data.Vector as Vector
------------------
-- | To Phylo | --
------------------
+{-
+-- TODO AD
+data Phylo' = PhyloBase { _phylo'_phyloBase :: Phylo}
+ | PhyloN { _phylo'_phylo1 :: Phylo}
+
-toPhylo :: [Document] -> TermList -> Config -> Phylo
-toPhylo docs lst conf = trace ("# phylo1 groups " <> show(length $ getGroupsFromLevel 1 phylo1))
- $ traceToPhylo (phyloLevel conf) $
- if (phyloLevel conf) > 1
- then foldl' (\phylo' _ -> synchronicClustering phylo') phylo1 [2..(phyloLevel conf)]
+toPhylo' :: Phylo' -> [Document] -> TermList -> PhyloConfig -> Phylo
+toPhylo' (PhyloN phylo) = toPhylo'
+toPhylo' (PhyloBase phylo) = toPhylo
+-}
+
+
+toPhylo :: Phylo -> Phylo
+toPhylo phyloStep = trace ("# phylo1 groups " <> show(length $ getGroupsFromLevel 1 phylo1))
+ $ traceToPhylo (phyloLevel $ getConfig phyloStep) $
+ if (phyloLevel $ getConfig phyloStep) > 1
+ then foldl' (\phylo' _ -> synchronicClustering phylo') phyloAncestors [2..(phyloLevel $ getConfig phyloStep)]
else phylo1
where
--------------------------------------
- phylo1 :: Phylo
- phylo1 = toPhylo1 docs phyloBase
+ phyloAncestors :: Phylo
+ phyloAncestors =
+ if (findAncestors $ getConfig phyloStep)
+ then toHorizon phylo1
+ else phylo1
--------------------------------------
- phyloBase :: Phylo
- phyloBase = toPhyloBase docs lst conf
+ phylo1 :: Phylo
+ phylo1 = toPhylo1 phyloStep
--------------------------------------
-
--------------------
-- | To Phylo 1 | --
--------------------
in phylo & phylo_groupsProxi .~ ((traceGroupsProxi . fromList) groupsProxi)
-appendGroups :: (a -> PhyloPeriodId -> Level -> Int -> [Cooc] -> PhyloGroup) -> Level -> Map (Date,Date) [a] -> Phylo -> Phylo
+appendGroups :: (a -> PhyloPeriodId -> (Text,Text) -> Level -> Int -> [Cooc] -> PhyloGroup) -> Level -> Map (Date,Date) [a] -> Phylo -> Phylo
appendGroups f lvl m phylo = trace ("\n" <> "-- | Append " <> show (length $ concat $ elems m) <> " groups to Level " <> show (lvl) <> "\n")
$ over ( phylo_periods
. traverse
. traverse)
(\phyloLvl -> if lvl == (phyloLvl ^. phylo_levelLevel)
then
- let pId = phyloLvl ^. phylo_levelPeriod
+ let pId = phyloLvl ^. phylo_levelPeriod
+ pId' = phyloLvl ^. phylo_levelPeriod'
phyloCUnit = m ! pId
in phyloLvl
& phylo_levelGroups .~ (fromList $ foldl (\groups obj ->
groups ++ [ (((pId,lvl),length groups)
- , f obj pId lvl (length groups)
+ , f obj pId pId' lvl (length groups)
(elems $ restrictKeys (phylo ^. phylo_timeCooc) $ periodsToYears [pId]))
] ) [] phyloCUnit)
else
phylo
-cliqueToGroup :: PhyloClique -> PhyloPeriodId -> Level -> Int -> [Cooc] -> PhyloGroup
-cliqueToGroup fis pId lvl idx coocs = PhyloGroup pId lvl idx ""
+cliqueToGroup :: PhyloClique -> PhyloPeriodId -> (Text,Text) -> Level -> Int -> [Cooc] -> PhyloGroup
+cliqueToGroup fis pId pId' lvl idx coocs = PhyloGroup pId pId' lvl idx ""
(fis ^. phyloClique_support)
+ (fis ^. phyloClique_weight)
+ (fis ^. phyloClique_sources)
(fis ^. phyloClique_nodes)
(ngramsToCooc (fis ^. phyloClique_nodes) coocs)
(1,[0]) -- branchid (lvl,[path in the branching tree])
(fromList [("breaks",[0]),("seaLevels",[0])])
- [] [] [] [] []
+ [] [] [] [] [] [] []
-toPhylo1 :: [Document] -> Phylo -> Phylo
-toPhylo1 docs phyloBase = case (getSeaElevation phyloBase) of
- Constante start gap -> constanteTemporalMatching start gap
- $ appendGroups cliqueToGroup 1 phyloClique phyloBase
- Adaptative steps -> adaptativeTemporalMatching steps
- $ toGroupsProxi 1
- $ appendGroups cliqueToGroup 1 phyloClique phyloBase
+toPhylo1 :: Phylo -> Phylo
+toPhylo1 phyloStep = case (getSeaElevation phyloStep) of
+ Constante start gap -> constanteTemporalMatching start gap phyloStep
+ Adaptative steps -> adaptativeTemporalMatching steps phyloStep
+
+-----------------------
+-- | 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)
+ then ""
+ else toFstDate ds
+ l = if (null ds)
+ then ""
+ else toLstDate ds
+ in (f,l)) m
+
+
+-- To build the first phylo step from docs and terms
+-- QL: backend entre phyloBase et phyloClique
+toPhyloStep :: [Document] -> TermList -> PhyloConfig -> Phylo
+toPhyloStep docs lst conf = case (getSeaElevation phyloBase) of
+ Constante _ _ -> appendGroups cliqueToGroup 1 phyloClique (updatePeriods (indexDates' docs') phyloBase)
+ Adaptative _ -> toGroupsProxi 1
+ $ appendGroups cliqueToGroup 1 phyloClique (updatePeriods (indexDates' docs') phyloBase)
where
--------------------------------------
phyloClique :: Map (Date,Date) [PhyloClique]
phyloClique = toPhyloClique phyloBase docs'
--------------------------------------
docs' :: Map (Date,Date) [Document]
+ -- QL: Time Consuming here
docs' = groupDocsByPeriodRec date (getPeriodIds phyloBase) (sortOn date docs) empty
- -- docs' = groupDocsByPeriod' date (getPeriodIds phyloBase) docs
--------------------------------------
-
+ phyloBase :: Phylo
+ phyloBase = toPhyloBase docs lst conf
+ --------------------------------------
---------------------------
-- | Frequent Item Set | --
$ filterClique True s (filterCliqueBySupport)
{- \$ traceFis "Unfiltered Fis" -}
phyloClique
- MaxClique s -> filterClique True s (filterCliqueBySize)
- phyloClique
+ MaxClique s _ _ -> filterClique True s (filterCliqueBySize)
+ phyloClique
where
--------------------------------------
phyloClique :: Map (Date,Date) [PhyloClique]
phyloClique = case (clique $ getConfig phylo) of
Fis _ _ ->
let fis = map (\(prd,docs) ->
- let lst = toList $ fisWithSizePolyMap (Segment 1 20) 1 (map (\d -> ngramsToIdx (text d) (getRoots phylo)) docs)
- in (prd, map (\f -> PhyloClique (Set.toList $ fst f) (snd f) prd) lst))
+ case (corpusParser $ getConfig phylo) of
+ Csv' _ -> 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 -> PhyloClique (Set.toList $ fst f) ((fst . snd) f) prd ((fst . snd . snd) f) (((snd . snd . snd) f))) lst)
+ _ -> let lst = toList
+ $ fisWithSizePolyMap (Segment 1 20) 1 (map (\d -> ngramsToIdx (text d) (getRoots phylo)) docs)
+ in (prd, map (\f -> PhyloClique (Set.toList $ fst f) (snd f) prd (Just $ fromIntegral $ snd f) []) lst)
+ )
$ toList phyloDocs
fis' = fis `using` parList rdeepseq
in fromList fis'
- MaxClique _ ->
+ MaxClique _ thr filterType ->
let mcl = map (\(prd,docs) ->
let cooc = map round
$ foldl sumCooc empty
$ map listToMatrix
$ map (\d -> ngramsToIdx (text d) (getRoots phylo)) docs
- in (prd, map (\cl -> PhyloClique cl 0 prd) $ getMaxCliques Conditional 0.001 cooc))
+ in (prd, map (\cl -> PhyloClique cl 0 prd Nothing []) $ getMaxCliques filterType Conditional thr cooc))
$ toList phyloDocs
mcl' = mcl `using` parList rdeepseq
in fromList mcl'
-----------------------
-- | 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 =
+groupDocsByPeriodRec f prds docs acc =
if ((null prds) || (null docs))
then acc
else
-- 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 =
+groupDocsByPeriod' f pds docs =
let docs' = groupBy (\d d' -> f d == f d') $ sortOn f docs
periods = map (inPeriode f docs') pds
periods' = periods `using` parList rdeepseq
-- 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 =
+groupDocsByPeriod f pds es =
let periods = map (inPeriode f es) pds
periods' = periods `using` parList rdeepseq
sumFreqs = sum $ elems freqs
in map (/sumFreqs) freqs
+docsToLastTermFreq :: Int -> [Document] -> Vector Ngrams -> Map Int Double
+docsToLastTermFreq n docs fdt =
+ let last = take n $ reverse $ 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 $ sort $ concat $ map (\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
initPhyloLevels :: Int -> PhyloPeriodId -> Map PhyloLevelId PhyloLevel
initPhyloLevels lvlMax pId =
- fromList $ map (\lvl -> ((pId,lvl),PhyloLevel pId lvl empty)) [1..lvlMax]
+ fromList $ map (\lvl -> ((pId,lvl),PhyloLevel pId ("","") lvl empty)) [1..lvlMax]
+
-- To init the basic elements of a Phylo
-toPhyloBase :: [Document] -> TermList -> Config -> Phylo
+toPhyloBase :: [Document] -> TermList -> PhyloConfig -> Phylo
toPhyloBase docs lst conf =
let foundations = PhyloFoundations (Vector.fromList $ nub $ concat $ map text docs) lst
+ docsSources = PhyloSources (Vector.fromList $ nub $ concat $ map sources docs)
params = defaultPhyloParam { _phyloParam_config = conf }
periods = toPeriods (sort $ nub $ map date docs) (getTimePeriod $ timeUnit conf) (getTimeStep $ timeUnit conf)
in trace ("\n" <> "-- | Create PhyloBase out of " <> show(length docs) <> " docs \n")
$ Phylo foundations
+ docsSources
(docsToTimeScaleCooc docs (foundations ^. foundations_roots))
(docsToTimeScaleNb docs)
(docsToTermFreq docs (foundations ^. foundations_roots))
+ (docsToLastTermFreq (getTimePeriod $ timeUnit conf) docs (foundations ^. foundations_roots))
empty
empty
params
- (fromList $ map (\prd -> (prd, PhyloPeriod prd (initPhyloLevels 1 prd))) periods)
+ (fromList $ map (\prd -> (prd, PhyloPeriod prd ("","") (initPhyloLevels 1 prd))) periods)