Sigmax.purs 12.5 KB
Newer Older
James Laver's avatar
James Laver committed
1 2 3
module Gargantext.Hooks.Sigmax
  where

4
import DOM.Simple.Types (Element)
5
import Data.Either (either)
6
import Data.Foldable (sequence_, foldl)
7
import Data.Map as Map
8 9
import Data.Maybe (Maybe(..))
import Data.Nullable (Nullable)
James Laver's avatar
James Laver committed
10
import Data.Sequence (Seq)
11
import Data.Sequence as Seq
12
import Data.Set as Set
13
import Data.Traversable (traverse_)
14
import Data.Tuple (Tuple(..))
James Laver's avatar
James Laver committed
15
import Effect (Effect)
16
import Effect.Timer (TimeoutId, clearTimeout, setTimeout)
17
import Gargantext.Hooks.Sigmax.ForceAtlas2 as ForceAtlas
18
import Gargantext.Hooks.Sigmax.Graphology as Graphology
James Laver's avatar
James Laver committed
19
import Gargantext.Hooks.Sigmax.Sigma as Sigma
20
import Gargantext.Hooks.Sigmax.Types as ST
arturo's avatar
arturo committed
21
import Gargantext.Utils.Console as C
22
import Gargantext.Utils.Reactix as R2
23
import Gargantext.Utils.Seq as GSeq
24
import Gargantext.Utils.Set as GSet
25
import Prelude (Unit, bind, discard, flip, not, pure, unit, ($), (*>), (<<<), (<>), (>>=), (+), (>), negate, (==), (<$>))
arturo's avatar
arturo committed
26 27
import Reactix as R
import Toestand as T
James Laver's avatar
James Laver committed
28 29 30

type Sigma =
  { sigma :: R.Ref (Maybe Sigma.Sigma)
31
    -- TODO is Seq in cleanup really necessary?
James Laver's avatar
James Laver committed
32 33 34
  , cleanup :: R.Ref (Seq (Effect Unit))
  }

35
type Data n e = { graph :: R.Ref (ST.Graph n e) }
James Laver's avatar
James Laver committed
36

arturo's avatar
arturo committed
37 38 39 40 41 42
moduleName :: R2.Module
moduleName = "Gargantext.Hooks.Sigmax"

console :: C.Console
console = C.encloseContext C.Main moduleName

43 44 45 46 47 48
initSigma :: R.Hooks Sigma
initSigma = do
    s <- R2.nothingRef
    c <- R.useRef Seq.empty
    pure { sigma: s, cleanup: c }

James Laver's avatar
James Laver committed
49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74
readSigma :: Sigma -> Maybe Sigma.Sigma
readSigma sigma = R.readRef sigma.sigma

writeSigma :: Sigma -> Maybe Sigma.Sigma -> Effect Unit
writeSigma sigma = R.setRef sigma.sigma

-- | Pushes to the back of the cleanup sequence. Cleanup happens
-- | *before* sigma is destroyed
cleanupLast :: Sigma -> Effect Unit -> Effect Unit
cleanupLast sigma = R.setRef sigma.cleanup <<< Seq.snoc existing
  where existing = R.readRef sigma.cleanup

-- | Pushes to the front of the cleanup sequence. Cleanup happens
-- | *before* sigma is destroyed
cleanupFirst :: Sigma -> Effect Unit -> Effect Unit
cleanupFirst sigma =
  R.setRef sigma.cleanup <<< (flip Seq.cons) (R.readRef sigma.cleanup)

cleanupSigma :: Sigma -> String -> Effect Unit
cleanupSigma sigma context = traverse_ kill (readSigma sigma)
  where
    kill sig = runCleanups *> killSigma *> emptyOut
      where -- close over sig
        killSigma = Sigma.killSigma sig >>= report
    runCleanups = sequence_ (R.readRef sigma.cleanup)
    emptyOut = writeSigma sigma Nothing *> R.setRef sigma.cleanup Seq.empty
arturo's avatar
arturo committed
75
    report = either (console.log2 errorMsg) (\_ -> console.log successMsg)
James Laver's avatar
James Laver committed
76 77 78 79
    prefix = "[" <> context <> "] "
    errorMsg = prefix <> "Error killing sigma:"
    successMsg = prefix <> "Killed sigma"

80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97
-- refreshData :: Sigma.Sigma -> Graphology.Graph -> Effect Unit
-- refreshData sigma graph = do
--   console.log clearingMsg
--   Graphology.clear sigmaGraph
--   console.log readingMsg
--   _ <- Graphology.updateWithGraph sigmaGraph graph

--   -- refresh
--   console.log refreshingMsg
--   Sigma.refresh sigma
--   --pure $ either (console.log2 errorMsg) refresh
--   where
--     sigmaGraph = Sigma.graph sigma
--     refresh _ = console.log refreshingMsg *> Sigma.refresh sigma
--     clearingMsg = "[refreshData] Clearing existing graph data"
--     readingMsg = "[refreshData] Reading graph data"
--     refreshingMsg = "[refreshData] Refreshing graph"
--     errorMsg = "[refreshData] Error reading graph data:"
James Laver's avatar
James Laver committed
98 99 100 101

dependOnSigma :: Sigma -> String -> (Sigma.Sigma -> Effect Unit) -> Effect Unit
dependOnSigma sigma notFoundMsg f = do
  case readSigma sigma of
arturo's avatar
arturo committed
102
    Nothing -> console.warn notFoundMsg
James Laver's avatar
James Laver committed
103 104 105 106 107
    Just sig -> f sig

dependOnContainer :: R.Ref (Nullable Element) -> String -> (Element -> Effect Unit) -> Effect Unit
dependOnContainer container notFoundMsg f = do
  case R.readNullableRef container of
arturo's avatar
arturo committed
108
    Nothing -> console.warn notFoundMsg
James Laver's avatar
James Laver committed
109 110
    Just c -> f c

111 112 113

-- Effectful versions of the above code

114 115 116
-- | Effect for handling pausing FA via state changes.  We need this because
-- | pausing can be done not only via buttons but also from the initial
-- | setTimer.
117
handleForceAtlas2Pause :: R.Ref (Maybe ForceAtlas.FA2Layout)
118 119 120
                          -> T.Box ST.ForceAtlasState
                          -> R.Ref (Maybe TimeoutId)
                          -> Effect Unit
121
handleForceAtlas2Pause fa2Ref forceAtlasState mFAPauseRef = do
122
  let fa2_ = R.readRef fa2Ref
123
  toggled <- T.read forceAtlasState
124 125 126 127 128 129
  case fa2_ of
    Nothing -> pure unit
    Just fa2 -> do
      isFARunning <- ForceAtlas.isRunning fa2
      case Tuple toggled isFARunning of
        Tuple ST.InitialRunning false -> do
130 131
          -- console.log "[handleForceAtlas2Paue)] restarting FA (InitialRunning)"
          ForceAtlas.start fa2
132
        Tuple ST.Running false -> do
133 134 135
          -- console.log2 "[handleForceAtlas2Pause] restarting FA (Running)" fa2
          Graphology.updateGraphOnlyVisible (ForceAtlas.graph fa2)
          ForceAtlas.start fa2
136 137 138 139
          case R.readRef mFAPauseRef of
            Nothing -> pure unit
            Just timeoutId -> clearTimeout timeoutId
        Tuple ST.Paused true -> do
140
          -- console.log "[handleForceAtlas2Pause] stopping FA (Paused)"
141 142
          ForceAtlas.stop fa2
        _ -> pure unit
143

144 145
setSigmaEdgesVisibility :: Sigma.Sigma -> Record ST.EdgeVisibilityProps -> Effect Unit
setSigmaEdgesVisibility sigma ev = do
146
  let settings = {
147
      hideEdgesOnMove: ST.edgeStateHidden ev.showEdges
148
    }
149
  Sigma.setSettings sigma settings
150
  Graphology.updateEachEdgeAttributes (Sigma.graph sigma) $ ST.setEdgeVisibility ev
151

152

153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183
-- updateEdges :: Sigma.Sigma -> ST.EdgesMap -> Effect Unit
-- updateEdges sigma edgesMap = do
--   Graphology.forEachEdge (Sigma.graph sigma) \e -> do
--     let mTEdge = Map.lookup e.id edgesMap
--     case mTEdge of
--       Nothing -> error $ "Edge id " <> e.id <> " not found in edgesMap"
--       (Just {color: tColor, hidden: tHidden}) -> do
--         _ <- pure $ (e .= "color") tColor
--         _ <- pure $ (e .= "hidden") tHidden
--         pure unit
--   --Sigma.refresh sigma


-- updateNodes :: Sigma.Sigma -> ST.NodesMap -> Effect Unit
-- updateNodes sigma nodesMap = do
--   Graphology.forEachNode (Sigma.graph sigma) \n -> do
--     let mTNode = Map.lookup n.id nodesMap
--     case mTNode of
--       Nothing -> error $ "Node id " <> n.id <> " not found in nodesMap"
--       (Just { borderColor: tBorderColor
--              , color: tColor
--              , equilateral: tEquilateral
--              , hidden: tHidden
--              , type: tType }) -> do
--         _ <- pure $ (n .= "borderColor") tBorderColor
--         _ <- pure $ (n .= "color") tColor
--         _ <- pure $ (n .= "equilateral") tEquilateral
--         _ <- pure $ (n .= "hidden") tHidden
--         _ <- pure $ (n .= "type") tType
--         pure unit
--   --Sigma.refresh sigma
184 185


186
-- | Toggles item visibility in the selected set
187 188
--   Basically: add items that are NOT in `selected` and remove items
--   that are in `selected`.
189
multiSelectUpdate :: ST.NodeIds -> ST.NodeIds -> ST.NodeIds
190
multiSelectUpdate new selected = foldl GSet.toggle selected new
191 192


arturo's avatar
arturo committed
193 194
bindSelectedNodesClick :: Sigma.Sigma -> T.Box ST.NodeIds -> T.Box Boolean -> Effect Unit
bindSelectedNodesClick sigma selectedNodeIds multiSelectEnabled =
195 196
  Sigma.bindClickNodes sigma $ \nodeIds' -> do
    let nodeIds = Set.fromFoldable nodeIds'
arturo's avatar
arturo committed
197 198
    multiSelectEnabled' <- T.read multiSelectEnabled
    if multiSelectEnabled' then
199
      T.modify_ (multiSelectUpdate nodeIds) selectedNodeIds
200
    else
201
      T.write_ nodeIds selectedNodeIds
202

203 204 205 206 207 208 209 210 211 212
bindShiftWheel :: Sigma.Sigma -> T.Box Number -> Effect Unit
bindShiftWheel sigma mouseSelectorSize =
  Sigma.bindShiftWheel sigma $ \delta -> do
    let step = if delta > 0.0 then 5.0 else -5.0
    val <- T.read mouseSelectorSize
    let newVal = val + step
    Sigma.setSettings sigma {
      mouseSelectorSize: newVal
      }
    T.write_ newVal mouseSelectorSize
213 214

selectorWithSize :: Sigma.Sigma -> Int -> Effect Unit
arturo's avatar
arturo committed
215
selectorWithSize _ _ = do
216 217
  pure unit

218 219
performDiff :: Sigma.Sigma -> ST.SGraph -> Effect Unit
performDiff sigma g = do
220 221 222
  -- if (Seq.null addEdges) && (Seq.null addNodes) && (Set.isEmpty removeEdges) && (Set.isEmpty removeNodes) then
  --   pure unit
  -- else do
223 224 225 226
  -- console.log2 "[performDiff] addNodes" addNodes
  -- console.log2 "[performDiff] addEdges" $ A.fromFoldable addEdges
  -- console.log2 "[performDiff] removeNodes" removeNodes
  -- console.log2 "[performDiff] removeEdges" removeEdges
227
  -- console.log2 "[performDiff] updateNodes length" $ A.length $ A.fromFoldable updateNodes
228
  traverse_ (Graphology.addNode sigmaGraph) addNodes
229 230 231
  --traverse_ (Graphology.addEdge sigmaGraph) addEdges
  -- insert edges in batches, otherwise a maximum recursion error is thrown
  traverse_ (\edges -> setTimeout 100 $ traverse_ (Graphology.addEdge sigmaGraph) edges) $ GSeq.groupBy 5000 addEdges
232 233
  traverse_ (Graphology.removeEdge sigmaGraph) removeEdges
  traverse_ (Graphology.removeNode sigmaGraph) removeNodes
234
  traverse_ (Graphology.updateEdge sigmaGraph) updateEdges
235 236 237 238 239 240
  --traverse_ (Graphology.updateNode sigmaGraph) updateNodes
  traverse_ (\n -> Graphology.mergeNodeAttributes sigmaGraph n.id { borderColor: n.borderColor
                                                                  , color: n.color
                                                                  , equilateral: n.equilateral
                                                                  , hidden: n.hidden
                                                                  , highlighted: n.highlighted }) updateNodes
241
  --Sigma.refresh sigma
242 243
  -- TODO Use FA2Layout here
  --Sigma.killForceAtlas2 sigma
244 245
  where
    sigmaGraph = Sigma.graph sigma
246 247 248
    { add: Tuple addEdges addNodes
    , remove: Tuple removeEdges removeNodes
    , update: Tuple updateEdges updateNodes } = sigmaDiff sigmaGraph g
249 250 251


-- | Compute a diff between current sigma graph and whatever is set via custom controls
252 253
sigmaDiff :: Graphology.Graph -> ST.SGraph -> Record ST.SigmaDiff
sigmaDiff sigmaGraph gControls = { add, remove, update }
254 255 256
  where
    add = Tuple addEdges addNodes
    remove = Tuple removeEdges removeNodes
257
    update = Tuple updateEdges updateNodes
258

259 260 261 262
    sigmaNodes = Graphology.nodes sigmaGraph
    sigmaEdges = Graphology.edges sigmaGraph
    sigmaNodeIds = Set.fromFoldable $ Seq.map _.id sigmaNodes
    sigmaEdgeIds = Set.fromFoldable $ Seq.map _.id sigmaEdges
263

264 265 266 267
    gcNodes = ST.graphNodes gControls
    gcEdges = ST.graphEdges gControls
    gcNodeIds = Seq.map _.id gcNodes
    gcEdgeIds = Seq.map _.id gcEdges
268 269


270 271 272 273 274 275
    -- Add nodes/edges which aren't present in `sigmaGraph`, but are
    -- in `gControls`
    addGC = ST.edgesFilter (\e -> not (Set.member e.id sigmaEdgeIds)) $
            ST.nodesFilter (\n -> not (Set.member n.id sigmaNodeIds)) gControls
    addEdges = ST.graphEdges addGC
    addNodes = ST.graphNodes addGC
276

277 278 279 280
    -- Remove nodes/edges from `sigmaGraph` which aren't in
    -- `gControls`
    removeEdges = Set.difference sigmaEdgeIds (Set.fromFoldable gcEdgeIds)
    removeNodes = Set.difference sigmaNodeIds (Set.fromFoldable gcNodeIds)
281

282
    commonNodeIds = Set.intersection sigmaNodeIds $ Set.fromFoldable gcNodeIds
283 284 285
    commonNodes = Seq.filter (\n -> Set.member n.id commonNodeIds) sigmaNodes
    sigmaNodeIdsMap = Map.fromFoldable $ Seq.map (\n -> Tuple n.id n) commonNodes --sigmaNodes
    updateEdges = Seq.empty
286 287
    -- Find nodes for which `ST.compareNodes` returns `false`, i.e. nodes differ
    updateNodes = Seq.filter (\n -> (ST.compareNodes n <$> (Map.lookup n.id sigmaNodeIdsMap)) == Just false) gcNodes
288

289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320

-- DEPRECATED

-- markSelectedEdges :: Sigma.Sigma -> ST.EdgeIds -> ST.EdgesMap -> Effect Unit
-- markSelectedEdges sigma selectedEdgeIds graphEdges = do
--   Graphology.forEachEdge (Sigma.graph sigma) \e -> do
--     case Map.lookup e.id graphEdges of
--       Nothing -> error $ "Edge id " <> e.id <> " not found in graphEdges map"
--       Just {color} -> do
--         let newColor =
--               if Set.member e.id selectedEdgeIds then
--                 "#ff0000"
--               else
--                 color
--         _ <- pure $ (e .= "color") newColor
--         pure unit
--   Sigma.refresh sigma

-- markSelectedNodes :: Sigma.Sigma -> ST.NodeIds -> ST.NodesMap -> Effect Unit
-- markSelectedNodes sigma selectedNodeIds graphNodes = do
--   Graphology.forEachNode (Sigma.graph sigma) \n -> do
--     case Map.lookup n.id graphNodes of
--       Nothing -> error $ "Node id " <> n.id <> " not found in graphNodes map"
--       Just {color} -> do
--         let newColor =
--               if Set.member n.id selectedNodeIds then
--                 "#ff0000"
--               else
--                 color
--         _ <- pure $ (n .= "color") newColor
--         pure unit
--   Sigma.refresh sigma