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

4
import Prelude (Unit, bind, discard, flip, pure, unit, ($), (*>), (<<<), (<>), (>>=), not, const, map)
5

James Laver's avatar
James Laver committed
6
import Data.Array as A
7
import Data.Either (either)
8
import Data.Foldable (sequence_, foldl)
9
import Data.Map as Map
10 11
import Data.Maybe (Maybe(..))
import Data.Nullable (Nullable)
James Laver's avatar
James Laver committed
12
import Data.Sequence (Seq)
13
import Data.Sequence as Seq
14
import Data.Set as Set
15
import Data.Traversable (traverse_)
16
import Data.Tuple (Tuple(..))
17
import Data.Tuple.Nested((/\))
18 19
import DOM.Simple.Console (log, log2)
import DOM.Simple.Types (Element)
James Laver's avatar
James Laver committed
20
import Effect (Effect)
21
import Effect.Class.Console (error)
22
import Effect.Timer (TimeoutId, clearTimeout)
23
import FFI.Simple ((.=))
James Laver's avatar
James Laver committed
24
import Gargantext.Hooks.Sigmax.Sigma as Sigma
25
import Gargantext.Hooks.Sigmax.Types as ST
26 27
import Gargantext.Utils.Reactix as R2
import Reactix as R
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

37 38 39 40 41 42
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
43 44 45 46 47 48 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 75 76 77 78 79 80 81 82
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
    report = either (log2 errorMsg) (\_ -> log successMsg)
    prefix = "[" <> context <> "] "
    errorMsg = prefix <> "Error killing sigma:"
    successMsg = prefix <> "Killed sigma"

refreshData :: forall n e. Sigma.Sigma -> Sigma.Graph n e -> Effect Unit
refreshData sigma graph
  =   log clearingMsg
  *>  Sigma.clear sigma
  *>  log readingMsg
  *>  Sigma.graphRead sigma graph
  >>= either (log2 errorMsg) refresh
  where
    refresh _ = log refreshingMsg *> Sigma.refresh sigma
83 84 85 86
    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
87

88 89
sigmafy :: forall n e. ST.Graph n e -> Sigma.Graph n e
sigmafy (ST.Graph g) = {nodes,edges}
James Laver's avatar
James Laver committed
90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105
  where
    nodes = A.fromFoldable g.nodes
    edges = A.fromFoldable g.edges

dependOnSigma :: Sigma -> String -> (Sigma.Sigma -> Effect Unit) -> Effect Unit
dependOnSigma sigma notFoundMsg f = do
  case readSigma sigma of
    Nothing -> log notFoundMsg
    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
    Nothing -> log notFoundMsg
    Just c -> f c

106 107 108

-- Effectful versions of the above code

109 110 111
-- | 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.
112
--handleForceAtlasPause sigmaRef (toggled /\ setToggled) mFAPauseRef = do
113 114
handleForceAtlas2Pause :: R.Ref Sigma -> R.State ST.ForceAtlasState -> R.Ref (Maybe TimeoutId) -> Effect Unit
handleForceAtlas2Pause sigmaRef (toggled /\ setToggled) mFAPauseRef = do
115 116
  let sigma = R.readRef sigmaRef
  dependOnSigma sigma "[handleForceAtlas2Pause] sigma: Nothing" $ \s -> do
117 118
    --log2 "[handleForceAtlas2Pause] mSigma: Just " s
    --log2 "[handleForceAtlas2Pause] toggled: " toggled
119
    isFARunning <- Sigma.isForceAtlas2Running s
120
    --log2 "[handleForceAtlas2Pause] isFARunning: " isFARunning
121
    case Tuple toggled isFARunning of
122 123 124 125
      Tuple ST.InitialRunning false -> do
        -- hide edges during forceAtlas rendering, this prevents flickering
        Sigma.restartForceAtlas2 s
      Tuple ST.Running false -> do
126 127
        -- hide edges during forceAtlas rendering, this prevents flickering
        Sigma.restartForceAtlas2 s
128 129 130
        case R.readRef mFAPauseRef of
          Nothing -> pure unit
          Just timeoutId -> clearTimeout timeoutId
131
      Tuple ST.Paused true -> do
132 133
        -- restore edges state
        Sigma.stopForceAtlas2 s
134
      _ -> pure unit
135 136 137 138 139 140 141 142

setEdges :: Sigma.Sigma -> Boolean -> Effect Unit
setEdges sigma val = do
  let settings = {
        drawEdges: val
      , drawEdgeLabels: val
      , hideEdgesOnMove: not val
    }
143 144
  Sigma.setSettings sigma settings

145

146
updateEdges :: Sigma.Sigma -> ST.EdgesMap -> Effect Unit
147
updateEdges sigma edgesMap = do
148
  Sigma.forEachEdge sigma \e -> do
149 150 151
    let mTEdge = Map.lookup e.id edgesMap
    case mTEdge of
      Nothing -> error $ "Edge id " <> e.id <> " not found in edgesMap"
152
      (Just {color: tColor, hidden: tHidden}) -> do
153
        _ <- pure $ (e .= "color") tColor
154
        _ <- pure $ (e .= "hidden") tHidden
155
        pure unit
156
  --Sigma.refresh sigma
157 158


159
updateNodes :: Sigma.Sigma -> ST.NodesMap -> Effect Unit
160 161 162 163 164
updateNodes sigma nodesMap = do
  Sigma.forEachNode sigma \n -> do
    let mTNode = Map.lookup n.id nodesMap
    case mTNode of
      Nothing -> error $ "Node id " <> n.id <> " not found in nodesMap"
165 166 167 168 169
      (Just { borderColor: tBorderColor
             , color: tColor
             , hidden: tHidden
             , type: tType}) -> do
        _ <- pure $ (n .= "borderColor") tBorderColor
170 171
        _ <- pure $ (n .= "color") tColor
        _ <- pure $ (n .= "hidden") tHidden
172
        _ <- pure $ (n .= "type") tType
173
        pure unit
174
  --Sigma.refresh sigma
175 176


177
-- | Toggles item visibility in the selected set
178
multiSelectUpdate :: ST.SelectedNodeIds -> ST.SelectedNodeIds -> ST.SelectedNodeIds
179 180 181 182 183 184 185 186 187
multiSelectUpdate new selected = foldl fld selected new
  where
    fld selectedAcc item =
      if Set.member item selectedAcc then
        Set.delete item selectedAcc
      else
        Set.insert item selectedAcc


188
bindSelectedNodesClick :: Sigma.Sigma -> R.State ST.SelectedNodeIds -> R.Ref Boolean -> Effect Unit
189 190 191 192 193 194 195
bindSelectedNodesClick sigma (_ /\ setSelectedNodeIds) multiSelectEnabledRef =
  Sigma.bindClickNodes sigma $ \nodes -> do
    let multiSelectEnabled = R.readRef multiSelectEnabledRef
    let nodeIds = Set.fromFoldable $ map _.id nodes
    if multiSelectEnabled then
      setSelectedNodeIds $ multiSelectUpdate nodeIds
    else
196
      setSelectedNodeIds $ const nodeIds
197

198
bindSelectedEdgesClick :: R.Ref Sigma -> R.State ST.SelectedEdgeIds -> Effect Unit
199 200 201 202 203 204 205 206
bindSelectedEdgesClick sigmaRef (_ /\ setSelectedEdgeIds) =
  dependOnSigma (R.readRef sigmaRef) "[graphCpt] no sigma" $ \sigma -> do
    Sigma.bindClickEdge sigma $ \edge -> do
      setSelectedEdgeIds \eids ->
        if Set.member edge.id eids then
          Set.delete edge.id eids
        else
          Set.insert edge.id eids
207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242

selectorWithSize :: Sigma.Sigma -> Int -> Effect Unit
selectorWithSize sigma size = do
  pure unit

-- DEPRECATED

markSelectedEdges :: Sigma.Sigma -> ST.SelectedEdgeIds -> ST.EdgesMap -> Effect Unit
markSelectedEdges sigma selectedEdgeIds graphEdges = do
  Sigma.forEachEdge 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.SelectedNodeIds -> ST.NodesMap -> Effect Unit
markSelectedNodes sigma selectedNodeIds graphNodes = do
  Sigma.forEachNode 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