Skip to content

haskell-gargantext
haskell-gargantext
Commit 4ea0d7f8 authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

[CLEAN] removing previous code (WIP)

parent 480f7bb9
Pipeline #1248 canceled with stage
    Expand all Show whitespace changes
    Inline Side-by-side
    Showing with 55 additions and 509 deletions
    src/Gargantext/Core/Text/List.hs
    View file @ 4ea0d7f8
    This diff is collapsed.
    src/Gargantext/Core/Text/List/Group.hs
    View file @ 4ea0d7f8
    ...@@ -18,7 +18,7 @@ Portability : POSIX ...@@ -18,7 +18,7 @@ Portability : POSIX
    module Gargantext.Core.Text.List.Group module Gargantext.Core.Text.List.Group
    where where
    import Control.Lens (set, view) import Control.Lens (set, view, over)
    import Data.Set (Set) import Data.Set (Set)
    import Data.Map (Map) import Data.Map (Map)
    import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
    ...@@ -52,30 +52,24 @@ toGroupedTree groupParams flc scores = {-view flc_scores-} flow2 ...@@ -52,30 +52,24 @@ toGroupedTree groupParams flc scores = {-view flc_scores-} flow2
    True -> flow1 True -> flow1
    False -> groupWithStem' groupParams flow1 False -> groupWithStem' groupParams flow1
    setScoresWith :: Map Text a {-
    -> Map Text (GroupedTreeScores b) DM.foldlWithKey :: (a -> k -> b -> a) -> a -> Map k b -> a
    -}
    setScoresWith :: (Ord a, Ord b)
    => (Text -> (GroupedTreeScores a) -> (GroupedTreeScores b))
    -> Map Text (GroupedTreeScores a) -> Map Text (GroupedTreeScores a)
    setScoresWith = undefined -> Map Text (GroupedTreeScores b)
    setScoresWith = Map.mapWithKey
    {-
    Map.foldlWithKey (\k v ->
    {- over gts'_children (setScoresWith fun)
    $ over gts'_score (fun k)
    -}
    set gts'_score Set.empty -- (fun k)
    v
    ) mempty m
    -}
    ------------------------------------------------------------------------ ------------------------------------------------------------------------
    ------------------------------------------------------------------------
    -- 8<-- 8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--
    -- | TODO To be removed
    toGroupedText :: GroupedTextParams a b
    -> Map Text FlowListScores
    -> Map Text (Set NodeId)
    -> Map Stem (GroupedText Int)
    toGroupedText groupParams scores =
    (groupWithStem groupParams) . (groupWithScores scores)
    addListType :: Map Text ListType -> GroupedText a -> GroupedText a
    addListType m g = set gt_listType (hasListType m g) g
    where
    hasListType :: Map Text ListType -> GroupedText a -> Maybe ListType
    hasListType m' (GroupedText _ label _ g' _ _ _) =
    List.foldl' (<>) Nothing
    $ map (\t -> Map.lookup t m')
    $ Set.toList
    $ Set.insert label g'
    src/Gargantext/Core/Text/List/Group/Prelude.hs
    View file @ 4ea0d7f8
    ...@@ -32,6 +32,7 @@ import qualified Data.Set as Set ...@@ -32,6 +32,7 @@ import qualified Data.Set as Set
    import qualified Data.Map as Map import qualified Data.Map as Map
    import qualified Data.List as List import qualified Data.List as List
    type Stem = Text
    ------------------------------------------------------------------------ ------------------------------------------------------------------------
    -- | Main Types to group With Scores but preserving Tree dependencies -- | Main Types to group With Scores but preserving Tree dependencies
    -- Therefore there is a need of Tree of GroupedTextScores -- Therefore there is a need of Tree of GroupedTextScores
    ...@@ -162,108 +163,3 @@ instance ToNgramsElement (Text, GroupedTreeScores a) where ...@@ -162,108 +163,3 @@ instance ToNgramsElement (Text, GroupedTreeScores a) where
    $ view gts'_children gts' $ view gts'_children gts'
    -- 8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--
    -- TODO to remove below
    data GroupedWithListScores =
    GroupedWithListScores { _gwls_listType :: !(Maybe ListType)
    , _gwls_children :: !(Set Text)
    } deriving (Show)
    instance Semigroup GroupedWithListScores where
    (<>) (GroupedWithListScores c1 l1)
    (GroupedWithListScores c2 l2) =
    GroupedWithListScores (c1 <> c2)
    (l1 <> l2)
    instance Monoid GroupedWithListScores where
    mempty = GroupedWithListScores Nothing Set.empty
    makeLenses ''GroupedWithListScores
    ------------------------------------------------------------------------
    ------------------------------------------------------------------------
    -- | Group With Stem Main Types
    type Stem = Text
    data GroupedText score =
    GroupedText { _gt_listType :: !(Maybe ListType)
    , _gt_label :: !Text
    , _gt_score :: !score
    , _gt_children :: !(Set Text)
    , _gt_size :: !Int
    , _gt_stem :: !Stem -- needed ?
    , _gt_nodes :: !(Set NodeId)
    } deriving (Show, Eq) --}
    -- | Lenses Instances
    makeLenses 'GroupedText
    instance ViewListType (GroupedText a) where
    viewListType = view gt_listType
    instance SetListType (GroupedText a) where
    setListType = set gt_listType
    instance Ord a => ViewScore (GroupedText a) a where
    viewScore = (view gt_score)
    {-
    instance Show score => Show (GroupedText score) where
    show (GroupedText lt l s _ _ _ _) = show l <> " : " <> show lt <> " : " <> show s
    --}
    {-
    instance (Eq a) => Eq (GroupedText a) where
    (==) (GroupedText _ _ score1 _ _ _ _)
    (GroupedText _ _ score2 _ _ _ _) = (==) score1 score2
    -}
    instance (Eq a, Ord a) => Ord (GroupedText a) where
    compare (GroupedText _ _ score1 _ _ _ _)
    (GroupedText _ _ score2 _ _ _ _) = compare score1 score2
    instance Ord a => Semigroup (GroupedText a) where
    (<>) (GroupedText lt1 label1 score1 group1 s1 stem1 nodes1)
    (GroupedText lt2 label2 score2 group2 s2 stem2 nodes2)
    | score1 >= score2 = GroupedText lt label1 score1 (Set.insert label2 gr) s1 stem1 nodes
    | otherwise = GroupedText lt label2 score2 (Set.insert label1 gr) s2 stem2 nodes
    where
    lt = lt1 <> lt2
    gr = Set.union group1 group2
    nodes = Set.union nodes1 nodes2
    instance SetListType [GroupedText Int] where
    setListType lt = map (setListType lt)
    instance ToNgramsElement (Map Stem (GroupedText Int)) where
    toNgramsElement = List.concat . (map toNgramsElement) . Map.elems
    instance ToNgramsElement [GroupedText a] where
    toNgramsElement = List.concat . (map toNgramsElement)
    instance ToNgramsElement (GroupedText a) where
    toNgramsElement :: GroupedText a -> [NgramsElement]
    toNgramsElement (GroupedText listType label _ setNgrams _ _ _) =
    [parentElem] <> childrenElems
    where
    parent = label
    children = Set.toList setNgrams
    parentElem = mkNgramsElement (NgramsTerm parent)
    (fromMaybe CandidateTerm listType)
    Nothing
    (mSetFromList (NgramsTerm <$> children))
    childrenElems = map (\t -> mkNgramsElement t (fromMaybe CandidateTerm $ listType)
    (Just $ RootParent (NgramsTerm parent) (NgramsTerm parent))
    (mSetFromList [])
    ) (NgramsTerm <$> children)
    -- 8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--
    src/Gargantext/Core/Text/List/Group/WithScores.hs
    View file @ 4ea0d7f8
    ...@@ -98,78 +98,4 @@ toGroupedTree' m notEmpty ...@@ -98,78 +98,4 @@ toGroupedTree' m notEmpty
    --8<-- -8<-- -8<-- -8<-- -8<-- -8<-- -8<-- -8<-- -8<-- -8<-- -8<-- -8<--
    -- TODO TO BE REMOVED
    data GroupedTextScores score =
    GroupedTextScores { _gts_listType :: !(Maybe ListType)
    , _gts_score :: score
    , _gts_children :: !(Set Text)
    } deriving (Show)
    makeLenses 'GroupedTextScores
    instance Semigroup a => Semigroup (GroupedTextScores a) where
    (<>) (GroupedTextScores l1 s1 c1)
    (GroupedTextScores l2 s2 c2)
    = GroupedTextScores (l1 <> l2)
    (s1 <> s2)
    (c1 <> c2)
    -- | Main function
    groupWithScores :: Map Text FlowListScores
    -> Map Text (Set NodeId)
    -> Map Text (GroupedTextScores (Set NodeId))
    groupWithScores scores ms = orphans <> groups
    where
    groups = addScore ms
    $ fromGroupedScores
    $ fromListScores scores
    orphans = addIfNotExist scores ms
    ------------------------------------------------------------------------
    addScore :: Map Text (Set NodeId)
    -> Map Text (GroupedTextScores (Set NodeId))
    -> Map Text (GroupedTextScores (Set NodeId))
    addScore mapNs = Map.mapWithKey scoring
    where
    scoring k g = set gts_score ( Set.unions
    $ catMaybes
    $ map (\n -> Map.lookup n mapNs)
    $ [k] <> (Set.toList $ view gts_children g)
    ) g
    addIfNotExist :: Map Text FlowListScores
    -> Map Text (Set NodeId)
    -> Map Text (GroupedTextScores (Set NodeId))
    addIfNotExist mapSocialScores mapScores =
    foldl' (addIfNotExist' mapSocialScores) mempty $ Map.toList mapScores
    where
    addIfNotExist' mss m (t,ns) =
    case Map.lookup t mss of
    Nothing -> Map.alter (add ns) t m
    _ -> m
    add ns' Nothing = Just $ GroupedTextScores Nothing ns' mempty
    add _ _ = Nothing -- should not be present
    ------------------------------------------------------------------------
    ------------------------------------------------------------------------
    fromGroupedScores :: Map Parent GroupedWithListScores
    -> Map Parent (GroupedTextScores (Set NodeId))
    fromGroupedScores = Map.map (\(GroupedWithListScores l c) -> GroupedTextScores l mempty c)
    ------------------------------------------------------------------------
    fromListScores :: Map Text FlowListScores -> Map Parent GroupedWithListScores
    fromListScores = Map.fromListWith (<>) . (map fromScores') . Map.toList
    where
    fromScores' :: (Text, FlowListScores) -> (Text, GroupedWithListScores)
    fromScores' (t, fs) = case (keyWithMaxValue $ view fls_parents fs) of
    Nothing -> (t, set gwls_listType (keyWithMaxValue $ view fls_listType fs) mempty)
    -- Parent case: taking its listType, for now children Set is empty
    Just parent -> (parent, set gwls_children (Set.singleton t) mempty)
    -- We ignore the ListType of children for the parents' one
    -- added after and winner of semigroup actions
    --8<-- -8<-- -8<-- -8<-- -8<-- -8<-- -8<-- -8<-- -8<-- -8<-- -8<-- -8<--
    src/Gargantext/Core/Text/List/Group/WithStem.hs
    View file @ 4ea0d7f8
    ...@@ -185,65 +185,3 @@ mergeWith_Double fun flc = FlowCont scores mempty ...@@ -185,65 +185,3 @@ mergeWith_Double fun flc = FlowCont scores mempty
    -- 8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--
    -------------------------------------------------------------------
    -- TODO to remove
    data GroupedTextParams a b =
    GroupedTextParams { _gt_fun_stem :: Text -> Text
    , _gt_fun_score :: a -> b
    , _gt_fun_texts :: a -> Set Text
    , _gt_fun_nodeIds :: a -> Set NodeId
    -- , _gt_fun_size :: a -> Int
    }
    makeLenses 'GroupedTextParams
    groupWithStem :: {- ( HasNgrams a
    , HasGroupWithScores a b
    , Semigroup a
    , Ord b
    )
    => -} GroupedTextParams a b
    -> Map Text (GroupedTextScores (Set NodeId))
    -> Map Stem (GroupedText Int)
    groupWithStem _ = Map.mapWithKey scores2groupedText
    scores2groupedText :: Text -> GroupedTextScores (Set NodeId) -> GroupedText Int
    scores2groupedText t g = GroupedText (view gts_listType g)
    t
    (Set.size $ view gts_score g)
    (Set.delete t $ view gts_children g)
    (size t)
    t
    (view gts_score g)
    ------------------------------------------------------------------------
    ------------------------------------------------------------------------
    groupedTextWithStem :: Ord b
    => GroupedTextParams a b
    -> Map Text a
    -> Map Stem (GroupedText b)
    groupedTextWithStem gparams from =
    Map.fromListWith (<>) $ map (group gparams) $ Map.toList from
    where
    group gparams' (t,d) = let t' = (view gt_fun_stem gparams') t
    in (t', GroupedText
    Nothing
    t
    ((view gt_fun_score gparams') d)
    ((view gt_fun_texts gparams') d)
    (size t)
    t'
    ((view gt_fun_nodeIds gparams') d)
    )
    ------------------------------------------------------------------------
    src/Gargantext/Core/Text/List/Social.hs
    View file @ 4ea0d7f8
    ...@@ -98,84 +98,3 @@ flowSocialList' flowPriority user nt flc = ...@@ -98,84 +98,3 @@ flowSocialList' flowPriority user nt flc =
    . toFlowListScores (keepAllParents nt'') flc'' . toFlowListScores (keepAllParents nt'') flc''
    ---8<-TODO-REMOVE ALL BELOW--8<--8<-- 8<-- 8<--8<--8<--
    -- | Choice depends on Ord instance of ListType
    -- for now : data ListType = StopTerm | CandidateTerm | MapTerm
    -- means MapTerm > CandidateTerm > StopTerm in case of equality of counts
    -- (we minimize errors on MapTerms if doubt)
    -- * TODO what if equality ?
    -- * TODO maybe use social groups too
    toSocialList :: Map Text (Map ListType Int)
    -> Set Text
    -> Map (Maybe ListType) (Set Text)
    toSocialList m = Map.fromListWith (<>)
    . Set.toList
    . Set.map (toSocialList1 m)
    toSocialList1 :: Map Text (Map ListType Int)
    -> Text
    -> (Maybe ListType, Set Text)
    toSocialList1 m t = case Map.lookup t m of
    Nothing -> (Nothing, Set.singleton t)
    Just m' -> ( (fst . fst) <$> Map.maxViewWithKey m'
    , Set.singleton t
    )
    toSocialList1_testIsTrue :: Bool
    toSocialList1_testIsTrue = result == (Just MapTerm, Set.singleton token)
    where
    result = toSocialList1 (Map.fromList [(token, m)]) token
    token = "token"
    m = Map.fromList [ (CandidateTerm, 1)
    , (MapTerm , 2)
    , (StopTerm , 3)
    ]
    flowSocialList :: ( RepoCmdM env err m
    , CmdM env err m
    , HasNodeError err
    , HasTreeError err
    )
    => User -> NgramsType -> Set Text
    -> m (Map ListType (Set Text))
    flowSocialList user nt ngrams' = do
    -- Here preference to privateLists (discutable: let user choice)
    privateListIds <- findListsId user Private
    privateLists <- flowSocialListByMode privateListIds nt ngrams'
    -- printDebug "* privateLists *: \n" privateLists
    sharedListIds <- findListsId user Shared
    sharedLists <- flowSocialListByMode sharedListIds nt (termsByList CandidateTerm privateLists)
    -- printDebug "* sharedLists *: \n" sharedLists
    -- TODO publicMapList:
    -- Note: if both produce 3 identic repetition => refactor mode
    -- publicListIds <- findListsId Public user
    -- publicLists <- flowSocialListByMode' publicListIds nt (termsByList CandidateTerm privateLists)
    let result = parentUnionsExcl
    [ Map.mapKeys (fromMaybe CandidateTerm) privateLists
    , Map.mapKeys (fromMaybe CandidateTerm) sharedLists
    -- , Map.mapKeys (fromMaybe CandidateTerm) publicLists
    ]
    -- printDebug "* socialLists *: results \n" result
    pure result
    -- | TODO remove
    flowSocialListByMode :: ( RepoCmdM env err m
    , CmdM env err m
    , HasNodeError err
    , HasTreeError err
    )
    => [NodeId]-> NgramsType -> Set Text
    -> m (Map (Maybe ListType) (Set Text))
    flowSocialListByMode [] _nt ngrams' = pure $ Map.fromList [(Nothing, ngrams')]
    flowSocialListByMode listIds nt ngrams' = do
    counts <- countFilterList ngrams' nt listIds Map.empty
    let r = toSocialList counts ngrams'
    pure r
    src/Gargantext/Core/Text/List/Social/Prelude.hs
    View file @ 4ea0d7f8
    ...@@ -110,36 +110,3 @@ hasParent t m = case Map.lookup t m of ...@@ -110,36 +110,3 @@ hasParent t m = case Map.lookup t m of
    keyWithMaxValue :: Map a b -> Maybe a keyWithMaxValue :: Map a b -> Maybe a
    keyWithMaxValue m = (fst . fst) <$> Map.maxViewWithKey m keyWithMaxValue m = (fst . fst) <$> Map.maxViewWithKey m
    ------------------------------------------------------------------------
    -- | Tools TODO clean it (some need to be removed)
    ------------------------------------------------------------------------
    termsByList :: ListType -> (Map (Maybe ListType) (Set Text)) -> Set Text
    termsByList CandidateTerm m = Set.unions
    $ map (\lt -> fromMaybe Set.empty $ Map.lookup lt m)
    [ Nothing, Just CandidateTerm ]
    termsByList l m =
    fromMaybe Set.empty $ Map.lookup (Just l) m
    ------------------------------------------------------------------------
    unions' :: (Ord a, Semigroup a, Semigroup b, Ord b)
    => [Map a (Set b)] -> Map a (Set b)
    unions' = invertBack . Map.unionsWith (<>) . map invertForw
    invertForw :: (Ord b, Semigroup a) => Map a (Set b) -> Map b a
    invertForw = Map.unionsWith (<>)
    . (map (\(k,st) -> Map.fromSet (\_ -> k) st))
    . Map.toList
    invertBack :: (Ord a, Ord b) => Map b a -> Map a (Set b)
    invertBack = Map.fromListWith (<>)
    . (map (\(b,a) -> (a, Set.singleton b)))
    . Map.toList
    unions_test :: Map ListType (Set Text)
    unions_test = unions' [m1, m2]
    where
    m1 = Map.fromList [ (StopTerm , Set.singleton "Candidate")]
    m2 = Map.fromList [ (CandidateTerm, Set.singleton "Candidate")
    , (MapTerm , Set.singleton "Candidate")
    ]
    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