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

5
import Control.Parallel (parTraverse)
6
import Data.Array (head, last, concat)
7
import Data.Int (fromString)
8
import Data.Map as Map
9
import Data.Maybe (Maybe(..), fromJust)
10
import Data.Sequence as Seq
11
import Data.Set as Set
12 13
import Effect (Effect)
import Effect.Aff (Aff, launchAff_)
14
import Effect.Class (liftEffect)
15
import Partial.Unsafe (unsafePartial)
16 17 18
import Reactix as R
import Reactix.DOM.HTML as RH
import Reactix.DOM.HTML as H
19 20
import Record as Record
import Record.Extra as RX
21
import Toestand as T
22 23 24

import Gargantext.Prelude

25
import Gargantext.Components.Lang (Lang(..))
26
import Gargantext.Components.Search (SearchType(..), SearchQuery(..))
27
import Gargantext.Components.GraphExplorer.Types  as GET
28
import Gargantext.Components.GraphExplorer.Types  (SidePanelState(..), SideTab(..))
29
import Gargantext.Components.GraphExplorer.Legend as Legend
30
import Gargantext.Components.NgramsTable.Core as NTC
31
import Gargantext.Components.Nodes.Corpus.Graph.Tabs (tabs) as CGT
32
import Gargantext.Components.RandomText (words)
33
import Gargantext.Data.Array (mapMaybe)
34
import Gargantext.Ends (Frontends)
35
import Gargantext.Hooks.Sigmax.Types as SigmaxT
36
import Gargantext.Sessions (Session)
37
import Gargantext.Types (CTabNgramType, NodeID, TabSubType(..), TabType(..), TermList(..), modeTabType)
38
import Gargantext.Utils.Reactix as R2
39
import Gargantext.Utils.Toestand as T2
40

41 42
here :: R2.Here
here = R2.here "Gargantext.Components.GraphExplorer.Sidebar"
43

44 45
type Common = (
    graphId         :: NodeID
46
  , metaData        :: GET.MetaData
47 48 49
  , reloadForest    :: T.Box T2.Reload
  , removedNodeIds  :: T.Box SigmaxT.NodeIds
  , selectedNodeIds :: T.Box SigmaxT.NodeIds
50
  , session         :: Session
51 52 53 54 55
  )

type Props = (
    frontends       :: Frontends
  , graph           :: SigmaxT.SGraph
56
  , graphVersion    :: T2.ReloadS
57
  , showSidePanel   :: T.Box GET.SidePanelState
58
  | Common
59
  )
60

61 62
sidebar :: Record Props -> R.Element
sidebar props = R.createElement sidebarCpt props []
63

64
sidebarCpt :: R.Component Props
65
sidebarCpt = here.component "sidebar" cpt
66
  where
67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84
    cpt props@{ metaData, showSidePanel } _ = do
      showSidePanel' <- T.useLive T.unequal showSidePanel

      case showSidePanel' of
        GET.Closed -> pure $ RH.div {} []
        GET.InitialClosed -> pure $ RH.div {} []
        GET.Opened sideTabT -> do
          let sideTab' = case sideTabT of
                SideTabLegend -> sideTabLegend sideTabProps []
                SideTabData -> sideTabData sideTabProps []
                SideTabCommunity -> sideTabCommunity sideTabProps []
          pure $ RH.div { id: "sp-container" }
            [ sideTabNav { sidePanel: showSidePanel
                         , sideTabs: [SideTabLegend, SideTabData, SideTabCommunity] } []
            , sideTab'
            ]
      where
        sideTabProps = RX.pick props :: Record SideTabProps
85

86
type SideTabNavProps = (
87
    sidePanel :: T.Box GET.SidePanelState
88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115
  , sideTabs  :: Array SideTab
  )

sideTabNav :: R2.Component SideTabNavProps
sideTabNav = R.createElement sideTabNavCpt

