Sidebar.purs 17.8 KB
Newer Older
1
module Gargantext.Components.GraphExplorer.Sidebar
2
  -- (Props, sidebar)
3
  where
4

5 6
import Gargantext.Prelude

7
import Control.Parallel (parTraverse)
8
import Data.Array (head, last, concat)
9
import Data.Array as A
10
import Data.Either (Either(..))
11
import Data.Foldable as F
12
import Data.Int (fromString)
13
import Data.Map as Map
14
import Data.Maybe (Maybe(..), fromJust)
15
import Data.Sequence as Seq
16
import Data.Set as Set
17
import Effect (Effect)
18
import Effect.Aff (Aff, launchAff_)
19
import Effect.Class (liftEffect)
20
import Gargantext.Components.App.Data (Boxes)
21
import Gargantext.Components.GraphExplorer.Legend as Legend
22
import Gargantext.Components.GraphExplorer.Sidebar.Types as GEST
23 24
import Gargantext.Components.GraphExplorer.Types as GET
import Gargantext.Components.Lang (Lang(..))
25
import Gargantext.Components.NgramsTable.Core as NTC
26
import Gargantext.Components.Nodes.Corpus.Graph.Tabs (tabs) as CGT
27
import Gargantext.Components.RandomText (words)
28
import Gargantext.Components.Search (SearchType(..), SearchQuery(..))
29
import Gargantext.Config.REST (RESTError)
30
import Gargantext.Data.Array (mapMaybe)
31
import Gargantext.Ends (Frontends)
32
import Gargantext.Hooks.Sigmax.Types as SigmaxT
33
import Gargantext.Sessions (Session)
34
import Gargantext.Types (CTabNgramType, FrontendError(..), NodeID, TabSubType(..), TabType(..), TermList(..), modeTabType)
35
import Gargantext.Utils.Reactix as R2
36
import Gargantext.Utils.Toestand as T2
37
import Math as Math
38 39 40 41 42 43 44
import Partial.Unsafe (unsafePartial)
import Reactix as R
import Reactix.DOM.HTML as H
import Reactix.DOM.HTML as RH
import Record as Record
import Record.Extra as RX
import Toestand as T
45

46 47
here :: R2.Here
here = R2.here "Gargantext.Components.GraphExplorer.Sidebar"
48

49
type Common = (
50
    boxes           :: Boxes
51
  , graphId         :: NodeID
52 53
  , metaData        :: GET.MetaData
  , session         :: Session
54 55 56 57 58 59
  )

type Props = (
    frontends       :: Frontends
  , graph           :: SigmaxT.SGraph
  | Common
60
  )
61

62 63
sidebar :: R2.Component Props
sidebar = R.createElement sidebarCpt
64
sidebarCpt :: R.Component Props
65
sidebarCpt = here.component "sidebar" cpt
66
  where
67 68
    cpt props@{ boxes: { sidePanelGraph } } _ = do
      { sideTab } <- GEST.focusedSidePanel sidePanelGraph
69 70 71 72 73
      sideTab' <- T.useLive T.unequal sideTab

      pure $ RH.div { id: "sp-container" }
        [ sideTabNav { sideTab
                     , sideTabs: [GET.SideTabLegend, GET.SideTabData, GET.SideTabCommunity] } []
74 75 76 77
        , case sideTab' of
            GET.SideTabLegend -> sideTabLegend sideTabProps []
            GET.SideTabData -> sideTabData sideTabProps []
            GET.SideTabCommunity -> sideTabCommunity sideTabProps []
78
        ]
79
      where
80
        sideTabProps = RX.pick props :: Record Props
81

82
type SideTabNavProps = (
83 84
    sideTab  :: T.Box GET.SideTab
  , sideTabs :: Array GET.SideTab
85 86 87 88 89 90 91
  )

sideTabNav :: R2.Component SideTabNavProps
sideTabNav = R.createElement sideTabNavCpt
sideTabNavCpt :: R.Component SideTabNavProps
sideTabNavCpt = here.component "sideTabNav" cpt
  where
92 93
    cpt { sideTab, sideTabs } _ = do
      sideTab' <- T.useLive T.unequal sideTab
94 95

      pure $ R.fragment [ H.div { className: "text-primary center"} [H.text ""]
96
                        , H.div { className: "nav nav-tabs"} (liItem sideTab' <$> sideTabs)
97 98 99
                            -- , H.div {className: "center"} [ H.text "Doc sideTabs"]
                        ]
      where
100 101
        liItem :: GET.SideTab -> GET.SideTab -> R.Element
        liItem sideTab' tab =
102
          H.div { className : "nav-item nav-link"
103
                            <> if tab == sideTab'
104 105
                                 then " active"
                                 else ""
106 107
                , on: { click: \_ -> T.write_ tab sideTab }
                } [ H.text $ show tab ]
108

109
sideTabLegend :: R2.Component Props
110
sideTabLegend = R.createElement sideTabLegendCpt
111
sideTabLegendCpt :: R.Component Props
112 113
sideTabLegendCpt = here.component "sideTabLegend" cpt
  where
114
    cpt { metaData: GET.MetaData { legend } } _ = do
115 116 117 118
      pure $ H.div {}
        [ Legend.legend { items: Seq.fromFoldable legend }
        , documentation EN
        ]
119

120
sideTabData :: R2.Component Props
121
sideTabData = R.createElement sideTabDataCpt
122
sideTabDataCpt :: R.Component Props
123 124
sideTabDataCpt = here.component "sideTabData" cpt
  where
125 126 127
    cpt props@{ boxes: { sidePanelGraph } } _ = do
      { selectedNodeIds } <- GEST.focusedSidePanel sidePanelGraph
      selectedNodeIds' <- T.useLive T.unequal selectedNodeIds
128 129 130 131 132

      pure $ RH.div {}
        [ selectedNodes (Record.merge { nodesMap: SigmaxT.nodesGraphMap props.graph } props) []
        , neighborhood props []
        , RH.div { className: "col-md-12", id: "query" }
133 134 135 136 137 138 139
          [ query { frontends: props.frontends
                  , metaData: props.metaData
                  , nodesMap: SigmaxT.nodesGraphMap props.graph
                  , searchType: SearchDoc
                  , selectedNodeIds: selectedNodeIds'
                  , session: props.session
                  } []
140 141
          ]
        ]
142

143

144
sideTabCommunity :: R2.Component Props
145
sideTabCommunity = R.createElement sideTabCommunityCpt
146
sideTabCommunityCpt :: R.Component Props
147 148
sideTabCommunityCpt = here.component "sideTabCommunity" cpt
  where
149 150 151 152
    cpt props@{ boxes: { sidePanelGraph }
              , frontends } _ = do
      { selectedNodeIds } <- GEST.focusedSidePanel sidePanelGraph
      selectedNodeIds' <- T.useLive T.unequal selectedNodeIds
153 154 155 156

      pure $ RH.div { className: "col-md-12", id: "query" }
        [ selectedNodes (Record.merge { nodesMap: SigmaxT.nodesGraphMap props.graph } props) []
        , neighborhood props []
157
        , query { frontends
158 159 160 161 162 163
                , metaData: props.metaData
                , nodesMap: SigmaxT.nodesGraphMap props.graph
                , searchType: SearchContact
                , selectedNodeIds: selectedNodeIds'
                , session: props.session
                } []
164
        ]
165 166 167


-------------------------------------------
168 169
-- TODO
-- selectedNodes :: Record Props -> Map.Map String Nodes -> R.Element
170 171 172 173 174 175 176 177 178 179 180

type SelectedNodesProps = (
  nodesMap :: SigmaxT.NodesMap
  | Props
  )

selectedNodes :: R2.Component SelectedNodesProps
selectedNodes = R.createElement selectedNodesCpt
selectedNodesCpt :: R.Component SelectedNodesProps
selectedNodesCpt = here.component "selectedNodes" cpt
  where
181 182 183 184
    cpt props@{ boxes: { sidePanelGraph }
              , graph
              , nodesMap } _ = do
      { selectedNodeIds } <- GEST.focusedSidePanel sidePanelGraph
185 186 187 188
      selectedNodeIds' <- T.useLive T.unequal selectedNodeIds

      pure $ R2.row
        [ R2.col 12
189 190 191
          [ RH.ul { className: "nav nav-tabs d-flex justify-content-center"
                  , id: "myTab"
                  , role: "tablist" }
Alexandre Delanoë's avatar
Alexandre Delanoë committed
192
            [ RH.div { className: "tab-content" }
193
              [ RH.div { className: "d-flex flex-wrap justify-content-center"
Alexandre Delanoë's avatar
Alexandre Delanoë committed
194
                       , role: "tabpanel" }
195
                ( Seq.toUnfoldable
196 197 198 199 200 201 202
                  $ ( Seq.map (\node -> badge { minSize: node.size  -- same size for all badges
                                              , maxSize: node.size
                                              , node
                                              , selectedNodeIds })
                      (badges graph selectedNodeIds')
                    )
--                  $ ( Seq.map (\node -> badge { maxSize, minSize, node, selectedNodeIds }) badges')
203
                )
Alexandre Delanoë's avatar
Alexandre Delanoë committed
204 205 206
              , H.br {}
              ]
            ]
207
          , RH.div { className: "tab-content flex-space-between" }
208 209 210 211
            [ updateTermButton (Record.merge { buttonType: "primary"
                                             , rType: CandidateTerm
                                             , nodesMap
                                             , text: "Move as candidate" } commonProps) []
212
            , H.br {}
213 214 215 216
            , updateTermButton (Record.merge { buttonType: "danger"
                                             , nodesMap
                                             , rType: StopTerm
                                             , text: "Move as stop" } commonProps) []
217 218 219 220 221 222 223 224 225 226 227
            ]
          ]
        ]
      where
        commonProps = RX.pick props :: Record Common

neighborhood :: R2.Component Props
neighborhood = R.createElement neighborhoodCpt
neighborhoodCpt :: R.Component Props
neighborhoodCpt = here.component "neighborhood" cpt
  where
228 229 230 231
    cpt { boxes: { sidePanelGraph }
        , graph
         } _ = do
      { selectedNodeIds } <- GEST.focusedSidePanel sidePanelGraph
232 233
      selectedNodeIds' <- T.useLive T.unequal selectedNodeIds

234
      let badges' = neighbourBadges graph selectedNodeIds'
235 236
          minSize = F.foldl Math.min 0.0 (Seq.map _.size (SigmaxT.graphNodes graph))
          maxSize = F.foldl Math.max 0.0 (Seq.map _.size (SigmaxT.graphNodes graph))
237

238 239 240 241 242 243
      pure $ RH.div { className: "tab-content", id: "myTabContent" }
        [ RH.div { -- className: "flex-space-around d-flex justify-content-center"
             className: "d-flex flex-wrap flex-space-around"
             , id: "home"
             , role: "tabpanel"
             }
244
          (Seq.toUnfoldable $ Seq.map (\node -> badge { maxSize, minSize, node, selectedNodeIds }) badges')
245 246 247
        ]


248
type UpdateTermButtonProps = (
249 250 251 252 253 254 255
    buttonType :: String
  , nodesMap   :: SigmaxT.NodesMap
  , rType      :: TermList
  , text       :: String
  | Common
  )

256 257 258 259
updateTermButton :: R2.Component UpdateTermButtonProps
updateTermButton = R.createElement updateTermButtonCpt
updateTermButtonCpt :: R.Component UpdateTermButtonProps
updateTermButtonCpt = here.component "updateTermButton" cpt
260
  where
261 262 263 264
    cpt { boxes: { errors
                 , reloadForest
                 , sidePanelGraph }
        , buttonType
265 266 267 268 269 270
        , graphId
        , metaData
        , nodesMap
        , rType
        , session
        , text } _ = do
271
      { removedNodeIds, selectedNodeIds } <- GEST.focusedSidePanel sidePanelGraph
272 273 274 275 276 277
      selectedNodeIds' <- T.useLive T.unequal selectedNodeIds

      pure $ if Set.isEmpty selectedNodeIds' then
               RH.div {} []
             else
               RH.button { className: "btn btn-sm btn-" <> buttonType
278
                         , on: { click: onClickRemove removedNodeIds selectedNodeIds selectedNodeIds' }
279 280
                         } [ RH.text text ]
      where
281
        onClickRemove removedNodeIds selectedNodeIds selectedNodeIds' _ = do
282 283
          let nodes = mapMaybe (\id -> Map.lookup id nodesMap)
                              $ Set.toUnfoldable selectedNodeIds'
284 285
          sendPatches { errors
                      , graphId: graphId
286 287 288 289 290
                      , metaData: metaData
                      , nodes
                      , session: session
                      , termList: rType
                      , reloadForest }
291 292
          T.write_ selectedNodeIds' removedNodeIds
          T.write_ SigmaxT.emptyNodeIds selectedNodeIds
293 294


295
type BadgeProps =
296 297 298
  ( maxSize         :: Number
  , minSize         :: Number
  , node            :: Record SigmaxT.Node
299
  , selectedNodeIds :: T.Box SigmaxT.NodeIds )
300

301 302 303 304
badge :: R2.Leaf BadgeProps
badge props = R.createElement badgeCpt props []
badgeCpt :: R.Component BadgeProps
badgeCpt = here.component "badge" cpt where
305 306 307 308 309 310
  cpt { maxSize, minSize, node: { id, label, size }, selectedNodeIds } _ = do
    let minFontSize = 1.0  -- "em"
    let maxFontSize = 3.0  -- "em"
    let sizeScaled = (size - minSize) / (maxSize - minSize)  -- in [0; 1] range
    let scale' = Math.log (sizeScaled + 1.0) / (Math.log 2.0)  -- in [0; 1] range
    let scale = minFontSize + scale' * (maxFontSize - minFontSize)
311 312 313 314 315 316 317 318 319 320
    let style = {
          fontSize: show scale <> "em"
          }
    
    pure $ RH.a { className: "badge badge-pill badge-light"
                , on: { click: onClick }
                } [ RH.h6 { style } [ RH.text label ] ]
    where
      onClick _ = do
        T.write_ (Set.singleton id) selectedNodeIds
321

322 323
badges :: SigmaxT.SGraph -> SigmaxT.NodeIds -> Seq.Seq (Record SigmaxT.Node)
badges graph selectedNodeIds = SigmaxT.graphNodes $ SigmaxT.nodesById graph selectedNodeIds
324

325
neighbourBadges :: SigmaxT.SGraph -> SigmaxT.NodeIds -> Seq.Seq (Record SigmaxT.Node)
326 327
neighbourBadges graph selectedNodeIds = SigmaxT.neighbours graph selectedNodes' where
  selectedNodes' = SigmaxT.graphNodes $ SigmaxT.nodesById graph selectedNodeIds
328

329
type SendPatches =
330 331
  ( errors       :: T.Box (Array FrontendError)
  , graphId      :: NodeID
332 333
  , metaData     :: GET.MetaData
  , nodes        :: Array (Record SigmaxT.Node)
334
  , reloadForest :: T2.ReloadS
335 336
  , session      :: Session
  , termList     :: TermList
337
  )
338

339
sendPatches :: Record SendPatches -> Effect Unit
340
sendPatches { errors, metaData, nodes, reloadForest, session, termList } = do
341
  launchAff_ do
342
    patches <- (parTraverse (sendPatch termList session metaData) nodes) -- :: Aff (Array NTC.VersionedNgramsPatches)
343 344 345
    let mPatch = last patches
    case mPatch of
      Nothing -> pure unit
346 347 348
      Just (Left err) -> liftEffect $ do
        T.modify_ (A.cons $ FRESTError { error: err }) errors
        here.log2 "[sendPatches] RESTError" err
349
      Just (Right (NTC.Versioned _patch)) -> do
350
        liftEffect $ T2.reload reloadForest
351

352
-- Why is this called delete node?
353 354 355 356
sendPatch :: TermList
          -> Session
          -> GET.MetaData
          -> Record SigmaxT.Node
357
          -> Aff (Either RESTError NTC.VersionedNgramsPatches)
358
sendPatch termList session (GET.MetaData metaData) node = do
359 360 361 362
    eRet  <- NTC.putNgramsPatches coreParams versioned
    case eRet of
      Left err -> pure $ Left err
      Right ret -> do
363
        _task <- NTC.postNgramsChartsAsync coreParams  -- TODO add task
364
        pure $ Right ret
365
  where
366
    nodeId :: NodeID
367
    nodeId = unsafePartial $ fromJust $ fromString node.id
368

369 370
    versioned :: NTC.VersionedNgramsPatches
    versioned = NTC.Versioned {version: metaData.list.version, data: np}
371

372
    coreParams :: NTC.CoreParams ()
373
    coreParams = {session, nodeId, listIds: [metaData.list.listId], tabType}
374

375 376
    tabNgramType :: CTabNgramType
    tabNgramType = modeTabType node.gargType
377

378 379
    tabType :: TabType
    tabType = TabCorpus (TabNgramType tabNgramType)
380

381 382
    term :: NTC.NgramsTerm
    term = NTC.normNgram tabNgramType node.label
383

384 385
    np :: NTC.NgramsPatches
    np = NTC.singletonPatchMap term $ NTC.NgramsPatch { patch_children: mempty, patch_list }
386

387
    patch_list :: NTC.Replace TermList
388
    patch_list = NTC.Replace { new: termList, old: MapTerm }
389

390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439
type Query =
  ( frontends       :: Frontends
  , metaData        :: GET.MetaData
  , nodesMap        :: SigmaxT.NodesMap
  , searchType      :: SearchType
  , selectedNodeIds :: SigmaxT.NodeIds
  , session         :: Session )

query :: R2.Component Query
query = R.createElement queryCpt

queryCpt :: R.Component Query
queryCpt = here.component "query" cpt where
  cpt props@{ selectedNodeIds } _ = do

    pure $ if Set.isEmpty selectedNodeIds
           then RH.div {} []
           else query' props []

query' :: R2.Component Query
query' = R.createElement queryCpt'

queryCpt' :: R.Component Query
queryCpt' = here.component "query'" cpt where
  cpt { frontends
      , metaData: GET.MetaData metaData
      , nodesMap
      , searchType
      , selectedNodeIds
      , session } _ = do
    pure $ case (head metaData.corpusId) of
      Nothing -> RH.div {} []
      Just corpusId ->
        CGT.tabs { frontends
                 , query: SearchQuery { expected: searchType
                                      , query : concat $ toQuery <$> Set.toUnfoldable selectedNodeIds
                                      }
                 , session
                 , sides: [side corpusId]
                 }

    where
      toQuery id = case Map.lookup id nodesMap of
        Nothing -> []
        Just n -> words n.label

      side corpusId = GET.GraphSideCorpus { corpusId
                                          , corpusLabel: metaData.title
                                          , listId     : metaData.list.listId
                                          }
440 441 442 443 444 445 446 447 448 449 450 451

------------------------------------------------------------------------

            {-, RH.div { className: "col-md-12", id: "horizontal-checkbox" }
              [ RH.ul {}
                [ checkbox "Pubs"
                , checkbox "Projects"
                , checkbox "Patents"
                , checkbox "Others"
                ]
              ]
              -}
452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486
--------------------------------------------------------------------------


documentation :: Lang -> R.Element
documentation _ =
  H.div {} [ H.h2 {} [ H.text "What is Graph ?"]
           , ul [ "Graph is a conveniant tool to explore your documents. "
                , "Nodes are terms selected in your Map List. "
                <> "Node size is proportional to the number of documents with the associated term. "
                , "Edges between nodes represent proximities of terms according to a specific distance between your documents. "
                <> "Link strength is proportional to the strenght of terms association."
                ]
           , H.h3 {} [ H.text "Basic Interactions:"]
           , ul [ "Click on a node to select/unselect and get its information. "
                , "In case of multiple selection, the button unselect clears all selections. "
                <> "Use your mouse scroll to zoom in and out in the graph. "
                , "Use the node filter to create a subgraph with nodes of a given size "
                <>"range (e.g. display only generic terms). "
                , "Use the edge filter so create a subgraph with links in a given range (e.g. keep the strongest association)."
                ]
           ]

  where
    ul ts = H.ul {} $ map (\t -> H.li {} [ H.text t ]) ts

{-
TODO DOC
  Conditional distance between the terms X and Y is the probability to have both terms X and Y in the same textual context.
  Distributional distance between the terms X and Y is the probability to have same others terms in the same textual context as X or Y.

Global/local view:
    The 'change level' button allows to change between global view and node centered view,
    To explore the neighborhood of a selection click on the 'change level' button.
-}