Skip to content

haskell-gargantext
haskell-gargantext
Commit 66f96f84 authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

[MERGE]

parent 54d94963
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 603 additions and 559 deletions
gargantext.cabal
View file @ 66f96f84
......@@ -5,7 +5,7 @@ cabal-version: 1.12
-- see: https://github.com/sol/hpack
name: gargantext
version: 0.0.6.9.5
version: 0.0.6.9.5
synopsis: Search, map, share
description: Please see README.md
category: Data
......
src/Gargantext/Core/Viz/Phylo.hs
View file @ 66f96f84
......@@ -30,8 +30,7 @@ import Control.DeepSeq (NFData)
import Control.Lens (makeLenses)
import Data.Aeson
import Data.Aeson.TH (deriveJSON)
import Data.Map.Strict (Map)
import Data.Set (Set)
import Data.Map (Map)
import Data.Swagger
import Data.Text (Text, pack)
import Data.Vector (Vector)
......@@ -64,9 +63,9 @@ instance ToSchema ListParser
data SeaElevation =
Constante
{ _cons_start :: Double
, _cons_gap :: Double }
, _cons_step :: Double }
| Adaptative
{ _adap_steps :: Double }
{ _adap_granularity :: Double }
deriving (Show,Generic,Eq)
instance ToSchema SeaElevation
......@@ -78,8 +77,8 @@ data Proximity =
| WeightedLogSim
{ _wls_sensibility :: Double
, _wls_minSharedNgrams :: Int }
| Hamming
{ _hmg_sensibility :: Double
| Hamming
{ _hmg_sensibility :: Double
, _hmg_minSharedNgrams :: Int}
deriving (Show,Generic,Eq)
......@@ -205,7 +204,7 @@ data PhyloSubConfig =
subConfig2config :: PhyloSubConfig -> PhyloConfig
subConfig2config subConfig = defaultConfig { phyloProximity = WeightedLogJaccard (_sc_phyloProximity subConfig) 1
subConfig2config subConfig = defaultConfig { phyloProximity = WeightedLogJaccard (_sc_phyloProximity subConfig) 1
, phyloSynchrony = ByProximityThreshold (_sc_phyloSynchrony subConfig) 0 AllBranches MergeAllGroups
, phyloQuality = Quality (_sc_phyloQuality subConfig) 1
, timeUnit = _sc_timeUnit subConfig
......@@ -307,8 +306,8 @@ instance ToSchema Software where
defaultSoftware :: Software
defaultSoftware =
Software { _software_name = pack "GarganText"
, _software_version = pack "v5" }
Software { _software_name = pack "Gargantext"
, _software_version = pack "v4" }
-- | Global parameters of a Phylo
......@@ -325,7 +324,7 @@ instance ToSchema PhyloParam where
defaultPhyloParam :: PhyloParam
defaultPhyloParam =
PhyloParam { _phyloParam_version = pack "v3"
PhyloParam { _phyloParam_version = pack "v2.adaptative"
, _phyloParam_software = defaultSoftware
, _phyloParam_config = defaultConfig }
......@@ -410,7 +409,8 @@ data Phylo =
, _phylo_timeDocs :: !(Map Date Double)
, _phylo_termFreq :: !(Map Int Double)
, _phylo_lastTermFreq :: !(Map Int Double)
, _phylo_diaSimScan :: Set Double
, _phylo_horizon :: !(Map (PhyloGroupId,PhyloGroupId) Double)
, _phylo_groupsProxi :: !(Map (PhyloGroupId,PhyloGroupId) Double)
, _phylo_param :: PhyloParam
, _phylo_periods :: Map Period PhyloPeriod
, _phylo_quality :: Double
......
src/Gargantext/Core/Viz/Phylo/Example.hs
View file @ 66f96f84
This diff is collapsed.
src/Gargantext/Core/Viz/Phylo/PhyloExport.hs
View file @ 66f96f84
......@@ -19,7 +19,7 @@ import Data.GraphViz.Attributes.Complete hiding (EdgeType, Order)
import Data.GraphViz.Types.Generalised (DotGraph)
import Data.GraphViz.Types.Monadic
import Data.List ((++), sort, nub, null, concat, sortOn, groupBy, union, (\\), (!!), init, partition, notElem, unwords, nubBy, inits, elemIndex)
import Data.Map.Strict (Map, fromList, empty, fromListWith, insert, (!), elems, unionWith, findWithDefault, toList, member)
import Data.Map (Map, fromList, empty, fromListWith, insert, (!), elems, unionWith, findWithDefault, toList, member)
import Data.Text.Lazy (fromStrict, pack, unpack)
import Data.Vector (Vector)
import Debug.Trace (trace)
......@@ -375,7 +375,7 @@ processSort sort' elev export = case sort' of
ByBirthDate o -> sortByBirthDate o export
ByHierarchy _ -> case elev of
Constante s s' -> export & export_branches .~ (branchToIso' s s' $ sortByHierarchy 0 (export ^. export_branches))
Adaptative _ -> export & export_branches .~ (branchToIso $ sortByHierarchy 0 (export ^. export_branches))
Adaptative _ -> export & export_branches .~ (branchToIso $ sortByHierarchy 0 (export ^. export_branches))
-----------------
-- | Metrics | --
......@@ -546,10 +546,9 @@ processLabels labels foundations freq export =
-- | Dynamics | --
------------------
-- utiliser & creer une Map FdtId [PhyloGroup]
-- n = index of the current term
toDynamics :: FdtId -> [PhyloGroup] -> PhyloGroup -> Map FdtId (Date,Date) -> Double
toDynamics n elders g m =
toDynamics :: Int -> [PhyloGroup] -> PhyloGroup -> Map Int (Date,Date) -> Double
toDynamics n parents g m =
let prd = g ^. phylo_groupPeriod
end = last' "dynamics" (sort $ map snd $ elems m)
in if (((snd prd) == (snd $ m ! n)) && (snd prd /= end))
......@@ -565,18 +564,18 @@ toDynamics n elders g m =
where
--------------------------------------
isNew :: Bool
isNew = not $ elem n $ concat $ map _phylo_groupNgrams elders
isNew = not $ elem n $ concat $ map _phylo_groupNgrams parents
type FdtId = Int
processDynamics :: [PhyloGroup] -> [PhyloGroup]
processDynamics groups =
map (\g ->
let elders = filter (\g' -> (g ^. phylo_groupBranchId == g' ^. phylo_groupBranchId)
let parents = filter (\g' -> (g ^. phylo_groupBranchId == g' ^. phylo_groupBranchId)
&& ((fst $ g ^. phylo_groupPeriod) > (fst $ g' ^. phylo_groupPeriod))) groups
in g & phylo_groupMeta %~ insert "dynamics" (map (\n -> toDynamics n elders g mapNgrams) $ g ^. phylo_groupNgrams) ) groups
in g & phylo_groupMeta %~ insert "dynamics" (map (\n -> toDynamics n parents g mapNgrams) $ g ^. phylo_groupNgrams) ) groups
where
--------------------------------------
mapNgrams :: Map FdtId (Date,Date)
mapNgrams :: Map Int (Date,Date)
mapNgrams = map (\dates ->
let dates' = sort dates
in (head' "dynamics" dates', last' "dynamics" dates'))
......@@ -622,7 +621,7 @@ toHorizon phylo =
$ concat
$ tracePhyloAncestors newGroups) phylo
reBranched = fromList $ map (\g -> (getGroupId g, g)) $ concat
$ groupsToBranches' $ fromList $ map (\g -> (getGroupId g, g)) $ getGroupsFromScale scale phyloAncestor
$ groupsToBranches' $ fromList $ map (\g -> (getGroupId g, g)) $ getGroupsFromLevel scale phyloAncestor
in updatePhyloGroups scale reBranched phylo
where
-- | 1) for each periods
......@@ -637,7 +636,7 @@ toHorizon phylo =
-- | 2) find ancestors between groups without parents
mapGroups :: [[PhyloGroup]]
mapGroups = map (\prd ->
let groups = getGroupsFromScalePeriods scale [prd] phylo
let groups = getGroupsFromLevelPeriods scale [prd] phylo
childs = getPreviousChildIds scale frame prd periods phylo
-- maybe add a better filter for non isolated ancestors
heads = filter (\g -> (not . null) $ (g ^. phylo_groupPeriodChilds))
......@@ -661,7 +660,7 @@ toHorizon phylo =
getPreviousChildIds :: Scale -> Int -> Period -> [Period] -> Phylo -> [PhyloGroupId]
getPreviousChildIds lvl frame curr prds phylo =
concat $ map ((map fst) . _phylo_groupPeriodChilds)
$ getGroupsFromScalePeriods lvl (getNextPeriods ToParents frame curr prds) phylo
$ getGroupsFromLevelPeriods lvl (getNextPeriods ToParents frame curr prds) phylo
---------------------
-- | phyloExport | --
......@@ -696,10 +695,10 @@ toPhyloExport phylo = exportToDot phylo
--------------------------------------
groups :: [PhyloGroup]
groups = traceExportGroups
-- necessaire ?
$ processDynamics
$ getGroupsFromScale (phyloScale $ getConfig phylo)
$ getGroupsFromLevel (phyloScale $ getConfig phylo)
$ tracePhyloInfo phylo
-- \$ toHorizon phylo
traceExportBranches :: [PhyloBranch] -> [PhyloBranch]
......@@ -722,3 +721,4 @@ traceExportGroups groups = trace ("\n" <> "-- | Export "
<> show(length groups) <> " groups and "
<> show(length $ nub $ concat $ map (\g -> g ^. phylo_groupNgrams) groups) <> " terms"
) groups
src/Gargantext/Core/Viz/Phylo/PhyloMaker.hs
View file @ 66f96f84
This diff is collapsed.
src/Gargantext/Core/Viz/Phylo/PhyloTools.hs
View file @ 66f96f84
......@@ -14,7 +14,7 @@ module Gargantext.Core.Viz.Phylo.PhyloTools where
import Control.Lens hiding (Level)
import Data.List (sort, concat, null, union, (++), tails, sortOn, nub, init, tail, partition, tails, nubBy, group, notElem)
import Data.Map.Strict (Map, elems, fromList, unionWith, keys, member, (!), filterWithKey, fromListWith, empty, restrictKeys)
import Data.Map (Map, elems, fromList, unionWith, keys, member, (!), filterWithKey, fromListWith, empty, restrictKeys)
import Data.Set (Set, disjoint)
import Data.String (String)
import Data.Text (Text,unpack)
......@@ -25,6 +25,7 @@ import Gargantext.Prelude
import Prelude (floor,read)
import Text.Printf
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Vector as Vector
......@@ -139,7 +140,6 @@ periodsToYears periods = (Set.fromList . sort . concat)
findBounds :: [Date] -> (Date,Date)
findBounds [] = panic "[G.C.V.P.PhyloTools] empty dates for find bounds"
findBounds dates =
let dates' = sort dates
in (head' "findBounds" dates', last' "findBounds" dates')
......@@ -387,10 +387,10 @@ getLevelParentId :: PhyloGroup -> PhyloGroupId
getLevelParentId g = fst $ head' "getLevelParentId" $ g ^. phylo_groupScaleParents
getLastLevel :: Phylo -> Scale
getLastLevel phylo = last' "lastLevel" $ getScales phylo
getLastLevel phylo = last' "lastLevel" $ getLevels phylo
getScales :: Phylo -> [Scale]
getScales phylo = nub
getLevels :: Phylo -> [Scale]
getLevels phylo = nub
$ map snd
$ keys $ view ( phylo_periods
. traverse
......@@ -408,7 +408,7 @@ getPhyloSeaRiseStart phylo = case (getSeaElevation phylo) of
getPhyloSeaRiseSteps :: Phylo -> Double
getPhyloSeaRiseSteps phylo = case (getSeaElevation phylo) of
Constante _ s -> s
Adaptative s -> s
Adaptative s -> s
getConfig :: Phylo -> PhyloConfig
......@@ -431,16 +431,14 @@ getRoots phylo = (phylo ^. phylo_foundations) ^. foundations_roots
getSources :: Phylo -> Vector Text
getSources phylo = _sources (phylo ^. phylo_sources)
-- get the groups distributed by branches at the last scale
phyloLastScale :: Phylo -> [[PhyloGroup]]
phyloLastScale phylo = elems
phyloToLastBranches :: Phylo -> [[PhyloGroup]]
phyloToLastBranches phylo = elems
$ fromListWith (++)
$ map (\g -> (g ^. phylo_groupBranchId, [g]))
$ getGroupsFromScale (last' "byBranches" $ getScales phylo) phylo
$ getGroupsFromLevel (last' "byBranches" $ getLevels phylo) phylo
getGroupsFromScale :: Scale -> Phylo -> [PhyloGroup]
getGroupsFromScale lvl phylo =
getGroupsFromLevel :: Scale -> Phylo -> [PhyloGroup]
getGroupsFromLevel lvl phylo =
elems $ view ( phylo_periods
. traverse
. phylo_periodScales
......@@ -449,8 +447,8 @@ getGroupsFromScale lvl phylo =
. phylo_scaleGroups ) phylo
getGroupsFromScalePeriods :: Scale -> [Period] -> Phylo -> [PhyloGroup]
getGroupsFromScalePeriods lvl periods phylo =
getGroupsFromLevelPeriods :: Scale -> [Period] -> Phylo -> [PhyloGroup]
getGroupsFromLevelPeriods lvl periods phylo =
elems $ view ( phylo_periods
. traverse
. filtered (\phyloPrd -> elem (phyloPrd ^. phylo_periodPeriod) periods)
......@@ -496,14 +494,14 @@ updatePeriods periods' phylo =
) phylo
updateQuality :: Double -> Phylo -> Phylo
updateQuality quality phylo = phylo { _phylo_quality = quality }
updateQuality quality phylo = phylo { _phylo_quality = quality }
traceToPhylo :: Scale -> Phylo -> Phylo
traceToPhylo lvl phylo =
trace ("\n" <> "-- | End of phylo making at level " <> show (lvl) <> " with "
<> show (length $ getGroupsFromScale lvl phylo) <> " groups and "
<> show (length $ nub $ map _phylo_groupBranchId $ getGroupsFromScale lvl phylo) <> " branches" <> "\n") phylo
<> show (length $ getGroupsFromLevel lvl phylo) <> " groups and "
<> show (length $ nub $ map _phylo_groupBranchId $ getGroupsFromLevel lvl phylo) <> " branches" <> "\n") phylo
--------------------
-- | Clustering | --
......@@ -566,15 +564,15 @@ toRelatedComponents nodes edges =
traceSynchronyEnd :: Phylo -> Phylo
traceSynchronyEnd phylo =
trace ( "-- | End synchronic clustering at level " <> show (getLastLevel phylo)
<> " with " <> show (length $ getGroupsFromScale (getLastLevel phylo) phylo) <> " groups"
<> " and " <> show (length $ nub $ map _phylo_groupBranchId $ getGroupsFromScale (getLastLevel phylo) phylo) <> " branches"
<> " with " <> show (length $ getGroupsFromLevel (getLastLevel phylo) phylo) <> " groups"
<> " and " <> show (length $ nub $ map _phylo_groupBranchId $ getGroupsFromLevel (getLastLevel phylo) phylo) <> " branches"
<> "\n" ) phylo
traceSynchronyStart :: Phylo -> Phylo
traceSynchronyStart phylo =
trace ( "\n" <> "-- | Start synchronic clustering at level " <> show (getLastLevel phylo)
<> " with " <> show (length $ getGroupsFromScale (getLastLevel phylo) phylo) <> " groups"
<> " and " <> show (length $ nub $ map _phylo_groupBranchId $ getGroupsFromScale (getLastLevel phylo) phylo) <> " branches"
<> " with " <> show (length $ getGroupsFromLevel (getLastLevel phylo) phylo) <> " groups"
<> " and " <> show (length $ nub $ map _phylo_groupBranchId $ getGroupsFromLevel (getLastLevel phylo) phylo) <> " branches"
<> "\n" ) phylo
......@@ -592,7 +590,7 @@ getMinSharedNgrams :: Proximity -> Int
getMinSharedNgrams proxi = case proxi of
WeightedLogJaccard _ m -> m
WeightedLogSim _ m -> m
Hamming _ _ -> undefined
Hamming _ _ -> undefined
----------------
-- | Branch | --
......@@ -661,6 +659,6 @@ traceTemporalMatching groups =
trace ( "\n" <> "-- | Start temporal matching for " <> show(length groups) <> " groups" <> "\n") groups
traceGroupsProxi :: [Double] -> [Double]
traceGroupsProxi l =
trace ( "\n" <> "-- | " <> show(List.length l) <> " computed pairs of groups proximity" <> "\n") l
traceGroupsProxi :: Map (PhyloGroupId,PhyloGroupId) Double -> Map (PhyloGroupId,PhyloGroupId) Double
traceGroupsProxi m =
trace ( "\n" <> "-- | " <> show(Map.size m) <> " computed pairs of groups proximity" <> "\n") m
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment