Skip to content

P
purescript-gargantext
Commit 86165573 authored by Nicolas Pouillard's avatar Nicolas Pouillard
Browse files
Options

[NGRAMS-TABLE] multi select, scoreType, ngram normalisation

parent ed3127bc
Hide whitespace changes
Inline Side-by-side
Showing with 250 additions and 109 deletions
src/Gargantext/Components/Annotation/AnnotatedField.purs
View file @ 86165573
......@@ -24,7 +24,7 @@ import Reactix.SyntheticEvent as E
import Gargantext.Types (CTabNgramType(..), TermList)
import Gargantext.Components.Annotation.Utils ( termBootstrapClass )
import Gargantext.Components.NgramsTable.Core (NgramsTable, NgramsTerm, findNgramTermList, highlightNgrams)
import Gargantext.Components.NgramsTable.Core (NgramsTable, NgramsTerm, findNgramTermList, highlightNgrams, normNgram)
import Gargantext.Components.Annotation.Menu ( AnnotationMenu, annotationMenu, MenuType(..) )
import Gargantext.Utils.Reactix as R2
import Gargantext.Utils.Selection as Sel
......@@ -56,7 +56,7 @@ annotatedFieldComponent = R.hooksComponent "AnnotatedField" cpt
let x = E.clientX event
y = E.clientY event
setList t = do
setTermList text' (Just list) t
setTermList (normNgram CTabTerms text') (Just list) t
setMenu (const Nothing)
setMenu (const $ Just {x, y, list: Just list, menuType: SetTermListItem, setList} )
......@@ -78,9 +78,10 @@ maybeShowMenu setMenu setTermList ngrams event = do
sel' -> do
let x = E.clientX event
y = E.clientY event
list = findNgramTermList CTabTerms ngrams sel'
n = normNgram CTabTerms sel'
list = findNgramTermList ngrams n
setList t = do
setTermList sel' list t
setTermList n list t
setMenu (const Nothing)
E.preventDefault event
setMenu (const $ Just { x, y, list, menuType: NewNgram, setList })
......
src/Gargantext/Components/DocsTable.purs
View file @ 86165573
......@@ -285,7 +285,7 @@ pageCpt = R.memo' $ R.hooksComponent "G.C.DocsTable.pageCpt" cpt where
pure $ T.table
{ rows: rows localCategories
, container: T.defaultContainer { title: "Documents" }
, params, colNames, totalRecords }
, params, colNames, totalRecords, wrapColElts }
where
sid = sessionId session
gi Favorite = "glyphicon glyphicon-star"
......@@ -296,6 +296,7 @@ pageCpt = R.memo' $ R.hooksComponent "G.C.DocsTable.pageCpt" cpt where
| Just cid <- corpusId = Routes.CorpusDocument sid cid listId
| otherwise = Routes.Document sid listId
colNames = T.ColumnName <$> [ "Map", "Stop", "Date", "Title", "Source"]
wrapColElts = const identity
getCategory (localCategories /\ _) {_id, category} = maybe category identity (localCategories ^. at _id)
rows localCategories = row <$> documents
where
......
src/Gargantext/Components/FacetsTable.purs
View file @ 86165573
......@@ -277,11 +277,12 @@ pageCpt :: R.Component PageProps
pageCpt = R.staticComponent "G.C.FacetsTable.Page" cpt
where
cpt {totalRecords, container, deletions, documents, session, path: path@({nodeId, listId, query} /\ setPath)} _ = do
T.table { rows, container, colNames, totalRecords, params }
T.table { rows, container, colNames, totalRecords, params, wrapColElts }
where
setParams f = setPath $ \p@{params: ps} -> p {params = f ps}
params = (fst path).params /\ setParams
colNames = T.ColumnName <$> [ "", "Date", "Title", "Source", "Authors", "Delete" ]
wrapColElts = const identity
-- TODO: how to interprete other scores?
gi Favorite = "glyphicon glyphicon-star-empty"
gi _ = "glyphicon glyphicon-star"
......
src/Gargantext/Components/NgramsTable.purs
View file @ 86165573
......@@ -7,8 +7,10 @@ import Prelude
( class Show, Unit, bind, const, discard, identity, map, mempty, not
, pure, show, unit, (#), ($), (&&), (+), (/=), (<$>), (<<<), (<>), (=<<)
, (==), (||) )
import Control.Monad (unless)
import Data.Array as A
import Data.Lens (Lens', to, view, (%~), (.~), (^.), (^..))
import Data.FunctorWithIndex (mapWithIndex)
import Data.Lens (Lens', to, view, (%~), (.~), (^.), (^..), (^?))
import Data.Lens.Common (_Just)
import Data.Lens.At (at)
import Data.Lens.Index (ix)
......@@ -17,9 +19,11 @@ import Data.Lens.Record (prop)
import Data.List as List
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..), maybe)
import Data.Maybe (Maybe(..), maybe, fromJust)
import Data.Monoid.Additive (Additive(..))
import Data.Ord.Down (Down(..))
import Data.Set (Set)
import Data.Set as Set
import Data.Symbol (SProxy(..))
import Data.Tuple (Tuple(..), snd)
import Data.Tuple.Nested ((/\))
......@@ -37,17 +41,21 @@ import Gargantext.Types
, readTermSize, termLists, termSizes)
import Gargantext.Components.AutoUpdate (autoUpdateElt)
import Gargantext.Components.NgramsTable.Core
( CoreState, NgramsElement(..), NgramsPatch(..)
, NgramsTable, NgramsTerm, PageParams, Replace(..), Versioned(..)
( CoreState, NgramsElement(..), NgramsPatch(..), NgramsTablePatch
, NgramsTable, NgramsTerm, PageParams, Replace, Versioned(..)
, VersionedNgramsTable, _NgramsElement, _NgramsTable, _children
, _list, _ngrams, _occurrences, _root, addNewNgram, applyNgramsTablePatch
, applyPatchSet, commitPatch, convOrderBy, initialPageParams, loadNgramsTable
, patchSetFromMap, replace, singletonNgramsTablePatch )
, patchSetFromMap, replace, singletonNgramsTablePatch, isEmptyNgramsTablePatch
, normNgram, ngramsTermText, fromNgramsPatches, PatchMap(..), rootsOf )
import Gargantext.Components.Loader (loader)
import Gargantext.Components.Table as T
import Gargantext.Sessions (Session)
import Gargantext.Utils.Reactix as R2
import Partial.Unsafe (unsafePartial)
import Unsafe.Coerce (unsafeCoerce)
type State =
CoreState
( ngramsParent :: Maybe NgramsTerm -- Nothing means we are not currently grouping terms
......@@ -56,48 +64,86 @@ type State =
-- This updates the children of `ngramsParent`,
-- ngrams set to `true` are to be added, and `false` to
-- be removed.
, ngramsSelection :: Set NgramsTerm
-- ^ The set of selected checkboxes of the first column.
, ngramsSelectAll :: Boolean
-- ^ The checkbox to select all the checkboxes of the first column.
)
_ngramsChildren :: forall row. Lens' { ngramsChildren :: Map NgramsTerm Boolean | row } (Map NgramsTerm Boolean)
_ngramsChildren = prop (SProxy :: SProxy "ngramsChildren")
_ngramsSelectAll :: forall row. Lens' { ngramsSelectAll :: Boolean | row } Boolean
_ngramsSelectAll = prop (SProxy :: SProxy "ngramsSelectAll")
_ngramsSelection :: forall row. Lens' { ngramsSelection :: Set NgramsTerm | row } (Set NgramsTerm)
_ngramsSelection = prop (SProxy :: SProxy "ngramsSelection")
initialState :: VersionedNgramsTable -> State
initialState (Versioned {version}) =
{ ngramsTablePatch: mempty
, ngramsVersion: version
, ngramsParent: Nothing
, ngramsChildren: mempty
, ngramsSelectAll: false
, ngramsSelection: mempty
}
data Action
= SetTermListItem NgramsTerm (Replace TermList)
= CommitPatch NgramsTablePatch
| SetParentResetChildren (Maybe NgramsTerm)
-- ^ This sets `ngramsParent` and resets `ngramsChildren`.
| ToggleChild Boolean NgramsTerm
-- ^ Toggles the NgramsTerm in the `PatchSet` `ngramsChildren`.
-- If the `Boolean` is `true` it means we want to add it if it is not here,
-- if it is `false` it is meant to be removed if not here.
| AddTermChildren -- NgramsTable
-- ^ The NgramsTable argument is here as a cache of `ngramsTablePatch`
-- applied to `initTable`.
-- TODO more docs
| AddTermChildren
| Refresh
| AddNewNgram NgramsTerm
| ToggleSelect NgramsTerm
-- ^ Toggles the NgramsTerm in the `Set` `ngramsSelection`.
| ToggleSelectAll
setTermListA :: NgramsTerm -> Replace TermList -> Action
setTermListA n patch_list =
CommitPatch $
singletonNgramsTablePatch n $
NgramsPatch { patch_list, patch_children: mempty }
setTermListSetA :: NgramsTable -> Set NgramsTerm -> TermList -> Action
setTermListSetA ngramsTable ns new_list =
CommitPatch $ fromNgramsPatches $ PatchMap $ mapWithIndex f $ toMap ns
where
f :: NgramsTerm -> Unit -> NgramsPatch
f n unit = NgramsPatch { patch_list, patch_children: mempty }
where
cur_list = ngramsTable ^? at n <<< _Just <<< _NgramsElement <<< _list
patch_list = replace (unsafePartial (fromJust cur_list)) new_list
toMap :: forall a. Set a -> Map a Unit
toMap = unsafeCoerce
-- TODO https://github.com/purescript/purescript-ordered-collections/pull/21
-- toMap = Map.fromFoldable
addNewNgramA :: NgramsTerm -> Action
addNewNgramA ngram = CommitPatch $ addNewNgram ngram CandidateTerm
type Dispatch = Action -> Effect Unit
tableContainer :: { path :: R.State PageParams
, dispatch :: Dispatch
, ngramsParent :: Maybe NgramsTerm
, ngramsChildren :: Map NgramsTerm Boolean
, ngramsTable :: NgramsTable
tableContainer :: { path :: R.State PageParams
, dispatch :: Dispatch
, ngramsParent :: Maybe NgramsTerm
, ngramsChildren :: Map NgramsTerm Boolean
, ngramsSelection :: Set NgramsTerm
, ngramsTable :: NgramsTable
, tabNgramType :: CTabNgramType
}
-> Record T.TableContainerProps -> R.Element
tableContainer { path: {searchQuery, termListFilter, termSizeFilter} /\ setPath
, dispatch
, ngramsParent
, ngramsChildren
, ngramsSelection
, ngramsTable: ngramsTableCache
, tabNgramType
} props =
H.div {className: "container-fluid"}
[ H.div {className: "jumbotron1"}
......@@ -119,7 +165,8 @@ tableContainer { path: {searchQuery, termListFilter, termSizeFilter} /\ setPath
, H.div {} (
if A.null props.tableBody && searchQuery /= "" then [
H.button { className: "btn btn-primary"
, on: {click: const $ dispatch $ AddNewNgram searchQuery}}
, on: {click: const $ dispatch $ addNewNgramA $ normNgram tabNgramType searchQuery}
}
[ H.text ("Add " <> searchQuery) ]
] else [])]
, H.div {className: "col-md-2", style: {marginTop : "6px"}}
......@@ -141,7 +188,20 @@ tableContainer { path: {searchQuery, termListFilter, termSizeFilter} /\ setPath
[ props.pageSizeDescription
, props.pageSizeControl
, H.text " items / "
, props.paginationLinks]]]]
, props.paginationLinks]]
, H.div {className: "col-md-1", style: {marginTop : "6px", marginBottom : "1px"}}
[ H.li {className: " list-group-item"}
[ H.button { className: "btn btn-primary"
, on: {click: const $ dispatch $ setTermListSetA ngramsTableCache ngramsSelection GraphTerm }
}
[ H.text "Map" ]
, H.button { className: "btn btn-primary"
, on: {click: const $ dispatch $ setTermListSetA ngramsTableCache ngramsSelection StopTerm }
}
[ H.text "Stop" ]
]
]
]]
, H.div {}
(maybe [] (\ngrams ->
let
......@@ -156,9 +216,9 @@ tableContainer { path: {searchQuery, termListFilter, termSizeFilter} /\ setPath
ngramsClick _ = Nothing
ngramsEdit _ = Nothing
in
[ H.p {} [H.text $ "Editing " <> ngrams]
[ H.p {} [H.text $ "Editing " <> ngramsTermText ngrams]
, R2.buff $ renderNgramsTree { ngramsTable, ngrams, ngramsStyle: [], ngramsClick, ngramsEdit }
, H.button {className: "btn btn-primary", on: {click: (const $ dispatch $ AddTermChildren)}} [H.text "Save"]
, H.button {className: "btn btn-primary", on: {click: (const $ dispatch AddTermChildren)}} [H.text "Save"]
, H.button {className: "btn btn-secondary", on: {click: (const $ dispatch $ SetParentResetChildren Nothing)}} [H.text "Cancel"]
]) ngramsParent)
, H.div {id: "terms_table", className: "panel-body"}
......@@ -171,9 +231,9 @@ tableContainer { path: {searchQuery, termListFilter, termSizeFilter} /\ setPath
setTermListFilter x = setPath $ _ { termListFilter = x }
setTermSizeFilter x = setPath $ _ { termSizeFilter = x }
toggleMap :: forall a. a -> Maybe a -> Maybe a
toggleMap _ (Just _) = Nothing
toggleMap b Nothing = Just b
toggleMaybe :: forall a. a -> Maybe a -> Maybe a
toggleMaybe _ (Just _) = Nothing
toggleMaybe b Nothing = Just b
-- NEXT
data Action'
......@@ -183,8 +243,7 @@ data Action'
-- NEXT
type Props =
( tabNgramType :: CTabNgramType
, path :: R.State PageParams
( path :: R.State PageParams
, versioned :: VersionedNgramsTable )
-- NEXT
......@@ -223,18 +282,32 @@ loadedNgramsTableSpec = Thermite.simpleSpec performAction render
performAction (SetParentResetChildren p) _ _ =
modifyState_ $ setParentResetChildren p
performAction (ToggleChild b c) _ _ =
modifyState_ $ _ngramsChildren <<< at c %~ toggleMap b
modifyState_ $ _ngramsChildren <<< at c %~ toggleMaybe b
performAction (ToggleSelect c) _ _ =
modifyState_ $ _ngramsSelection <<< at c %~ toggleMaybe unit
performAction ToggleSelectAll _ { ngramsSelectAll: true } =
modifyState_ $ (_ngramsSelection .~ mempty)
<<< (_ngramsSelectAll .~ false)
performAction ToggleSelectAll { versioned: Versioned { data: initTable } }
{ ngramsTablePatch } =
let
ngramsTable = applyNgramsTablePatch ngramsTablePatch initTable
roots = rootsOf ngramsTable
in
modifyState_ $ (_ngramsSelection .~ roots)
<<< (_ngramsSelectAll .~ true)
performAction Refresh {path: path /\ _} {ngramsVersion} = do
commitPatch path (Versioned {version: ngramsVersion, data: mempty})
performAction (SetTermListItem n pl) {path: path /\ _, tabNgramType} {ngramsVersion} =
commitPatch path (Versioned {version: ngramsVersion, data: mempty})
-- Here we purposedly send an empty patch as a way to synchronize with
-- the server.
performAction (CommitPatch pt) {path: path /\ _} {ngramsVersion} =
unless (isEmptyNgramsTablePatch pt) $
commitPatch path (Versioned {version: ngramsVersion, data: pt})
where
pe = NgramsPatch { patch_list: pl, patch_children: mempty }
pt = singletonNgramsTablePatch tabNgramType n pe
performAction AddTermChildren _ {ngramsParent: Nothing} =
-- impossible but harmless
pure unit
performAction AddTermChildren {path: path /\ _, tabNgramType}
performAction AddTermChildren {path: path /\ _}
{ ngramsParent: Just parent
, ngramsChildren
, ngramsVersion
......@@ -244,25 +317,35 @@ loadedNgramsTableSpec = Thermite.simpleSpec performAction render
where
pc = patchSetFromMap ngramsChildren
pe = NgramsPatch { patch_list: mempty, patch_children: pc }
pt = singletonNgramsTablePatch tabNgramType parent pe
performAction (AddNewNgram ngram) {path: path /\ _, tabNgramType} {ngramsVersion} =
commitPatch path (Versioned {version: ngramsVersion, data: pt})
where
pt = addNewNgram tabNgramType ngram CandidateTerm
pt = singletonNgramsTablePatch parent pe
render :: Thermite.Render State (Record LoadedNgramsTableProps) Action
render dispatch { path: path@({params} /\ setPath)
, versioned: Versioned { data: initTable } }
{ ngramsTablePatch, ngramsParent, ngramsChildren }
render dispatch { path: path@({scoreType, params} /\ setPath)
, versioned: Versioned { data: initTable }
, tabNgramType }
{ ngramsTablePatch, ngramsParent, ngramsChildren,
ngramsSelection, ngramsSelectAll }
_reactChildren =
[ autoUpdateElt { duration: 3000, effect: dispatch Refresh }
, R2.scuff $ T.table { params: params /\ setParams -- TODO-LENS
, rows, container, colNames, totalRecords}
, rows, container, colNames, wrapColElts, totalRecords
}
]
where
totalRecords = 47361 -- TODO
colNames = T.ColumnName <$> ["Map", "Stop", "Terms", "Score (Occurrences)"] -- see convOrderBy
container = tableContainer {path, dispatch, ngramsParent, ngramsChildren, ngramsTable}
colNames = T.ColumnName <$> ["Select", "Map", "Stop", "Terms", "Score"] -- see convOrderBy
selected =
input
[ _type "checkbox"
, className "checkbox"
, checked ngramsSelectAll
, onChange $ const $ dispatch $ ToggleSelectAll
]
-- This is used to *decorate* the Select header with the checkbox.
wrapColElts (T.ColumnName "Select") = const [R2.buff selected]
wrapColElts (T.ColumnName "Score") = (_ <> [H.text ("(" <> show scoreType <> ")")])
wrapColElts _ = identity
container = tableContainer {path, dispatch, ngramsParent, ngramsChildren, ngramsSelection, ngramsTable, tabNgramType}
setParams f = setPath $ \p@{params: ps} -> p {params = f ps}
ngramsTable = applyNgramsTablePatch ngramsTablePatch initTable
orderWith =
......@@ -276,9 +359,9 @@ loadedNgramsTableSpec = Thermite.simpleSpec performAction render
let Additive occurrences = sumOccurrences ngramsTable ngramsElement in
Tuple ne (ngramsElement # _NgramsElement <<< _occurrences .~ occurrences)
ngramsParentRoot :: Maybe String
ngramsParentRoot :: Maybe NgramsTerm
ngramsParentRoot =
(\np -> ngramsTable ^. at np <<< _Just <<< _NgramsElement <<< _root) =<< ngramsParent
(\np -> ngramsTable ^? at np <<< _Just <<< _NgramsElement <<< _root <<< _Just) =<< ngramsParent
displayRow (NgramsElement {ngrams, root}) =
root == Nothing
......@@ -292,7 +375,9 @@ loadedNgramsTableSpec = Thermite.simpleSpec performAction render
|| -- Unless they are scheduled to be removed.
ngramsChildren ^. at ngrams == Just false
convertRow (Tuple ngrams ngramsElement) =
{ row: R2.buff <$> renderNgramsItem { ngramsTable, ngrams, ngramsParent, ngramsElement, dispatch}
{ row: R2.buff <$> renderNgramsItem { ngramsTable, ngrams,
ngramsParent, ngramsElement,
ngramsSelection, dispatch }
, delete: false
}
......@@ -334,7 +419,7 @@ tree :: { ngramsTable :: NgramsTable
tree params@{ngramsTable, ngramsStyle, ngramsEdit, ngramsClick} nd =
li [ style {width : "100%"} ]
([ i icon []
, tag [text $ " " <> nd.ngrams]
, tag [text $ " " <> ngramsTermText nd.ngrams]
] <> maybe [] edit (ngramsEdit nd) <>
[ forest cs
])
......@@ -381,17 +466,20 @@ renderNgramsItem :: { ngrams :: NgramsTerm
, ngramsTable :: NgramsTable
, ngramsElement :: NgramsElement
, ngramsParent :: Maybe NgramsTerm
, ngramsSelection :: Set NgramsTerm
, dispatch :: Action -> Effect Unit
} -> Array ReactElement
renderNgramsItem { ngramsTable, ngrams, ngramsElement, ngramsParent, dispatch } =
[ checkbox GraphTerm
renderNgramsItem { ngramsTable, ngrams, ngramsElement, ngramsParent
, ngramsSelection, dispatch } =
[ selected
, checkbox GraphTerm
, checkbox StopTerm
, if ngramsParent == Nothing
then renderNgramsTree { ngramsTable, ngrams, ngramsStyle, ngramsClick, ngramsEdit }
else
a [onClick $ const $ dispatch $ ToggleChild true ngrams]
[ i [className "glyphicon glyphicon-plus"] []
, span ngramsStyle [text $ " " <> ngrams]
, span ngramsStyle [text $ " " <> ngramsTermText ngrams]
]
, text $ show (ngramsElement ^. _NgramsElement <<< _occurrences)
]
......@@ -399,7 +487,14 @@ renderNgramsItem { ngramsTable, ngrams, ngramsElement, ngramsParent, dispatch }
termList = ngramsElement ^. _NgramsElement <<< _list
ngramsStyle = [termStyle termList]
ngramsEdit = Just <<< dispatch <<< SetParentResetChildren <<< Just <<< view _ngrams
ngramsClick = Just <<< cycleTermListItem <<< view _ngrams
ngramsClick = Just <<< dispatch <<< cycleTermListItem <<< view _ngrams
selected =
input
[ _type "checkbox"
, className "checkbox"
, checked $ Set.member ngrams ngramsSelection
, onChange $ const $ dispatch $ ToggleSelect ngrams
]
checkbox termList' =
let chkd = termList == termList'
termList'' = if chkd then CandidateTerm else termList'
......@@ -408,14 +503,11 @@ renderNgramsItem { ngramsTable, ngrams, ngramsElement, ngramsParent, dispatch }
[ _type "checkbox"
, className "checkbox"
, checked chkd
-- , title "Mark as completed"
, onChange $ const $ setTermList (replace termList termList'') ngrams
, onChange $ const $ dispatch $
setTermListA ngrams (replace termList termList'')
]
setTermList Keep _ = pure unit
setTermList rep@(Replace {old,new}) n = dispatch $ SetTermListItem n rep
cycleTermListItem = setTermList (replace termList (nextTermList termList))
cycleTermListItem n = setTermListA n (replace termList (nextTermList termList))
termStyle :: TermList -> DOM.Props
termStyle GraphTerm = style {color: "green"}
......
src/Gargantext/Components/NgramsTable/Core.purs
View file @ 86165573
......@@ -11,6 +11,7 @@ module Gargantext.Components.NgramsTable.Core
, _NgramsTable
, NgramsTerm
, normNgram
, ngramsTermText
, findNgramTermList
, Version
, Versioned(..)
......@@ -27,9 +28,11 @@ module Gargantext.Components.NgramsTable.Core
, patchSetFromMap
, applyPatchSet
, applyNgramsTablePatch
, rootsOf
, singletonPatchMap
, fromNgramsPatches
, singletonNgramsTablePatch
, isEmptyNgramsTablePatch
, _list
, _occurrences
, _children
......@@ -48,6 +51,7 @@ import Data.Array (head)
import Data.Array as A
import Data.Argonaut ( class DecodeJson, decodeJson, class EncodeJson, encodeJson
, jsonEmptyObject, (:=), (~>), (.:), (.??) )
import Data.Bifunctor (lmap)
import Data.Either (Either(..))
import Data.Foldable (class Foldable, foldMap, foldl, foldr)
import Data.FoldableWithIndex (class FoldableWithIndex, foldMapWithIndex, foldlWithIndex, foldrWithIndex)
......@@ -63,7 +67,7 @@ import Data.Lens.Iso.Newtype (_Newtype)
import Data.List ((:), List(Nil))
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..), maybe)
import Data.Maybe (Maybe(..), maybe, isNothing)
import Data.Traversable (class Traversable, traverse, traverse_, sequence)
import Data.TraversableWithIndex (class TraversableWithIndex, traverseWithIndex)
import Data.Set (Set)
......@@ -76,17 +80,14 @@ import Data.Tuple (Tuple(..))
-- import Debug.Trace
import Effect.Aff (Aff)
import Foreign.Object as FO
import React (ReactElement)
import React as React
import Thermite (StateCoTransformer, modifyState_)
import Partial (crashWith)
import Partial.Unsafe (unsafePartial)
import Gargantext.Components.Table as T
import Gargantext.Ends (url)
import Gargantext.Routes (SessionRoute(..))
import Gargantext.Sessions (Session, get, put, post)
import Gargantext.Types (OrderBy(..), CTabNgramType(..), TabType, TermList(..), TermSize)
import Gargantext.Types (OrderBy(..), CTabNgramType(..), TabType, TermList(..), TermSize, ScoreType(..))
import Gargantext.Utils.KarpRabin (indicesOfAny)
type CoreParams s =
......@@ -104,6 +105,7 @@ type PageParams =
, searchQuery :: String
, termListFilter :: Maybe TermList -- Nothing means all
, termSizeFilter :: Maybe TermSize -- Nothing means all
, scoreType :: ScoreType
)
initialPageParams :: Session -> Int -> Array Int -> TabType -> PageParams
......@@ -115,10 +117,34 @@ initialPageParams session nodeId listIds tabType =
, termSizeFilter: Nothing
, termListFilter: Just GraphTerm
, searchQuery: ""
, scoreType: Occurrences
, session
}
type NgramsTerm = String
newtype NgramsTerm = NormNgramsTerm String
derive instance eqNgramsTerm :: Eq NgramsTerm
derive instance ordNgramsTerm :: Ord NgramsTerm
instance encodeJsonNgramsTerm :: EncodeJson NgramsTerm where
encodeJson (NormNgramsTerm s) = encodeJson s
-- TODO we assume that the ngrams are already normalized.
instance decodeJsonNgramsTerm :: DecodeJson NgramsTerm where
decodeJson = map NormNgramsTerm <<< decodeJson
ngramsTermText :: NgramsTerm -> String
ngramsTermText (NormNgramsTerm t) = t
-- TODO
normNgramInternal :: CTabNgramType -> String -> String
normNgramInternal CTabAuthors = identity
normNgramInternal CTabSources = identity
normNgramInternal CTabInstitutes = identity
normNgramInternal CTabTerms = S.toLower <<< R.replace wordBoundaryReg " "
normNgram :: CTabNgramType -> String -> NgramsTerm
normNgram tabType = NormNgramsTerm <<< normNgramInternal tabType
-----------------------------------------------------------------------------------
newtype NgramsElement = NgramsElement
......@@ -194,10 +220,10 @@ derive instance newtypeNgramsTable :: Newtype NgramsTable _
_NgramsTable :: Iso' NgramsTable (Map NgramsTerm NgramsElement)
_NgramsTable = _Newtype
instance indexNgramsTable :: Index NgramsTable String NgramsElement where
instance indexNgramsTable :: Index NgramsTable NgramsTerm NgramsElement where
ix k = _NgramsTable <<< ix k
instance atNgramsTable :: At NgramsTable String NgramsElement where
instance atNgramsTable :: At NgramsTable NgramsTerm NgramsElement where
at k = _NgramsTable <<< at k
instance decodeJsonNgramsTable :: DecodeJson NgramsTable where
......@@ -239,7 +265,7 @@ highlightNgrams ntype (NgramsTable table) input0 =
init x = S.take (S.length x - 1) x
input = spR input0
pats = A.fromFoldable (Map.keys table)
ixs = indicesOfAny (sp <$> pats) (normNgram ntype input)
ixs = indicesOfAny (sp <<< ngramsTermText <$> pats) (normNgramInternal ntype input)
consOnJustTail s xs@(Tuple _ (Just _) : _) =
Tuple s Nothing : xs
......@@ -264,7 +290,7 @@ highlightNgrams ntype (NgramsTable table) input0 =
Nothing ->
crashWith "highlightNgrams: out of bounds pattern"
Just pat ->
let lpat = S.length (db pat) in
let lpat = S.length (db (ngramsTermText pat)) in
case Map.lookup pat table of
Nothing ->
crashWith "highlightNgrams: pattern missing from table"
......@@ -452,14 +478,16 @@ instance traversablePatchMap :: Traversable (PatchMap k) where
instance traversableWithIndexPatchMap :: TraversableWithIndex k (PatchMap k) where
traverseWithIndex f (PatchMap m) = PatchMap <$> traverseWithIndex f m
instance encodeJsonPatchMap :: EncodeJson p => EncodeJson (PatchMap String p) where
-- TODO generalize
instance encodeJsonPatchMap :: EncodeJson p => EncodeJson (PatchMap NgramsTerm p) where
encodeJson (PatchMap m) =
encodeJson $ FO.fromFoldable $ (Map.toUnfoldable m :: Array _)
encodeJson $ FO.fromFoldable $ map (lmap ngramsTermText) (Map.toUnfoldable m :: Array _)
instance decodeJsonPatchMap :: DecodeJson p => DecodeJson (PatchMap String p) where
instance decodeJsonPatchMap :: DecodeJson p => DecodeJson (PatchMap NgramsTerm p) where
decodeJson json = do
obj <- decodeJson json
pure $ PatchMap $ Map.fromFoldableWithIndex (obj :: FO.Object p)
pure $ PatchMap $ foldlWithIndex (\k m v -> Map.insert (NormNgramsTerm k) v m) mempty (obj :: FO.Object p)
-- TODO we assume that the ngrams are already normalized ^^^^^^^^^^^^^
singletonPatchMap :: forall k p. k -> p -> PatchMap k p
singletonPatchMap k p = PatchMap (Map.singleton k p)
......@@ -484,21 +512,22 @@ type NgramsTablePatch =
, ngramsPatches :: NgramsPatches
}
isEmptyNgramsTablePatch :: NgramsTablePatch -> Boolean
isEmptyNgramsTablePatch {ngramsPatches} = isEmptyPatchMap ngramsPatches
fromNgramsPatches :: NgramsPatches -> NgramsTablePatch
fromNgramsPatches ngramsPatches = {ngramsNewElems: mempty, ngramsPatches}
normNgram :: CTabNgramType -> String -> NgramsTerm
normNgram CTabAuthors = identity
normNgram CTabSources = identity
normNgram CTabInstitutes = identity
normNgram CTabTerms = S.toLower <<< R.replace wordBoundaryReg " "
findNgramTermList :: NgramsTable -> NgramsTerm -> Maybe TermList
findNgramTermList (NgramsTable m) n = m ^? at n <<< _Just <<< _NgramsElement <<< _list
singletonNgramsTablePatch :: NgramsTerm -> NgramsPatch -> NgramsTablePatch
singletonNgramsTablePatch n p = fromNgramsPatches $ singletonPatchMap n p
findNgramTermList :: CTabNgramType -> NgramsTable -> String -> Maybe TermList
findNgramTermList ntype (NgramsTable m) s = m ^? at (normNgram ntype s) <<< _Just <<< _NgramsElement <<< _list
singletonNgramsTablePatch :: CTabNgramType -> NgramsTerm -> NgramsPatch -> NgramsTablePatch
singletonNgramsTablePatch m n p = fromNgramsPatches $ singletonPatchMap (normNgram m n) p
rootsOf :: NgramsTable -> Set NgramsTerm
rootsOf (NgramsTable m) = Map.keys $ Map.filter isRoot m
where
isRoot (NgramsElement {parent}) = isNothing parent
type RootParent = { root :: NgramsTerm, parent :: NgramsTerm }
......@@ -526,7 +555,7 @@ reParentNgramsPatch parent (NgramsPatch {patch_children: PatchSet {rem, add}}) =
-- root_of_parent <- use (at parent <<< _Just <<< _NgramsElement <<< _root)
-- ^ TODO this does not type checks, we do the following two lines instead:
s <- use (at parent)
let root_of_parent = s ^. (_Just <<< _NgramsElement <<< _root)
let root_of_parent = s ^? (_Just <<< _NgramsElement <<< _root <<< _Just)
let rp = { root: maybe parent identity root_of_parent, parent }
traverse_ (reParent Nothing) rem
traverse_ (reParent $ Just rp) add
......@@ -572,9 +601,10 @@ postNewElems newElems params = void $ traverseWithIndex postNewElem newElems
where
postNewElem ngrams list = postNewNgrams [ngrams] (Just list) params
addNewNgram :: CTabNgramType -> NgramsTerm -> TermList -> NgramsTablePatch
addNewNgram ntype ngrams list = { ngramsPatches: mempty
, ngramsNewElems: Map.singleton (normNgram ntype ngrams) list }
addNewNgram :: NgramsTerm -> TermList -> NgramsTablePatch
addNewNgram ngrams list =
{ ngramsPatches: mempty
, ngramsNewElems: Map.singleton ngrams list }
putNgramsPatches :: forall s. CoreParams s -> Versioned NgramsPatches -> Aff (Versioned NgramsPatches)
putNgramsPatches {session, nodeId, listIds, tabType} = put session putNgrams
......@@ -594,16 +624,16 @@ commitPatch props (Versioned {version, data: tablePatch@{ngramsPatches, ngramsNe
loadNgramsTable :: PageParams -> Aff VersionedNgramsTable
loadNgramsTable
{ nodeId, listIds, termListFilter, termSizeFilter, session
{ nodeId, listIds, termListFilter, termSizeFilter, session, scoreType
, searchQuery, tabType, params: {offset, limit, orderBy}}
= get session query
where query = GetNgrams { tabType, offset, limit, listIds
, orderBy: convOrderBy <$> orderBy
, termListFilter, termSizeFilter
, searchQuery } (Just nodeId)
, searchQuery, scoreType } (Just nodeId)
convOrderBy :: T.OrderByDirection T.ColumnName -> OrderBy
convOrderBy (T.ASC (T.ColumnName "Score (Occurrences)")) = ScoreAsc
convOrderBy (T.DESC (T.ColumnName "Score (Occurrences)")) = ScoreDesc
convOrderBy (T.ASC (T.ColumnName "Score")) = ScoreAsc
convOrderBy (T.DESC (T.ColumnName "Score")) = ScoreDesc
convOrderBy (T.ASC _) = TermAsc
convOrderBy (T.DESC _) = TermDesc
src/Gargantext/Components/Nodes/Annuaire.purs
View file @ 86165573
module Gargantext.Components.Nodes.Annuaire where
import Prelude (bind, identity, pure, ($), (<$>), (<>))
import Prelude (bind, identity, pure, const, ($), (<$>), (<>))
import Data.Argonaut (class DecodeJson, decodeJson, (.:), (.:?))
import Data.Array (head)
import Data.Maybe (Maybe(..), maybe)
......@@ -101,12 +101,13 @@ pageCpt = R.staticComponent "LoadedAnnuairePage" cpt
where
cpt { session, annuairePath, pagePath
, table: (AnnuaireTable {annuaireTable}) } _ = do
T.table { rows, params, container, colNames, totalRecords }
T.table { rows, params, container, colNames, totalRecords, wrapColElts }
where
totalRecords = 4361 -- TODO
rows = (\c -> {row: contactCells session c, delete: false}) <$> annuaireTable
container = T.defaultContainer { title: "Annuaire" } -- TODO
colNames = T.ColumnName <$> [ "", "Name", "Company", "Service", "Role"]
wrapColElts = const identity
setParams f = snd pagePath $ \{nodeId, params: ps} ->
{params: f ps, nodeId: fst annuairePath}
params = T.initialParams /\ setParams
......
src/Gargantext/Components/Nodes/Corpus/Document.purs
View file @ 86165573
......@@ -22,7 +22,7 @@ import Gargantext.Components.Annotation.AnnotatedField as AnnotatedField
import Gargantext.Hooks.Loader (useLoader)
import Gargantext.Routes (SessionRoute(..))
import Gargantext.Sessions (Session, get)
import Gargantext.Types (CTabNgramType(..), NodeType(..), TabSubType(..), TabType(..), TermList)
import Gargantext.Types (CTabNgramType(..), NodeType(..), TabSubType(..), TabType(..), TermList, ScoreType(..))
import Gargantext.Utils.Reactix as R2
type DocPath =
......@@ -295,11 +295,11 @@ docViewSpec = simpleSpec performAction render
commitPatch path (Versioned {version: ngramsVersion, data: pt})
where
pe = NgramsPatch { patch_list: pl, patch_children: mempty }
pt = singletonNgramsTablePatch CTabTerms n pe
pt = singletonNgramsTablePatch n pe
performAction (AddNewNgram ngram termList) {path} {ngramsVersion} =
commitPatch path (Versioned {version: ngramsVersion, data: pt})
where
pt = addNewNgram CTabTerms ngram termList
pt = addNewNgram ngram termList
render :: Render State Props Action
render dispatch { loaded: { ngramsTable: Versioned { data: initTable }, document } }
......@@ -379,8 +379,9 @@ loadData {session, nodeId, listIds, tabType} = do
, listIds
, params: { offset : 0, limit : 100, orderBy: Nothing}
, tabType
, searchQuery : ""
, termListFilter : Nothing
, termSizeFilter : Nothing
, searchQuery: ""
, termListFilter: Nothing
, termSizeFilter: Nothing
, scoreType: Occurrences
}
pure {document, ngramsTable}
src/Gargantext/Components/Table.purs
View file @ 86165573
......@@ -12,6 +12,7 @@ import Effect (Effect)
import Reactix as R
import Reactix.DOM.HTML as H
import Gargantext.Utils.Reactix as R2
import Gargantext.Utils.Reactix (effectLink)
type TableContainerProps =
( pageSizeControl :: R.Element
......@@ -51,6 +52,8 @@ derive instance eqOrderByDirection :: Eq a => Eq (OrderByDirection a)
type Props =
( colNames :: Array ColumnName
, wrapColElts :: ColumnName -> Array R.Element -> Array R.Element
-- ^ Use `const identity` as a default behavior.
, totalRecords :: Int
, params :: R.State Params
, rows :: Rows
......@@ -126,7 +129,7 @@ table props = R.createElement tableCpt props []
tableCpt :: R.Component Props
tableCpt = R.hooksComponent "G.C.Table.table" cpt
where
cpt {container, colNames, totalRecords, rows, params} _ = do
cpt {container, colNames, wrapColElts, totalRecords, rows, params} _ = do
pageSize@(pageSize' /\ setPageSize) <- R.useState' PS10
(page /\ setPage) <- R.useState' 1
(orderBy /\ setOrderBy) <- R.useState' Nothing
......@@ -140,9 +143,10 @@ tableCpt = R.hooksComponent "G.C.Table.table" cpt
lnk mc = effectLink (setOrderBy (const mc))
cs :: Array R.Element
cs =
wrapColElts c $
case orderBy of
Just (ASC d) | c == d -> [lnk (Just (DESC c)) "DESC ", lnk Nothing (columnName c)]
Just (DESC d) | c == d -> [lnk (Just (ASC c)) "ASC ", lnk Nothing (columnName c)]
Just (ASC d) | c == d -> [lnk (Just (DESC c)) "DESC ", lnk Nothing (columnName c)]
Just (DESC d) | c == d -> [lnk (Just (ASC c)) "ASC ", lnk Nothing (columnName c)]
_ -> [lnk (Just (ASC c)) (columnName c)]
R.useEffect1' state $ when (fst params /= stateParams state) $ (snd params) (const $ stateParams state)
pure $ container
......@@ -198,9 +202,6 @@ textDescription currPage pageSize totalRecords =
end = if end' > totalRecords then totalRecords else end'
msg = "Showing " <> show start <> " to " <> show end <> " of " <> show totalRecords
effectLink :: Effect Unit -> String -> R.Element
effectLink eff msg = H.a {on: {click: const eff}} [H.text msg]
pagination :: (R2.Setter Int) -> Int -> Int -> R.Element
pagination changePage tp cp =
H.span {} $
......
src/Gargantext/Ends.purs
View file @ 86165573
......@@ -127,6 +127,7 @@ sessionPath (R.GetNgrams opts i) =
<> foldMap (\x -> "&list=" <> show x) opts.listIds
<> foldMap (\x -> "&listType=" <> show x) opts.termListFilter
<> foldMap termSizeFilter opts.termSizeFilter
<> "&scoreType=" <> show opts.scoreType
<> search opts.searchQuery
where
base (TabCorpus _) = sessionPath <<< R.NodeAPI Node i
......
src/Gargantext/Types.purs
View file @ 86165573
......@@ -227,6 +227,13 @@ nodeTypePath Texts = "texts"
type ListId = Int
data ScoreType = Occurrences
derive instance genericScoreType :: Generic ScoreType _
instance showScoreType :: Show ScoreType where
show = genericShow
type NgramsGetOpts =
{ tabType :: TabType
, offset :: Offset
......@@ -235,6 +242,7 @@ type NgramsGetOpts =
, listIds :: Array ListId
, termListFilter :: Maybe TermList
, termSizeFilter :: Maybe TermSize
, scoreType :: ScoreType
, searchQuery :: String
}
......
src/Gargantext/Utils/Reactix.purs
View file @ 86165573
......@@ -18,6 +18,7 @@ import FFI.Simple ((...), defineProperty, delay, args2, args3)
import React (class ReactPropFields, Children, ReactClass, ReactElement)
import React as React
import Reactix as R
import Reactix.DOM.HTML as H
import Reactix.DOM.HTML (ElemFactory, createDOM, text)
import Reactix.React (react)
import Reactix.SyntheticEvent as RE
......@@ -167,3 +168,6 @@ useReductor' r = useReductor r pure
render :: R.Element -> DOM.Element -> Effect Unit
render e d = delay unit $ \_ -> pure $ R.reactDOM ... "render" $ args2 e d
effectLink :: Effect Unit -> String -> R.Element
effectLink eff msg = H.a {on: {click: const eff}} [H.text msg]
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