Skip to content

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

[FEA] Graph options with Links Strength

parent 2e46942f
Hide whitespace changes
Inline Side-by-side
Showing with 72 additions and 43 deletions
gargantext.cabal
View file @ 942c1cd0
......@@ -5,7 +5,7 @@ cabal-version: 1.12
-- see: https://github.com/sol/hpack
name: gargantext
version: 0.0.5.9.2
version: 0.0.5.9.2
synopsis: Search, map, share
description: Please see README.md
category: Data
......
src/Gargantext/API/Node/Update.hs
View file @ 942c1cd0
......@@ -28,6 +28,7 @@ import Gargantext.API.Ngrams.List (reIndexWith)
import Gargantext.API.Prelude (GargServer, simuLogs)
import Gargantext.Core.Methods.Distances (GraphMetric(..))
import Gargantext.Core.Types.Main (ListType(..))
import Gargantext.Core.Viz.Graph (Strength)
import Gargantext.Core.Viz.Graph.API (recomputeGraph)
import Gargantext.Core.Viz.Graph.Tools (PartitionMethod(..))
import Gargantext.Core.Viz.Phylo (PhyloSubConfig(..), subConfig2config)
......@@ -59,8 +60,9 @@ type API = Summary " Update node according to NodeType params"
------------------------------------------------------------------------
data UpdateNodeParams = UpdateNodeParamsList { methodList :: !Method }
| UpdateNodeParamsGraph { methodGraphMetric :: !GraphMetric
, methodGraphClustering :: !PartitionMethod
| UpdateNodeParamsGraph { methodGraphMetric :: !GraphMetric
, methodGraphClustering :: !PartitionMethod
, methodGraphEdgesStrength :: !Strength
}
| UpdateNodeParamsTexts { methodTexts :: !Granularity }
......@@ -103,7 +105,7 @@ updateNode :: (HasSettings env, FlowCmdM env err m)
-> UpdateNodeParams
-> (JobLog -> m ())
-> m JobLog
updateNode uId nId (UpdateNodeParamsGraph metric method) logStatus = do
updateNode uId nId (UpdateNodeParamsGraph metric method strength) logStatus = do
logStatus JobLog { _scst_succeeded = Just 1
, _scst_failed = Just 0
......@@ -111,7 +113,7 @@ updateNode uId nId (UpdateNodeParamsGraph metric method) logStatus = do
, _scst_events = Just []
}
printDebug "Computing graph: " method
_ <- recomputeGraph uId nId method (Just metric) True
_ <- recomputeGraph uId nId method (Just metric) (Just strength) True
printDebug "Graph computed: " method
pure JobLog { _scst_succeeded = Just 2
......@@ -272,7 +274,7 @@ instance ToSchema UpdateNodeParams
instance Arbitrary UpdateNodeParams where
arbitrary = do
l <- UpdateNodeParamsList <$> arbitrary
g <- UpdateNodeParamsGraph <$> arbitrary <*> arbitrary
g <- UpdateNodeParamsGraph <$> arbitrary <*> arbitrary <*> arbitrary
t <- UpdateNodeParamsTexts <$> arbitrary
b <- UpdateNodeParamsBoard <$> arbitrary
elements [l,g,t,b]
......
src/Gargantext/Core/Viz/Graph.hs
View file @ 942c1cd0
......@@ -76,7 +76,8 @@ instance ToSchema Edge where
data LegendField = LegendField { _lf_id :: Int
, _lf_color :: Text
, _lf_label :: Text
} deriving (Show, Generic)
}
deriving (Show, Generic)
$(deriveJSON (unPrefix "_lf_") ''LegendField)
instance ToSchema LegendField where
......@@ -96,10 +97,22 @@ instance ToSchema ListForGraph where
makeLenses ''ListForGraph
--
data Strength = Strong | Weak
deriving (Generic, Eq, Ord, Enum, Bounded, Show)
$(deriveJSON (unPrefix "") ''Strength)
instance ToSchema Strength where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "")
instance Arbitrary Strength where
arbitrary = elements $ [Strong, Weak]
data GraphMetadata =
GraphMetadata { _gm_title :: Text -- title of the graph
, _gm_metric :: GraphMetric
, _gm_edgesStrength :: Maybe Strength
, _gm_corpusId :: [NodeId] -- we can map with different corpus
, _gm_legend :: [LegendField] -- legend of the Graph
, _gm_list :: ListForGraph
......@@ -113,6 +126,7 @@ instance ToSchema GraphMetadata where
makeLenses ''GraphMetadata
data Graph = Graph { _graph_nodes :: [Node]
, _graph_edges :: [Edge]
, _graph_metadata :: Maybe GraphMetadata
......
src/Gargantext/Core/Viz/Graph/API.hs
View file @ 942c1cd0
......@@ -104,8 +104,9 @@ getGraph _uId nId = do
Nothing -> do
let defaultMetric = Order1
let defaultPartitionMethod = Spinglass
graph' <- computeGraph cId defaultPartitionMethod (withMetric defaultMetric) NgramsTerms repo
mt <- defaultGraphMetadata cId "Title" repo defaultMetric
let defaultEdgesStrength = Strong
graph' <- computeGraph cId defaultPartitionMethod (withMetric defaultMetric) defaultEdgesStrength NgramsTerms repo
mt <- defaultGraphMetadata cId "Title" repo defaultMetric defaultEdgesStrength
let
graph'' = set graph_metadata (Just mt) graph'
hg = HyperdataGraphAPI graph'' camera
......@@ -123,9 +124,10 @@ recomputeGraph :: FlowCmdM env err m
-> NodeId
-> PartitionMethod
-> Maybe GraphMetric
-> Maybe Strength
-> Bool
-> m Graph
recomputeGraph _uId nId method maybeDistance force = do
recomputeGraph _uId nId method maybeDistance maybeStrength force = do
printDebug "recomputeGraph begins" (nId, method)
nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
let
......@@ -140,6 +142,12 @@ recomputeGraph _uId nId method maybeDistance force = do
Nothing -> withMetric Order1
Just m -> withMetric m
strength = case maybeStrength of
Nothing -> case graph ^? _Just . graph_metadata . _Just . gm_edgesStrength of
Nothing -> Strong
Just mr -> fromMaybe Strong mr
Just r -> r
mcId <- getClosestParentIdByType nId NodeCorpus
let cId = maybe (panic "[G.V.G.API] Node has no parent") identity mcId
printDebug "recomputeGraph corpus" cId
......@@ -152,7 +160,7 @@ recomputeGraph _uId nId method maybeDistance force = do
let computeG mt = do
printDebug "about to run computeGraph" ()
g <- computeGraph cId method similarity NgramsTerms repo
g <- computeGraph cId method similarity strength NgramsTerms repo
seq g $ printDebug "graph computed" ()
let g' = set graph_metadata mt g
seq g' $ printDebug "computed graph with new metadata" ()
......@@ -162,7 +170,7 @@ recomputeGraph _uId nId method maybeDistance force = do
case graph of
Nothing -> do
mt <- defaultGraphMetadata cId "Title" repo (fromMaybe Order1 maybeDistance)
mt <- defaultGraphMetadata cId "Title" repo (fromMaybe Order1 maybeDistance) strength
g <- computeG $ Just mt
pure $ trace "[G.V.G.API.recomputeGraph] Graph empty, computed" g
Just graph' -> if (listVersion == Just v) && (not force)
......@@ -176,10 +184,11 @@ computeGraph :: FlowCmdM env err m
=> CorpusId
-> PartitionMethod
-> Distance
-> Strength
-> NgramsType
-> NodeListStory
-> m Graph
computeGraph cId method d nt repo = do
computeGraph cId method d strength nt repo = do
printDebug "computeGraph" (cId, method, nt)
lId <- defaultList cId
printDebug "computeGraph got list id: " lId
......@@ -194,7 +203,7 @@ computeGraph cId method d nt repo = do
<$> getContextsByNgramsOnlyUser cId (lIds <> [lId]) nt (HashMap.keys ngs)
printDebug "computeGraph got coocs" (HashMap.size myCooc)
graph <- liftBase $ cooc2graphWith method d 0 myCooc
graph <- liftBase $ cooc2graphWith method d 0 strength myCooc
printDebug "computeGraph got graph" ()
--listNgrams <- getListNgrams [lId] nt
......@@ -209,23 +218,24 @@ defaultGraphMetadata :: HasNodeError err
-> Text
-> NodeListStory
-> GraphMetric
-> Strength
-> Cmd err GraphMetadata
defaultGraphMetadata cId t repo gm = do
defaultGraphMetadata cId t repo gm str = do
lId <- defaultList cId
pure $ GraphMetadata {
_gm_title = t
, _gm_metric = gm
, _gm_corpusId = [cId]
, _gm_legend = [
LegendField 1 "#FFF" "Cluster1"
, LegendField 2 "#FFF" "Cluster2"
, LegendField 3 "#FFF" "Cluster3"
, LegendField 4 "#FFF" "Cluster4"
]
, _gm_list = (ListForGraph lId (repo ^. unNodeStory . at lId . _Just . a_version))
, _gm_startForceAtlas = True
}
pure $ GraphMetadata { _gm_title = t
, _gm_metric = gm
, _gm_edgesStrength = Just str
, _gm_corpusId = [cId]
, _gm_legend = [
LegendField 1 "#FFF" "Cluster1"
, LegendField 2 "#FFF" "Cluster2"
, LegendField 3 "#FFF" "Cluster3"
, LegendField 4 "#FFF" "Cluster4"
]
, _gm_list = (ListForGraph lId (repo ^. unNodeStory . at lId . _Just . a_version))
, _gm_startForceAtlas = True
}
-- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
------------------------------------------------------------
......@@ -255,7 +265,7 @@ graphRecompute u n logStatus = do
, _scst_remaining = Just 1
, _scst_events = Just []
}
_g <- trace (show u) $ recomputeGraph u n Spinglass Nothing False
_g <- trace (show u) $ recomputeGraph u n Spinglass Nothing Nothing False
pure JobLog { _scst_succeeded = Just 1
, _scst_failed = Just 0
, _scst_remaining = Just 0
......@@ -310,7 +320,7 @@ recomputeVersions :: FlowCmdM env err m
=> UserId
-> NodeId
-> m Graph
recomputeVersions uId nId = recomputeGraph uId nId Spinglass Nothing False
recomputeVersions uId nId = recomputeGraph uId nId Spinglass Nothing Nothing False
------------------------------------------------------------
graphClone :: UserId
......
src/Gargantext/Core/Viz/Graph/Tools.hs
View file @ 942c1cd0
......@@ -92,6 +92,7 @@ cooc2graph' distance threshold myCooc
cooc2graphWith :: PartitionMethod
-> Distance
-> Threshold
-> Strength
-> HashMap (NgramsTerm, NgramsTerm) Int
-> IO Graph
cooc2graphWith Spinglass = cooc2graphWith' (spinglass 1)
......@@ -104,10 +105,11 @@ cooc2graphWith' :: ToComId a
=> Partitions a
-> Distance
-> Threshold
-> Strength
-> HashMap (NgramsTerm, NgramsTerm) Int
-> IO Graph
cooc2graphWith' doPartitions distance threshold myCooc = do
let (distanceMap, diag, ti) = doDistanceMap distance threshold myCooc
cooc2graphWith' doPartitions distance threshold strength myCooc = do
let (distanceMap, diag, ti) = doDistanceMap distance threshold strength myCooc
distanceMap `seq` trace "distanceMap OK" diag `seq` trace "diag OK" ti `seq` printDebug "ti done" ()
--{- -- Debug
......@@ -136,17 +138,20 @@ cooc2graphWith' doPartitions distance threshold myCooc = do
--seq confluence' $ printDebug "confluence OK" ()
--saveAsFileDebug "/tmp/confluence" confluence'
let g = data2graph ti diag bridgeness' confluence' partitions
saveAsFileDebug "/tmp/graph" g
--saveAsFileDebug "/tmp/graph" g
pure g
type Reverse = Bool
doDistanceMap :: Distance
-> Threshold
-> Strength
-> HashMap (NgramsTerm, NgramsTerm) Int
-> ( Map (Int,Int) Double
, Map (Index, Index) Int
, Map NgramsTerm Index
)
doDistanceMap Distributional threshold myCooc = (distanceMap, toIndex ti diag, ti)
doDistanceMap Distributional threshold strength myCooc = (distanceMap, toIndex ti diag, ti)
where
-- TODO remove below
(diag, theMatrix) = Map.partitionWithKey (\(x,y) _ -> x == y)
......@@ -165,14 +170,14 @@ doDistanceMap Distributional threshold myCooc = (distanceMap, toIndex ti diag, t
distanceMap = Map.fromList . trace "fromList" identity
$ List.take links
$ List.reverse
$ (if strength == Weak then List.reverse else identity)
$ List.sortOn snd
$ Map.toList
$ edgesFilter
$ (\m -> m `seq` trace "map2map done" (Map.filter (> threshold) m))
$ similarities `seq` mat2map (trace "similarities done" similarities)
doDistanceMap Conditional threshold myCooc = (distanceMap, toIndex ti myCooc', ti)
doDistanceMap Conditional threshold strength myCooc = (distanceMap, toIndex ti myCooc', ti)
where
myCooc' = Map.fromList $ HashMap.toList myCooc
(ti, _it) = createIndices myCooc'
......@@ -182,7 +187,7 @@ doDistanceMap Conditional threshold myCooc = (distanceMap, toIndex ti myCooc', t
distanceMap = toIndex ti
$ Map.fromList
$ List.take links
$ List.reverse
$ (if strength == Weak then List.reverse else identity)
$ List.sortOn snd
$ HashMap.toList
$ HashMap.filter (> threshold)
......@@ -332,11 +337,11 @@ filterByNeighbours threshold distanceMap = filteredMap
indexes = List.nub $ List.concat $ map (\(idx,idx') -> [idx,idx'] ) $ Map.keys distanceMap
filteredMap :: Map (Index, Index) Double
filteredMap = Map.fromList
$ List.concat
$ map (\idx ->
$ List.concat
$ map (\idx ->
let selected = List.reverse
$ List.sortOn snd
$ Map.toList
$ Map.toList
$ Map.filter (> 0)
$ Map.filterWithKey (\(from,_) _ -> idx == from) distanceMap
in List.take (round threshold) selected
......@@ -344,5 +349,3 @@ filterByNeighbours threshold distanceMap = filteredMap
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