sideTabNavCpt :: R.Component SideTabNavProps
sideTabNavCpt = here.component "sideTabNav" cpt
  where
    cpt { sidePanel
        , sideTabs } _ = do
      sidePanel' <- T.useLive T.unequal sidePanel

      pure $ R.fragment [ H.div { className: "text-primary center"} [H.text ""]
                        , H.div { className: "nav nav-tabs"} (liItem sidePanel' <$> sideTabs)
                            -- , H.div {className: "center"} [ H.text "Doc sideTabs"]
                        ]
      where
        liItem :: GET.SidePanelState -> SideTab -> R.Element
        liItem sidePanel' tab =
          H.div { className : "nav-item nav-link"
                            <> if (Opened tab) == sidePanel'
                                 then " active"
                                 else ""
              , on: { click: \_ -> T.write (Opened tab) sidePanel
                    }
              } [ H.text $ show tab ]

116
type SideTabProps = Props
117

118 119
sideTabLegend :: R2.Component SideTabProps
sideTabLegend = R.createElement sideTabLegendCpt
120

121 122 123 124 125 126 127 128
sideTabLegendCpt :: R.Component SideTabProps
sideTabLegendCpt = here.component "sideTabLegend" cpt
  where
    cpt props@{ metaData: GET.MetaData { legend } } _ = do
      pure $ H.div {}
        [ Legend.legend { items: Seq.fromFoldable legend }
        , documentation EN
        ]
129

130 131
sideTabData :: R2.Component SideTabProps
sideTabData = R.createElement sideTabDataCpt
132

133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157
sideTabDataCpt :: R.Component SideTabProps
sideTabDataCpt = here.component "sideTabData" cpt
  where
    cpt props _ = do
      selectedNodeIds' <- T.useLive T.unequal props.selectedNodeIds

      pure $ RH.div {}
        [ selectedNodes (Record.merge { nodesMap: SigmaxT.nodesGraphMap props.graph } props) []
        , neighborhood props []
        , RH.div { className: "col-md-12", id: "query" }
          [ query SearchDoc
            props.frontends
            props.metaData
            props.session
            (SigmaxT.nodesGraphMap props.graph)
            selectedNodeIds'
          ]
        ]
        where
          checkbox text = RH.li {}
                          [ RH.span {} [ RH.text text ]
                          , RH.input { type: "checkbox"
                                     , className: "checkbox"
                                     , defaultChecked: true
                                     , title: "Mark as completed" } ]
158

159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178

sideTabCommunity :: R2.Component SideTabProps
sideTabCommunity = R.createElement sideTabCommunityCpt

sideTabCommunityCpt :: R.Component SideTabProps
sideTabCommunityCpt = here.component "sideTabCommunity" cpt
  where
    cpt props _ = do
      selectedNodeIds' <- T.useLive T.unequal props.selectedNodeIds

      pure $ RH.div { className: "col-md-12", id: "query" }
        [ selectedNodes (Record.merge { nodesMap: SigmaxT.nodesGraphMap props.graph } props) []
        , neighborhood props []
        , query SearchContact
          props.frontends
          props.metaData
          props.session
          (SigmaxT.nodesGraphMap props.graph)
          selectedNodeIds'
        ]
179 180 181


-------------------------------------------
182 183
-- TODO
-- selectedNodes :: Record Props -> Map.Map String Nodes -> R.Element
184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202

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

selectedNodes :: R2.Component SelectedNodesProps
selectedNodes = R.createElement selectedNodesCpt

selectedNodesCpt :: R.Component SelectedNodesProps
selectedNodesCpt = here.component "selectedNodes" cpt
  where
    cpt props@{ graph
              , nodesMap
              , selectedNodeIds } _ = do
      selectedNodeIds' <- T.useLive T.unequal selectedNodeIds

      pure $ R2.row
        [ R2.col 12
203 204 205
          [ RH.ul { className: "nav nav-tabs d-flex justify-content-center"
                  , id: "myTab"
                  , role: "tablist" }
Alexandre Delanoë's avatar
Alexandre Delanoë committed
206
            [ RH.div { className: "tab-content" }
207
              [ RH.div { className: "d-flex flex-wrap justify-content-center"
Alexandre Delanoë's avatar
Alexandre Delanoë committed
208
                       , role: "tabpanel" }
209 210 211 212 213
                ( Seq.toUnfoldable
                  $ ( Seq.map (badge selectedNodeIds)
                      (badges graph selectedNodeIds')
                    )
                )
Alexandre Delanoë's avatar
Alexandre Delanoë committed
214 215 216
              , H.br {}
              ]
            ]
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 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296
          , RH.div { className: "tab-content flex-space-between" }
            [ removeButton (Record.merge { buttonType: "primary"
                                         , rType: CandidateTerm
                                         , nodesMap
                                         , text: "Move as candidate" } commonProps) []
            , H.br {}
            , removeButton (Record.merge { buttonType: "danger"
                                         , nodesMap
                                         , rType: StopTerm
                                         , text: "Move as stop" } commonProps) []
            ]
          ]
        ]
      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
    cpt { graph
        , selectedNodeIds } _ = do
      selectedNodeIds' <- T.useLive T.unequal selectedNodeIds

      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"
             }
          (Seq.toUnfoldable $ Seq.map (badge selectedNodeIds)
           $ neighbourBadges graph selectedNodeIds'
          )
        ]


type RemoveButtonProps = (
    buttonType :: String
  , nodesMap   :: SigmaxT.NodesMap
  , rType      :: TermList
  , text       :: String
  | Common
  )

removeButton :: R2.Component RemoveButtonProps
removeButton = R.createElement removeButtonCpt

removeButtonCpt :: R.Component RemoveButtonProps
removeButtonCpt = here.component "removeButton" cpt
  where
    cpt { buttonType
        , graphId
        , metaData
        , nodesMap
        , reloadForest
        , removedNodeIds
        , rType
        , selectedNodeIds
        , session
        , text } _ = do
      selectedNodeIds' <- T.useLive T.unequal selectedNodeIds

      pure $ if Set.isEmpty selectedNodeIds' then
               RH.div {} []
             else
               RH.button { className: "btn btn-sm btn-" <> buttonType
                         , on: { click: onClickRemove selectedNodeIds' }
                         } [ RH.text text ]
      where
        onClickRemove selectedNodeIds' e = do
          let nodes = mapMaybe (\id -> Map.lookup id nodesMap)
                              $ Set.toUnfoldable selectedNodeIds'
          deleteNodes { graphId: graphId
                      , metaData: metaData
                      , nodes
                      , session: session
                      , termList: rType
                      , reloadForest }
297 298
          T.write_ selectedNodeIds' removedNodeIds
          T.write_ SigmaxT.emptyNodeIds selectedNodeIds
299 300 301



302
badge :: T.Box SigmaxT.NodeIds -> Record SigmaxT.Node -> R.Element
303
badge selectedNodeIds {id, label} =
304
  RH.a { className: "badge badge-pill badge-light"
305
       , on: { click: onClick }
306
       } [ RH.h6 {} [ RH.text label ] ]
307 308
  where
    onClick e = do
309
      T.write_ (Set.singleton id) selectedNodeIds
310

311 312
badges :: SigmaxT.SGraph -> SigmaxT.NodeIds -> Seq.Seq (Record SigmaxT.Node)
badges graph selectedNodeIds = SigmaxT.graphNodes $ SigmaxT.nodesById graph selectedNodeIds
313

314
neighbourBadges :: SigmaxT.SGraph -> SigmaxT.NodeIds -> Seq.Seq (Record SigmaxT.Node)
315 316
neighbourBadges graph selectedNodeIds = SigmaxT.neighbours graph selectedNodes' where
  selectedNodes' = SigmaxT.graphNodes $ SigmaxT.nodesById graph selectedNodeIds
317

318
type DeleteNodes =
319 320 321
  ( graphId      :: NodeID
  , metaData     :: GET.MetaData
  , nodes        :: Array (Record SigmaxT.Node)
322
  , reloadForest :: T.Box T2.Reload
323 324
  , session      :: Session
  , termList     :: TermList
325
  )
326

327
deleteNodes :: Record DeleteNodes -> Effect Unit
James Laver's avatar
James Laver committed
328
deleteNodes { graphId, metaData, nodes, session, termList, reloadForest } = do
329 330 331 332 333 334
  launchAff_ do
    patches <- (parTraverse (deleteNode termList session metaData) nodes) :: Aff (Array NTC.VersionedNgramsPatches)
    let mPatch = last patches
    case mPatch of
      Nothing -> pure unit
      Just (NTC.Versioned patch) -> do
335
        liftEffect $ T2.reload reloadForest
336

337
-- Why is this called delete node?
338 339 340 341 342
deleteNode :: TermList
           -> Session
           -> GET.MetaData
           -> Record SigmaxT.Node
           -> Aff NTC.VersionedNgramsPatches
343
deleteNode termList session (GET.MetaData metaData) node = do
344
    ret  <- NTC.putNgramsPatches coreParams versioned
345 346
    task <- NTC.postNgramsChartsAsync coreParams  -- TODO add task
    pure ret
347
  where
348
    nodeId :: NodeID
349
    nodeId = unsafePartial $ fromJust $ fromString node.id
350

351 352
    versioned :: NTC.VersionedNgramsPatches
    versioned = NTC.Versioned {version: metaData.list.version, data: np}
353

354
    coreParams :: NTC.CoreParams ()
355
    coreParams = {session, nodeId, listIds: [metaData.list.listId], tabType}
356

357 358
    tabNgramType :: CTabNgramType
    tabNgramType = modeTabType node.gargType
359

360 361
    tabType :: TabType
    tabType = TabCorpus (TabNgramType tabNgramType)
362

363 364
    term :: NTC.NgramsTerm
    term = NTC.normNgram tabNgramType node.label
365

366 367
    pt :: NTC.NgramsTablePatch
    pt = NTC.fromNgramsPatches np
368

369 370
    np :: NTC.NgramsPatches
    np = NTC.singletonPatchMap term $ NTC.NgramsPatch { patch_children: mempty, patch_list }
371

372
    patch_list :: NTC.Replace TermList
373
    patch_list = NTC.Replace { new: termList, old: MapTerm }
374

375 376
query :: SearchType
      -> Frontends
377 378 379
      -> GET.MetaData
      -> Session
      -> SigmaxT.NodesMap
380
      -> SigmaxT.NodeIds
381
      -> R.Element
382 383
query _ _ _ _ _ selectedNodeIds | Set.isEmpty selectedNodeIds = RH.div {} []
query searchType frontends (GET.MetaData metaData) session nodesMap selectedNodeIds =
384 385
  query' (head metaData.corpusId)
  where
386
    query' Nothing         = RH.div {} []
387 388 389 390 391 392 393 394
    query' (Just corpusId) =
      CGT.tabs { frontends
               , session
               , query: SearchQuery { query : concat $ toQuery <$> Set.toUnfoldable selectedNodeIds
                                    , expected: searchType
                                    }
               , sides: [side corpusId]
               }
395 396

    toQuery id = case Map.lookup id nodesMap of
397 398
      Nothing -> []
      Just n -> words n.label
399 400 401 402 403

    side corpusId = GET.GraphSideCorpus { corpusId
                                        , listId     : metaData.list.listId
                                        , corpusLabel: metaData.title
                                        }
404 405 406 407 408 409 410 411 412 413 414 415

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

            {-, RH.div { className: "col-md-12", id: "horizontal-checkbox" }
              [ RH.ul {}
                [ checkbox "Pubs"
                , checkbox "Projects"
                , checkbox "Patents"
                , checkbox "Others"
                ]
              ]
              -}
416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450
--------------------------------------------------------------------------


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.
-}