Sidebar.purs 16.1 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.GraphExplorer.Types as GET
27
import Gargantext.Components.GraphExplorer.Legend as Legend
28
import Gargantext.Components.NgramsTable.Core as NTC
29
import Gargantext.Components.Nodes.Corpus.Graph.Tabs (tabs) as CGT
30
import Gargantext.Components.RandomText (words)
31
import Gargantext.Components.Search (SearchType(..), SearchQuery(..))
32
import Gargantext.Data.Array (mapMaybe)
33
import Gargantext.Ends (Frontends)
34
import Gargantext.Hooks.Sigmax.Types as SigmaxT
35
import Gargantext.Sessions (Session)
36
import Gargantext.Types (CTabNgramType, NodeID, TabSubType(..), TabType(..), TermList(..), modeTabType)
37
import Gargantext.Utils.Reactix as R2
38
import Gargantext.Utils.Toestand as T2
39

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

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

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

60 61
sidebar :: R2.Component Props
sidebar = R.createElement sidebarCpt
62

63
sidebarCpt :: R.Component Props
64
sidebarCpt = here.component "sidebar" cpt
65
  where
66
    cpt props@{ sideTab } _ = do
67 68 69 70 71
      sideTab' <- T.useLive T.unequal sideTab

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

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

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

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

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

108
type SideTabProps = Props
109

110 111
sideTabLegend :: R2.Component SideTabProps
sideTabLegend = R.createElement sideTabLegendCpt
112

113 114 115 116 117 118 119 120
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
        ]
121

122 123
sideTabData :: R2.Component SideTabProps
sideTabData = R.createElement sideTabDataCpt
124

125 126 127 128 129 130 131 132 133 134
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" }
135 136 137 138 139 140 141
          [ query { frontends: props.frontends
                  , metaData: props.metaData
                  , nodesMap: SigmaxT.nodesGraphMap props.graph
                  , searchType: SearchDoc
                  , selectedNodeIds: selectedNodeIds'
                  , session: props.session
                  } []
142 143 144 145 146 147 148 149 150
          ]
        ]
        where
          checkbox text = RH.li {}
                          [ RH.span {} [ RH.text text ]
                          , RH.input { type: "checkbox"
                                     , className: "checkbox"
                                     , defaultChecked: true
                                     , title: "Mark as completed" } ]
151

152 153 154 155 156 157 158 159 160 161 162 163 164

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 []
165 166 167 168 169 170 171
        , query { frontends: props.frontends
                , metaData: props.metaData
                , nodesMap: SigmaxT.nodesGraphMap props.graph
                , searchType: SearchContact
                , selectedNodeIds: selectedNodeIds'
                , session: props.session
                } []
172
        ]
173 174 175


-------------------------------------------
176 177
-- TODO
-- selectedNodes :: Record Props -> Map.Map String Nodes -> R.Element
178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196

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
197 198 199
          [ RH.ul { className: "nav nav-tabs d-flex justify-content-center"
                  , id: "myTab"
                  , role: "tablist" }
Alexandre Delanoë's avatar
Alexandre Delanoë committed
200
            [ RH.div { className: "tab-content" }
201
              [ RH.div { className: "d-flex flex-wrap justify-content-center"
Alexandre Delanoë's avatar
Alexandre Delanoë committed
202
                       , role: "tabpanel" }
203 204 205 206 207
                ( Seq.toUnfoldable
                  $ ( Seq.map (badge selectedNodeIds)
                      (badges graph selectedNodeIds')
                    )
                )
Alexandre Delanoë's avatar
Alexandre Delanoë committed
208 209 210
              , H.br {}
              ]
            ]
211
          , RH.div { className: "tab-content flex-space-between" }
212 213 214 215
            [ updateTermButton (Record.merge { buttonType: "primary"
                                             , rType: CandidateTerm
                                             , nodesMap
                                             , text: "Move as candidate" } commonProps) []
216
            , H.br {}
217 218 219 220
            , updateTermButton (Record.merge { buttonType: "danger"
                                             , nodesMap
                                             , rType: StopTerm
                                             , text: "Move as stop" } commonProps) []
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
            ]
          ]
        ]
      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'
          )
        ]


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

257 258 259 260
updateTermButton :: R2.Component UpdateTermButtonProps
updateTermButton = R.createElement updateTermButtonCpt
updateTermButtonCpt :: R.Component UpdateTermButtonProps
updateTermButtonCpt = here.component "updateTermButton" cpt
261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283
  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'
284
          sendPatches { graphId: graphId
285 286 287 288 289
                      , metaData: metaData
                      , nodes
                      , session: session
                      , termList: rType
                      , reloadForest }
290 291
          T.write_ selectedNodeIds' removedNodeIds
          T.write_ SigmaxT.emptyNodeIds selectedNodeIds
292 293 294



295
badge :: T.Box SigmaxT.NodeIds -> Record SigmaxT.Node -> R.Element
296
badge selectedNodeIds {id, label} =
297
  RH.a { className: "badge badge-pill badge-light"
298
       , on: { click: onClick }
299
       } [ RH.h6 {} [ RH.text label ] ]
300 301
  where
    onClick e = do
302
      T.write_ (Set.singleton id) selectedNodeIds
303

304 305
badges :: SigmaxT.SGraph -> SigmaxT.NodeIds -> Seq.Seq (Record SigmaxT.Node)
badges graph selectedNodeIds = SigmaxT.graphNodes $ SigmaxT.nodesById graph selectedNodeIds
306

307
neighbourBadges :: SigmaxT.SGraph -> SigmaxT.NodeIds -> Seq.Seq (Record SigmaxT.Node)
308 309
neighbourBadges graph selectedNodeIds = SigmaxT.neighbours graph selectedNodes' where
  selectedNodes' = SigmaxT.graphNodes $ SigmaxT.nodesById graph selectedNodeIds
310

311
type SendPatches =
312 313 314
  ( graphId      :: NodeID
  , metaData     :: GET.MetaData
  , nodes        :: Array (Record SigmaxT.Node)
315
  , reloadForest :: T2.ReloadS
316 317
  , session      :: Session
  , termList     :: TermList
318
  )
319

320 321
sendPatches :: Record SendPatches -> Effect Unit
sendPatches { graphId, metaData, nodes, session, termList, reloadForest } = do
322
  launchAff_ do
323
    patches <- (parTraverse (sendPatch termList session metaData) nodes) :: Aff (Array NTC.VersionedNgramsPatches)
324 325 326 327
    let mPatch = last patches
    case mPatch of
      Nothing -> pure unit
      Just (NTC.Versioned patch) -> do
328
        liftEffect $ T2.reload reloadForest
329

330
-- Why is this called delete node?
331 332 333 334 335 336
sendPatch :: TermList
          -> Session
          -> GET.MetaData
          -> Record SigmaxT.Node
          -> Aff NTC.VersionedNgramsPatches
sendPatch termList session (GET.MetaData metaData) node = do
337
    ret  <- NTC.putNgramsPatches coreParams versioned
338 339
    task <- NTC.postNgramsChartsAsync coreParams  -- TODO add task
    pure ret
340
  where
341
    nodeId :: NodeID
342
    nodeId = unsafePartial $ fromJust $ fromString node.id
343

344 345
    versioned :: NTC.VersionedNgramsPatches
    versioned = NTC.Versioned {version: metaData.list.version, data: np}
346

347
    coreParams :: NTC.CoreParams ()
348
    coreParams = {session, nodeId, listIds: [metaData.list.listId], tabType}
349

350 351
    tabNgramType :: CTabNgramType
    tabNgramType = modeTabType node.gargType
352

353 354
    tabType :: TabType
    tabType = TabCorpus (TabNgramType tabNgramType)
355

356 357
    term :: NTC.NgramsTerm
    term = NTC.normNgram tabNgramType node.label
358

359 360
    pt :: NTC.NgramsTablePatch
    pt = NTC.fromNgramsPatches np
361

362 363
    np :: NTC.NgramsPatches
    np = NTC.singletonPatchMap term $ NTC.NgramsPatch { patch_children: mempty, patch_list }
364

365
    patch_list :: NTC.Replace TermList
366
    patch_list = NTC.Replace { new: termList, old: MapTerm }
367

368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 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
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
                                          }
418 419 420 421 422 423 424 425 426 427 428 429

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

            {-, RH.div { className: "col-md-12", id: "horizontal-checkbox" }
              [ RH.ul {}
                [ checkbox "Pubs"
                , checkbox "Projects"
                , checkbox "Patents"
                , checkbox "Others"
                ]
              ]
              -}
430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464
--------------------------------------------------------------------------


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