module Gargantext.Components.GraphExplorer.Sidebar -- (Props, sidebar) where import Gargantext.Prelude import Control.Parallel (parTraverse) import Data.Array (head, last, concat) import Data.Array as A import Data.Either (Either(..)) import Data.Foldable as F import Data.Int (fromString) import Data.Map as Map import Data.Maybe (Maybe(..), fromJust) import Data.Sequence as Seq import Data.Set as Set import Effect (Effect) import Effect.Aff (launchAff_) import Effect.Class (liftEffect) import Gargantext.Components.App.Data (Boxes) import Gargantext.Components.GraphExplorer.Legend as Legend import Gargantext.Components.GraphExplorer.Sidebar.Types as GEST import Gargantext.Components.GraphExplorer.Types as GET import Gargantext.Components.Lang (Lang(..)) import Gargantext.Components.NgramsTable.Core as NTC import Gargantext.Components.Nodes.Corpus.Graph.Tabs (tabs) as CGT import Gargantext.Components.RandomText (words) import Gargantext.Components.Search (SearchType(..), SearchQuery(..)) import Gargantext.Config.REST (AffRESTError) import Gargantext.Data.Array (mapMaybe) import Gargantext.Ends (Frontends) import Gargantext.Hooks.Sigmax.Types as SigmaxT import Gargantext.Sessions (Session) import Gargantext.Types (CTabNgramType, FrontendError(..), NodeID, TabSubType(..), TabType(..), TermList(..), modeTabType) import Gargantext.Utils.Reactix as R2 import Gargantext.Utils.Toestand as T2 import Math as Math 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 here :: R2.Here here = R2.here "Gargantext.Components.GraphExplorer.Sidebar" type Common = ( boxes :: Boxes , graphId :: NodeID , metaData :: GET.MetaData , session :: Session ) type Props = ( frontends :: Frontends , graph :: SigmaxT.SGraph | Common ) sidebar :: R2.Component Props sidebar = R.createElement sidebarCpt sidebarCpt :: R.Component Props sidebarCpt = here.component "sidebar" cpt where cpt props@{ boxes: { sidePanelGraph } } _ = do { sideTab } <- GEST.focusedSidePanel sidePanelGraph sideTab' <- T.useLive T.unequal sideTab pure $ RH.div { id: "sp-container" } [ sideTabNav { sideTab , sideTabs: [GET.SideTabLegend, GET.SideTabData, GET.SideTabCommunity] } [] , case sideTab' of GET.SideTabLegend -> sideTabLegend sideTabProps [] GET.SideTabData -> sideTabData sideTabProps [] GET.SideTabCommunity -> sideTabCommunity sideTabProps [] ] where sideTabProps = RX.pick props :: Record Props type SideTabNavProps = ( sideTab :: T.Box GET.SideTab , sideTabs :: Array GET.SideTab ) sideTabNav :: R2.Component SideTabNavProps sideTabNav = R.createElement sideTabNavCpt sideTabNavCpt :: R.Component SideTabNavProps sideTabNavCpt = here.component "sideTabNav" cpt where cpt { sideTab, sideTabs } _ = do sideTab' <- T.useLive T.unequal sideTab pure $ R.fragment [ H.div { className: "text-primary center"} [H.text ""] , H.div { className: "nav nav-tabs"} (liItem sideTab' <$> sideTabs) -- , H.div {className: "center"} [ H.text "Doc sideTabs"] ] where liItem :: GET.SideTab -> GET.SideTab -> R.Element liItem sideTab' tab = H.div { className : "nav-item nav-link" <> if tab == sideTab' then " active" else "" , on: { click: \_ -> T.write_ tab sideTab } } [ H.text $ show tab ] sideTabLegend :: R2.Component Props sideTabLegend = R.createElement sideTabLegendCpt sideTabLegendCpt :: R.Component Props sideTabLegendCpt = here.component "sideTabLegend" cpt where cpt { metaData: GET.MetaData { legend } } _ = do pure $ H.div {} [ Legend.legend { items: Seq.fromFoldable legend } , documentation EN ] sideTabData :: R2.Component Props sideTabData = R.createElement sideTabDataCpt sideTabDataCpt :: R.Component Props sideTabDataCpt = here.component "sideTabData" cpt where cpt props@{ boxes: { sidePanelGraph } } _ = do { selectedNodeIds } <- GEST.focusedSidePanel sidePanelGraph selectedNodeIds' <- T.useLive T.unequal selectedNodeIds pure $ RH.div {} [ selectedNodes (Record.merge { nodesMap: SigmaxT.nodesGraphMap props.graph } props) [] , neighborhood props [] , RH.div { className: "col-md-12", id: "query" } [ query { frontends: props.frontends , metaData: props.metaData , nodesMap: SigmaxT.nodesGraphMap props.graph , searchType: SearchDoc , selectedNodeIds: selectedNodeIds' , session: props.session } [] ] ] sideTabCommunity :: R2.Component Props sideTabCommunity = R.createElement sideTabCommunityCpt sideTabCommunityCpt :: R.Component Props sideTabCommunityCpt = here.component "sideTabCommunity" cpt where cpt props@{ boxes: { sidePanelGraph } , frontends } _ = do { selectedNodeIds } <- GEST.focusedSidePanel sidePanelGraph selectedNodeIds' <- T.useLive T.unequal selectedNodeIds pure $ RH.div { className: "col-md-12", id: "query" } [ selectedNodes (Record.merge { nodesMap: SigmaxT.nodesGraphMap props.graph } props) [] , neighborhood props [] , query { frontends , metaData: props.metaData , nodesMap: SigmaxT.nodesGraphMap props.graph , searchType: SearchContact , selectedNodeIds: selectedNodeIds' , session: props.session } [] ] ------------------------------------------- -- TODO -- selectedNodes :: Record Props -> Map.Map String Nodes -> R.Element 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@{ boxes: { sidePanelGraph } , graph , nodesMap } _ = do { selectedNodeIds } <- GEST.focusedSidePanel sidePanelGraph selectedNodeIds' <- T.useLive T.unequal selectedNodeIds pure $ R2.row [ R2.col 12 [ RH.ul { className: "nav nav-tabs d-flex justify-content-center" , id: "myTab" , role: "tablist" } [ RH.div { className: "tab-content" } [ RH.div { className: "d-flex flex-wrap justify-content-center" , role: "tabpanel" } ( Seq.toUnfoldable $ ( 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') ) , H.br {} ] ] , RH.div { className: "tab-content flex-space-between" } [ updateTermButton (Record.merge { buttonType: "primary" , rType: CandidateTerm , nodesMap , text: "Move as candidate" } commonProps) [] , H.br {} , updateTermButton (Record.merge { buttonType: "danger" , nodesMap , rType: StopTerm , text: "Move as stop" } commonProps) [] ] ] ] where commonProps = RX.pick props :: Record Common data TagCloudState = Folded | Unfolded derive instance Eq TagCloudState flipFold :: TagCloudState -> TagCloudState flipFold Folded = Unfolded flipFold Unfolded = Folded neighborhood :: R2.Component Props neighborhood = R.createElement neighborhoodCpt neighborhoodCpt :: R.Component Props neighborhoodCpt = here.component "neighborhood" cpt where cpt { boxes: { sidePanelGraph } , graph } _ = do { selectedNodeIds } <- GEST.focusedSidePanel sidePanelGraph selectedNodeIds' <- T.useLive T.unequal selectedNodeIds state <- T.useBox Folded state' <- T.useLive T.unequal state let numberOfBadgesToShowWhenFolded = 5 badges' = neighbourBadges graph selectedNodeIds' 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)) orderedBadges = A.sortWith (\n -> -n.size) $ Seq.toUnfoldable badges' -- reverse sort (largest size first) displayBadges = case state' of Folded -> A.take numberOfBadgesToShowWhenFolded orderedBadges Unfolded -> orderedBadges stateText = case state' of Folded -> "Show more" Unfolded -> "Show less" showFoldedTooltip = A.length orderedBadges > numberOfBadgesToShowWhenFolded 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" } ((\node -> badge { maxSize, minSize, node, selectedNodeIds }) <$> displayBadges) <> RH.a { className: "" -- with empty class name, bootstrap renders this blue , on: { click: toggleUnfold state} } [ RH.text stateText ] ] where toggleUnfold state = T.modify_ flipFold state type UpdateTermButtonProps = ( buttonType :: String , nodesMap :: SigmaxT.NodesMap , rType :: TermList , text :: String | Common ) updateTermButton :: R2.Component UpdateTermButtonProps updateTermButton = R.createElement updateTermButtonCpt updateTermButtonCpt :: R.Component UpdateTermButtonProps updateTermButtonCpt = here.component "updateTermButton" cpt where cpt { boxes: { errors , reloadForest , sidePanelGraph } , buttonType , graphId , metaData , nodesMap , rType , session , text } _ = do { removedNodeIds, selectedNodeIds } <- GEST.focusedSidePanel sidePanelGraph 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 removedNodeIds selectedNodeIds selectedNodeIds' } } [ RH.text text ] where onClickRemove removedNodeIds selectedNodeIds selectedNodeIds' _ = do let nodes = mapMaybe (\id -> Map.lookup id nodesMap) $ Set.toUnfoldable selectedNodeIds' sendPatches { errors , graphId: graphId , metaData: metaData , nodes , session: session , termList: rType , reloadForest } T.write_ selectedNodeIds' removedNodeIds T.write_ SigmaxT.emptyNodeIds selectedNodeIds type BadgeProps = ( maxSize :: Number , minSize :: Number , node :: Record SigmaxT.Node , selectedNodeIds :: T.Box SigmaxT.NodeIds ) badge :: R2.Leaf BadgeProps badge = R2.leafComponent badgeCpt badgeCpt :: R.Component BadgeProps badgeCpt = here.component "badge" cpt where 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) 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 badges :: SigmaxT.SGraph -> SigmaxT.NodeIds -> Seq.Seq (Record SigmaxT.Node) badges graph selectedNodeIds = SigmaxT.graphNodes $ SigmaxT.nodesById graph selectedNodeIds neighbourBadges :: SigmaxT.SGraph -> SigmaxT.NodeIds -> Seq.Seq (Record SigmaxT.Node) neighbourBadges graph selectedNodeIds = SigmaxT.neighbours graph selectedNodes' where selectedNodes' = SigmaxT.graphNodes $ SigmaxT.nodesById graph selectedNodeIds type SendPatches = ( errors :: T.Box (Array FrontendError) , graphId :: NodeID , metaData :: GET.MetaData , nodes :: Array (Record SigmaxT.Node) , reloadForest :: T2.ReloadS , session :: Session , termList :: TermList ) sendPatches :: Record SendPatches -> Effect Unit sendPatches { errors, metaData, nodes, reloadForest, session, termList } = do launchAff_ do patches <- (parTraverse (sendPatch termList session metaData) nodes) -- :: Aff (Array NTC.VersionedNgramsPatches) let mPatch = last patches case mPatch of Nothing -> pure unit Just (Left err) -> liftEffect $ do T.modify_ (A.cons $ FRESTError { error: err }) errors here.log2 "[sendPatches] RESTError" err Just (Right (NTC.Versioned _patch)) -> do liftEffect $ T2.reload reloadForest -- Why is this called delete node? sendPatch :: TermList -> Session -> GET.MetaData -> Record SigmaxT.Node -> AffRESTError NTC.VersionedNgramsPatches sendPatch termList session (GET.MetaData metaData) node = do eRet <- NTC.putNgramsPatches coreParams versioned case eRet of Left err -> pure $ Left err Right ret -> do _task <- NTC.postNgramsChartsAsync coreParams -- TODO add task pure $ Right ret where nodeId :: NodeID nodeId = unsafePartial $ fromJust $ fromString node.id versioned :: NTC.VersionedNgramsPatches versioned = NTC.Versioned {version: metaData.list.version, data: np} coreParams :: NTC.CoreParams () coreParams = {session, nodeId, listIds: [metaData.list.listId], tabType} tabNgramType :: CTabNgramType tabNgramType = modeTabType node.gargType tabType :: TabType tabType = TabCorpus (TabNgramType tabNgramType) term :: NTC.NgramsTerm term = NTC.normNgram tabNgramType node.label np :: NTC.NgramsPatches np = NTC.singletonPatchMap term $ NTC.NgramsPatch { patch_children: mempty, patch_list } patch_list :: NTC.Replace TermList patch_list = NTC.Replace { new: termList, old: MapTerm } 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 } ------------------------------------------------------------------------ {-, RH.div { className: "col-md-12", id: "horizontal-checkbox" } [ RH.ul {} [ checkbox "Pubs" , checkbox "Projects" , checkbox "Patents" , checkbox "Others" ] ] -} -------------------------------------------------------------------------- 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. -}