Commit 8b029638 authored by Alexandre Delanoë's avatar Alexandre Delanoë

[REFACT] WIP compiling, needs setGroupedTreeWith specific scores.

parent 226db2c5
This diff is collapsed.
......@@ -22,7 +22,7 @@ import Control.Lens (set, view)
import Data.Set (Set)
import Data.Map (Map)
import Data.Maybe (fromMaybe)
import Data.Monoid (mempty)
import Data.Monoid (Monoid, mempty)
import Data.Text (Text)
import Gargantext.Core.Types (ListType(..))
import Gargantext.Database.Admin.Types.Node (NodeId)
......@@ -37,44 +37,26 @@ import qualified Data.List as List
------------------------------------------------------------------------
-- | TODO add group with stemming
class ToGroupedTree a b | a -> b where
toGroupedTree :: GroupParams
-> FlowCont Text FlowListScores
-> a
-> FlowCont Text (GroupedTreeScores b)
instance ToGroupedTree (Map Text (Set NodeId)) (Set NodeId)
where
toGroupedTree :: GroupParams
toGroupedTree :: (Ord a, Monoid a, GroupWithStem a)
=> GroupParams
-> FlowCont Text FlowListScores
-> Map Text (Set NodeId)
-> Map Text a
-- -> Map Text (GroupedTreeScores (Set NodeId))
-> FlowCont Text (GroupedTreeScores (Set NodeId))
toGroupedTree groupParams flc scores = {-view flc_scores-} flow2
-> FlowCont Text (GroupedTreeScores a)
toGroupedTree groupParams flc scores = {-view flc_scores-} flow2
where
flow1 = groupWithScores' flc scoring
scoring t = fromMaybe Set.empty $ Map.lookup t scores
scoring t = fromMaybe mempty $ Map.lookup t scores
flow2 = case (view flc_cont flow1) == Map.empty of
True -> flow1
False -> groupWithStem' groupParams flow1
instance ToGroupedTree (Map Text Double) Double
where
toGroupedTree :: GroupParams
-> FlowCont Text FlowListScores
-> Map Text Double
-- -> Map Text (GroupedTreeScores (Set NodeId))
-> FlowCont Text (GroupedTreeScores Double)
toGroupedTree groupParams flc scores = {-view flc_scores-} flow2
where
flow1 = groupWithScores' flc scoring
scoring t = fromMaybe mempty $ Map.lookup t scores
setScoresWith :: Map Text a
-> Map Text (GroupedTreeScores b)
-> Map Text (GroupedTreeScores a)
setScoresWith = undefined
flow2 = case (view flc_cont flow1) == Map.empty of
True -> flow1
False -> groupWithStem' groupParams flow1
------------------------------------------------------------------------
------------------------------------------------------------------------
......
......@@ -16,7 +16,7 @@ Portability : POSIX
module Gargantext.Core.Text.List.Group.Prelude
where
import Control.Lens (makeLenses, view, set)
import Control.Lens (makeLenses, view, set, over)
import Data.Monoid
import Data.Semigroup
import Data.Set (Set)
......@@ -25,6 +25,7 @@ import Data.Maybe (fromMaybe)
import Data.Map (Map)
import Gargantext.Core.Types (ListType(..))
import Gargantext.Database.Admin.Types.Node (NodeId)
import Gargantext.Core.Text.Metrics (scored', Scored(..), scored_speExc, scored_genInc, normalizeGlobal, normalizeLocal)
import Gargantext.API.Ngrams.Types (NgramsElement, mkNgramsElement, NgramsTerm(..), RootParent(..), mSetFromList)
import Gargantext.Prelude
import qualified Data.Set as Set
......@@ -41,7 +42,7 @@ data GroupedTreeScores score =
, _gts'_score :: !score
} deriving (Show, Ord, Eq)
instance (Semigroup a, Ord a) => Semigroup (GroupedTreeScores a) where
instance (Semigroup a) => Semigroup (GroupedTreeScores a) where
(<>) (GroupedTreeScores l1 s1 c1)
(GroupedTreeScores l2 s2 c2)
= GroupedTreeScores (l1 <> l2)
......@@ -62,12 +63,14 @@ class ViewListType a where
class SetListType a where
setListType :: Maybe ListType -> a -> a
------
class Ord b => ViewScore a b | a -> b where
viewScore :: a -> b
class ViewScores a b | a -> b where
viewScores :: a -> b
--------
class ToNgramsElement a where
toNgramsElement :: a -> [NgramsElement]
......@@ -80,12 +83,24 @@ instance ViewListType (GroupedTreeScores a) where
viewListType = view gts'_listType
instance SetListType (GroupedTreeScores a) where
setListType = set gts'_listType
setListType lt g = over gts'_children (setListType lt)
$ set gts'_listType lt g
instance SetListType (Map Text (GroupedTreeScores a)) where
setListType lt = Map.map (set gts'_listType lt)
------
instance ViewScore (GroupedTreeScores Double) Double where
viewScore = viewScores
instance ViewScores (GroupedTreeScores Double) Double where
viewScores g = sum $ parent : children
where
parent = view gts'_score g
children = map viewScores $ Map.elems $ view gts'_children g
instance ViewScore (GroupedTreeScores (Set NodeId)) Int where
viewScore = Set.size . viewScores
......@@ -95,6 +110,10 @@ instance ViewScores (GroupedTreeScores (Set NodeId)) (Set NodeId) where
parent = view gts'_score g
children = map viewScores $ Map.elems $ view gts'_children g
instance ViewScore (GroupedTreeScores (Scored Text)) Double where
viewScore = view (gts'_score . scored_genInc)
------
instance HasTerms (Map Text (GroupedTreeScores a)) where
hasTerms = Set.unions . (map hasTerms) . Map.toList
......@@ -112,6 +131,7 @@ instance HasTerms (Text, GroupedTreeScores a) where
instance ToNgramsElement (Map Text (GroupedTreeScores a)) where
toNgramsElement = List.concat . (map toNgramsElement) . Map.toList
instance ToNgramsElement (Text, GroupedTreeScores a) where
toNgramsElement (t, gts) = parent : children
where
......
......@@ -11,13 +11,14 @@ Mainly reexport functions in @Data.Text.Metrics@
-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Core.Text.Metrics
where
--import Data.Array.Accelerate ((:.)(..), Z(..))
--import Math.KMeans (kmeans, euclidSq, elements)
import Control.Lens (makeLenses)
import Data.Map (Map)
import Gargantext.Prelude
import Gargantext.Core.Methods.Distances.Accelerate.SpeGen
......@@ -46,7 +47,7 @@ data Scored ts = Scored
{ _scored_terms :: !ts
, _scored_genInc :: !GenericityInclusion
, _scored_speExc :: !SpecificityExclusion
} deriving (Show)
} deriving (Show, Eq, Ord)
localMetrics' :: Ord t => Map (t,t) Int -> Map t (Vec.Vector Double)
......@@ -96,5 +97,5 @@ normalizeLocal (Scored t s1 s2) = Scored t (log' 5 s1) (log' 2 s2)
-- | Type Instances
makeLenses 'Scored
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