Commit 34352a7e authored by Przemyslaw Kaminski's avatar Przemyslaw Kaminski

[Graph] node removal works now

However, graph still needs to be refreshed after this is done.
parent b2cd1fd9
......@@ -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
}
......@@ -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
......
......@@ -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)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment