From 34352a7ee87f8c8db28316852e4c6871efecd388 Mon Sep 17 00:00:00 2001
From: Przemek Kaminski <pk@intrepidus.pl>
Date: Wed, 8 Jan 2020 10:16:44 +0100
Subject: [PATCH] [Graph] node removal works now
However, graph still needs to be refreshed after this is done.
---
.../Components/GraphExplorer/Sidebar.purs | 52 +++++++++++++------
.../Components/GraphExplorer/Types.purs | 19 ++++---
.../Components/NgramsTable/Core.purs | 5 +-
3 files changed, 53 insertions(+), 23 deletions(-)
diff --git a/src/Gargantext/Components/GraphExplorer/Sidebar.purs b/src/Gargantext/Components/GraphExplorer/Sidebar.purs
index 9ed41c22..af405433 100644
--- a/src/Gargantext/Components/GraphExplorer/Sidebar.purs
+++ b/src/Gargantext/Components/GraphExplorer/Sidebar.purs
@@ -8,14 +8,19 @@ import DOM.Simple.Console (log2)
import Data.Array (head)
import Data.Int (fromString)
import Data.Map as Map
-import Data.Maybe (Maybe(..))
+import Data.Maybe (Maybe(..), fromJust)
import Data.Sequence as Seq
import Data.Set as Set
import Data.Traversable (traverse_)
import Data.Tuple.Nested ((/\))
import Effect (Effect)
import Effect.Aff (Aff, launchAff_)
+import Partial.Unsafe (unsafePartial)
+import Reactix as R
+import Reactix.DOM.HTML as RH
+
import Gargantext.Components.GraphExplorer.Types as GET
+import Gargantext.Components.NgramsTable.Core as NTC
import Gargantext.Components.Nodes.Corpus.Graph.Tabs as GT
import Gargantext.Components.RandomText (words)
import Gargantext.Data.Array (mapMaybe)
@@ -23,10 +28,8 @@ import Gargantext.Ends (Frontends)
import Gargantext.Hooks.Sigmax.Types as SigmaxTypes
import Gargantext.Routes (SessionRoute(NodeAPI))
import Gargantext.Sessions (Session, delete)
-import Gargantext.Types (NodeType(..), TermList(..))
+import Gargantext.Types (CTabNgramType(..), NodeType(..), TabSubType(..), TabType(..), TermList(..), modeTabType)
import Gargantext.Utils.Reactix as R2
-import Reactix as R
-import Reactix.DOM.HTML as RH
type Props =
( frontends :: Frontends
@@ -63,10 +66,10 @@ sidebarCpt = R.hooksComponent "Sidebar" cpt
, RH.div { className: "tab-content" }
[
RH.button { className: "btn btn-danger"
- , on: { click: onClickRemove CandidateTerm props.session props.selectedNodeIds }}
+ , on: { click: onClickRemove CandidateTerm props.session props.metaData nodesMap props.selectedNodeIds }}
[ RH.text "Remove candidate" ]
, RH.button { className: "btn btn-danger"
- , on: { click: onClickRemove StopTerm props.session props.selectedNodeIds }}
+ , on: { click: onClickRemove StopTerm props.session props.metaData nodesMap props.selectedNodeIds }}
[ RH.text "Remove stop" ]
]
, RH.li { className: "nav-item" }
@@ -109,10 +112,10 @@ sidebarCpt = R.hooksComponent "Sidebar" cpt
, checked: true
, title: "Mark as completed" } ]
- onClickRemove rType session (selectedNodeIds /\ _) e = do
+ onClickRemove rType session metaData nodesMap (selectedNodeIds /\ _) e = do
log2 "[onClickRemove] selectedNodeIds" selectedNodeIds
- let nodeIds = mapMaybe fromString $ Set.toUnfoldable selectedNodeIds
- deleteNodes rType session nodeIds
+ let nodes = mapMaybe (\id -> Map.lookup id nodesMap) $ Set.toUnfoldable selectedNodeIds
+ deleteNodes rType session metaData nodes
@@ -133,12 +136,31 @@ neighbourBadges graph (selectedNodeIds /\ _) = SigmaxTypes.neighbours graph sele
where
selectedNodes = SigmaxTypes.graphNodes $ SigmaxTypes.nodesById graph selectedNodeIds
-deleteNodes :: TermList -> Session -> Array Int -> Effect Unit
-deleteNodes termList session nodeIds = do
- traverse_ (launchAff_ <<< deleteNode termList session) nodeIds
+deleteNodes :: TermList -> Session -> GET.MetaData -> Array (Record SigmaxTypes.Node) -> Effect Unit
+deleteNodes termList session metaData nodes = do
+ traverse_ (launchAff_ <<< deleteNode termList session metaData) nodes
-deleteNode :: TermList -> Session -> Int -> Aff Int
-deleteNode termList session nodeId = delete session $ NodeAPI Node (Just nodeId) ""
+deleteNode :: TermList -> Session -> GET.MetaData -> Record SigmaxTypes.Node -> Aff NTC.VersionedNgramsPatches
+deleteNode termList session (GET.MetaData metaData) node = NTC.putNgramsPatches coreParams versioned
+ where
+ nodeId :: Int
+ nodeId = unsafePartial $ fromJust $ fromString node.id
+ versioned :: NTC.VersionedNgramsPatches
+ versioned = NTC.Versioned {version: metaData.list.version, data: np}
+ coreParams :: NTC.CoreParams ()
+ coreParams = {session, nodeId: 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
+ pt :: NTC.NgramsTablePatch
+ pt = NTC.fromNgramsPatches np
+ 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: GraphTerm }
query :: Frontends -> GET.MetaData -> Session -> SigmaxTypes.NodesMap -> R.State SigmaxTypes.SelectedNodeIds -> R.Element
@@ -154,6 +176,6 @@ query frontends (GET.MetaData metaData) session nodesMap (selectedNodeIds /\ _)
Just n -> words n.label
side corpusId = GET.GraphSideCorpus {
corpusId
- , listId: metaData.listId
+ , listId: metaData.list.listId
, corpusLabel: metaData.title
}
diff --git a/src/Gargantext/Components/GraphExplorer/Types.purs b/src/Gargantext/Components/GraphExplorer/Types.purs
index 7610dafc..a7bdbfa8 100644
--- a/src/Gargantext/Components/GraphExplorer/Types.purs
+++ b/src/Gargantext/Components/GraphExplorer/Types.purs
@@ -37,6 +37,7 @@ derive instance newtypeEdge :: Newtype Edge _
type InclusiveRange t = { min :: t, max :: t }
type ListId = Int
+type Version = Int
type CorpusId = Int
type CorpusLabel = String
@@ -61,8 +62,10 @@ newtype MetaData = MetaData
title :: String
, legend :: Array Legend
, corpusId :: Array Int
- , listId :: ListId
- , version :: Int
+ , list :: {
+ listId :: ListId
+ , version :: Version
+ }
}
getLegend :: GraphData -> Maybe (Array Legend)
@@ -97,7 +100,7 @@ initialGraphData = GraphData {
nodes: []
, edges: []
, sides: []
- , metaData : Just $ MetaData {title : "", legend : [], corpusId : [], listId : 0, version : 0}
+ , metaData : Just $ MetaData {title : "", legend : [], corpusId : [], list: {listId : 0, version : 0}}
}
instance decodeJsonGraphData :: DecodeJson GraphData where
@@ -108,7 +111,8 @@ instance decodeJsonGraphData :: DecodeJson GraphData where
-- TODO: sides
metadata <- obj .: "metadata"
corpusIds <- metadata .: "corpusId"
- listId' <- metadata .: "listId"
+ list <- metadata .: "list"
+ listId' <- list .: "listId"
metaData <- obj .: "metadata"
let side x = GraphSideCorpus { corpusId: x, corpusLabel: "Publications", listId : listId'}
let sides = side <$> corpusIds
@@ -133,9 +137,10 @@ instance decodeJsonMetaData :: DecodeJson MetaData where
title <- obj .: "title"
legend <- obj .: "legend"
corpusId <- obj .: "corpusId"
- listId <- obj .: "listId"
- version <- obj .: "version"
- pure $ MetaData { title, legend, corpusId, listId, version}
+ list <- obj .: "list"
+ listId <- list .: "listId"
+ version <- list .: "version"
+ pure $ MetaData { title, legend, corpusId, list: {listId, version}}
instance decodeJsonLegend :: DecodeJson Legend where
diff --git a/src/Gargantext/Components/NgramsTable/Core.purs b/src/Gargantext/Components/NgramsTable/Core.purs
index defbb567..82fc6e8c 100644
--- a/src/Gargantext/Components/NgramsTable/Core.purs
+++ b/src/Gargantext/Components/NgramsTable/Core.purs
@@ -15,6 +15,7 @@ module Gargantext.Components.NgramsTable.Core
, findNgramTermList
, Version
, Versioned(..)
+ , VersionedNgramsPatches
, VersionedNgramsTable
, CoreState
, highlightNgrams
@@ -42,6 +43,7 @@ module Gargantext.Components.NgramsTable.Core
, _parent
, _root
, commitPatch
+ , putNgramsPatches
, syncPatches
, addNewNgram
)
@@ -507,6 +509,7 @@ applyPatchMap applyPatchValue (PatchMap p) = mapWithIndex f
Just pv -> applyPatchValue pv v
type NgramsPatches = PatchMap NgramsTerm NgramsPatch
+type VersionedNgramsPatches = Versioned NgramsPatches
type NewElems = Map NgramsTerm TermList
@@ -618,7 +621,7 @@ addNewNgram ngrams list =
{ ngramsPatches: mempty
, ngramsNewElems: Map.singleton ngrams list }
-putNgramsPatches :: forall s. CoreParams s -> Versioned NgramsPatches -> Aff (Versioned NgramsPatches)
+putNgramsPatches :: forall s. CoreParams s -> VersionedNgramsPatches -> Aff VersionedNgramsPatches
putNgramsPatches {session, nodeId, listIds, tabType} = put session putNgrams
where putNgrams = PutNgrams tabType (head listIds) Nothing (Just nodeId)
--
2.21.0