Skip to content

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

[CLEAN] removing previous code (WIP)

parent 8b029638
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 55 additions and 507 deletions
src/Gargantext/Core/Text/List.hs
View file @ ece7883b
This diff is collapsed.
src/Gargantext/Core/Text/List/Group.hs
View file @ ece7883b
......@@ -18,7 +18,7 @@ Portability : POSIX
module Gargantext.Core.Text.List.Group
where
import Control.Lens (set, view)
import Control.Lens (set, view, over)
import Data.Set (Set)
import Data.Map (Map)
import Data.Maybe (fromMaybe)
......@@ -52,30 +52,24 @@ toGroupedTree groupParams flc scores = {-view flc_scores-} flow2
True -> 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)
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 @ ece7883b
......@@ -32,6 +32,7 @@ import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.List as List
type Stem = Text
------------------------------------------------------------------------
-- | Main Types to group With Scores but preserving Tree dependencies
-- Therefore there is a need of Tree of GroupedTextScores
......@@ -162,108 +163,3 @@ instance ToNgramsElement (Text, GroupedTreeScores a) where
$ 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 @ ece7883b
......@@ -98,76 +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 @ ece7883b
......@@ -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 @ ece7883b
......@@ -98,84 +98,3 @@ flowSocialList' flowPriority user 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 @ ece7883b
......@@ -110,36 +110,3 @@ hasParent t m = case Map.lookup t m of
keyWithMaxValue :: Map a b -> Maybe a
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