Skip to content

H
haskell-gargantext
Commit 2adb8ebd authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

[FIX][DB][FLOW] insert listngrams.

parent c0afac67
Hide whitespace changes
Inline Side-by-side
Showing with 87 additions and 79 deletions
src/Gargantext/API/Ngrams.hs
View file @ 2adb8ebd
......@@ -58,7 +58,7 @@ import Gargantext.Core.Types (node_id)
import Gargantext.Core.Utils.Prefix (unPrefix)
import Gargantext.Database.Ngrams (NgramsId)
import Gargantext.Database.Node (getListsWithParentId)
-- import Gargantext.Database.NodeNgram -- (NodeNgram(..), NodeNgram, updateNodeNgrams, NodeNgramPoly)
import Gargantext.Database.NodeNgram -- (NodeNgram(..), NodeNgram, updateNodeNgrams, NodeNgramPoly)
import Gargantext.Database.NodeNgramsNgrams -- (NodeNgramsNgramsPoly(NodeNgramsNgrams))
import Gargantext.Prelude
import Gargantext.Text.List.Types (ListType(..), ListId, ListTypeId) -- ,listTypeId )
......@@ -69,17 +69,18 @@ import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
------------------------------------------------------------------------
--data FacetFormat = Table | Chart
data TabType = Docs | Terms | Sources | Authors | Trash
data TabType = Docs | Terms | Sources | Authors | Institutes | Trash
deriving (Generic, Enum, Bounded)
instance FromHttpApiData TabType
where
parseUrlPiece "Docs" = pure Docs
parseUrlPiece "Terms" = pure Terms
parseUrlPiece "Sources" = pure Sources
parseUrlPiece "Authors" = pure Authors
parseUrlPiece "Trash" = pure Trash
parseUrlPiece _ = Left "Unexpected value of TabType"
parseUrlPiece "Docs" = pure Docs
parseUrlPiece "Terms" = pure Terms
parseUrlPiece "Sources" = pure Sources
parseUrlPiece "Institutes" = pure Institutes
parseUrlPiece "Authors" = pure Authors
parseUrlPiece "Trash" = pure Trash
parseUrlPiece _ = Left "Unexpected value of TabType"
instance ToParamSchema TabType
instance ToJSON TabType
......@@ -104,7 +105,7 @@ $(deriveJSON (unPrefix "_ne_") ''NgramsElement)
instance ToSchema NgramsElement
instance Arbitrary NgramsElement where
arbitrary = elements [NgramsElement "sport" StopList 1 Nothing mempty]
arbitrary = elements [NgramsElement "sport" GraphList 1 Nothing mempty]
------------------------------------------------------------------------
newtype NgramsTable = NgramsTable { _ngramsTable :: [NgramsElement] }
......@@ -113,20 +114,19 @@ newtype NgramsTable = NgramsTable { _ngramsTable :: [NgramsElement] }
instance Arbitrary NgramsTable where
arbitrary = elements
[ NgramsTable
[ NgramsElement "animal" GraphList 1 Nothing (Set.fromList ["dog"])
, NgramsElement "dog" GraphList 3 (Just "animal")
(Set.fromList ["object", "cat", "nothing"])
, NgramsElement "object" CandidateList 2 (Just "animal") mempty
, NgramsElement "cat" GraphList 1 (Just "animal") mempty
, NgramsElement "nothing" StopList 4 (Just "animal") mempty
[ NgramsElement "animal" GraphList 1 Nothing (Set.fromList ["dog", "cat"])
, NgramsElement "cat" GraphList 1 (Just "animal") mempty
, NgramsElement "dog" GraphList 3 (Just "animal")(Set.fromList ["dogs"])
, NgramsElement "dogs" StopList 4 (Just "dog") mempty
, NgramsElement "object" CandidateList 2 Nothing mempty
, NgramsElement "nothing" StopList 4 Nothing mempty
]
, NgramsTable
[ NgramsElement "plant" GraphList 3 Nothing
(Set.fromList ["flower", "moon", "cat", "sky"])
, NgramsElement "flower" GraphList 3 (Just "plant") mempty
, NgramsElement "moon" CandidateList 1 (Just "plant") mempty
, NgramsElement "cat" GraphList 2 (Just "plant") mempty
, NgramsElement "sky" StopList 1 (Just "plant") mempty
[ NgramsElement "organic" GraphList 3 Nothing (Set.singleton "flower")
, NgramsElement "flower" GraphList 3 (Just "organic") mempty
, NgramsElement "moon" CandidateList 1 Nothing mempty
, NgramsElement "cat" GraphList 2 Nothing mempty
, NgramsElement "sky" StopList 1 Nothing mempty
]
]
instance ToSchema NgramsTable
......@@ -182,11 +182,10 @@ instance Arbitrary NgramsPatch where
arbitrary = NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary)
data NgramsIdPatch =
NgramsIdPatch { _nip_ngramsId :: NgramsTerm
NgramsIdPatch { _nip_ngrams :: NgramsTerm
, _nip_ngramsPatch :: NgramsPatch
}
deriving (Ord, Eq, Show, Generic)
$(deriveJSON (unPrefix "_nip_") ''NgramsIdPatch)
instance ToSchema NgramsIdPatch
......@@ -213,7 +212,6 @@ data Versioned a = Versioned
, _v_data :: a
}
{-
-- TODO sequencs of modifications (Patchs)
type NgramsIdPatch = Patch NgramsId NgramsPatch
......@@ -236,16 +234,17 @@ ngramsIdPatch = fromList $ catMaybes $ reverse [ replace (1::NgramsId) (Just $ n
------------------------------------------------------------------------
------------------------------------------------------------------------
type CorpusId = Int
type TableNgramsApi = Summary " Table Ngrams API Change"
:> QueryParam "list" ListId
:> ReqBody '[JSON] NgramsIdPatchs -- Versioned ...
:> Put '[JSON] NgramsIdPatchsBack -- Versioned ...
type TableNgramsApiGet = Summary " Table Ngrams API Get"
:> QueryParam "ngramsType" TabType
:> QueryParam "list" ListId
:> Get '[JSON] NgramsTable
type TableNgramsApi = Summary " Table Ngrams API Change"
:> QueryParam "list" ListId
:> ReqBody '[JSON] NgramsIdPatchsFeed -- Versioned ...
:> Put '[JSON] NgramsIdPatchsBack -- Versioned ...
type NgramsIdPatchsFeed = NgramsIdPatchs
type NgramsIdPatchsBack = NgramsIdPatchs
......@@ -257,12 +256,10 @@ defaultList c cId = view node_id <$> maybe (panic noListFound) identity
where
noListFound = "Gargantext.API.Ngrams.defaultList: no list found"
toLists :: ListId -> NgramsIdPatchs -> [(ListId, NgramsId, ListTypeId)]
toLists = undefined
{-
toLists lId np =
[ (lId,ngId,listTypeId lt) | map (toList lId) (_nip_ngramsIdPatchs np) ]
-}
toLists :: ListId -> NgramsIdPatchs -> [(ListId, NgramsId, ListTypeId)]
-- toLists = undefined
toLists lId np = [ (lId,ngId,listTypeId lt) | map (toList lId) (_nip_ngramsIdPatchs np) ]
toList :: ListId -> NgramsIdPatch -> (ListId, NgramsId, ListTypeId)
toList = undefined
......@@ -271,13 +268,11 @@ toGroups :: ListId -> (NgramsPatch -> Set NgramsId) -> NgramsIdPatchs -> [NodeNg
toGroups lId addOrRem ps = concat $ map (toGroup lId addOrRem) $ _nip_ngramsIdPatchs ps
toGroup :: ListId -> (NgramsPatch -> Set NgramsId) -> NgramsIdPatch -> [NodeNgramsNgrams]
toGroup = undefined
{-
-- toGroup = undefined
toGroup lId addOrRem (NgramsIdPatch ngId patch) =
map (\ng -> (NodeNgramsNgrams lId ngId ng (Just 1))) (Set.toList $ addOrRem patch)
-}
-}
tableNgramsPatch :: Connection -> CorpusId -> Maybe ListId -> NgramsIdPatchsFeed -> IO NgramsIdPatchsBack
tableNgramsPatch = undefined
......@@ -290,7 +285,7 @@ tableNgramsPatch conn corpusId maybeList patchs = do
_ <- ngramsGroup' conn Del $ toGroups listId _np_rem_children patchs
_ <- updateNodeNgrams conn (toLists listId patchs)
pure (NgramsIdPatchs [])
-}
-}
getTableNgramsPatch :: Connection -> CorpusId -> Maybe TabType -> Maybe ListId -> IO NgramsTable
getTableNgramsPatch = undefined
src/Gargantext/Core/Types/Main.hs
View file @ 2adb8ebd
......@@ -80,7 +80,7 @@ corpusTree nId t = TreeN (NodeTree ("Corpus " <> t) NodeCorpus nId) ( [ leafT
-- TODO multiple ListType declaration, remove it
data ListType = Stop | Candidate | Map
deriving (Generic, Eq, Ord)
deriving (Generic, Eq, Ord, Show)
instance ToJSON ListType
instance FromJSON ListType
......@@ -93,7 +93,6 @@ listId Map = 2
-- data Metrics = Occurrences | Cooccurrences | Specclusion | Genclusion | Cvalue
-- | TfidfCorpus | TfidfGlobal | TirankLocal | TirankGlobal
-- | Community Manager Use Case
type Annuaire = NodeCorpus
......
src/Gargantext/Database/Flow.hs
View file @ 2adb8ebd
......@@ -22,7 +22,7 @@ authors
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Gargantext.Database.Flow (flowDatabase)
module Gargantext.Database.Flow (flowDatabase, ngrams2list)
where
import GHC.Show (Show)
......@@ -66,7 +66,7 @@ flowDatabase ff fp cName = do
--printDebug "Docs IDs : " (ids)
idsRepeat <- runCmd' $ insertDocuments masterUserId corpusId hyperdataDocuments
--printDebug "Repeated Docs IDs : " (length ids)
-- Ngrams Flow
-- todo: flow for new documents only
-- let tids = toInserted ids
......@@ -92,14 +92,12 @@ flowDatabase ff fp cName = do
listId2 <- runCmd' $ listFlow masterUserId corpusId indexedNgrams
printDebug "list id : " listId2
printDebug "Docs IDs : " (length idsRepeat)
(_, _, corpusId2) <- subFlow "user1" cName
inserted <- runCmd' $ add corpusId2 (map reId ids)
printDebug "Inserted : " (length inserted)
-- pure [corpusId2, corpusId]
runCmd' $ del [corpusId2, corpusId]
pure corpusId2
-- runCmd' $ del [corpusId2, corpusId]
type CorpusName = Text
......@@ -204,15 +202,20 @@ insertToNodeNgrams m = insertNodeNgrams [ NodeNgram Nothing nId ((_ngramsId
------------------------------------------------------------------------
------------------------------------------------------------------------
listFlow :: UserId -> CorpusId -> Map (NgramsT NgramsIndexed) (Map NodeId Int) -> Cmd ListId
listFlow uId cId ng = do
listFlow uId cId ngs = do
printDebug "ngs:" ngs
lId <- maybe (panic "mkList error") identity <$> head <$> mkList cId uId
printDebug "ngs" (DM.keys ngs)
-- TODO add stemming equivalence of 2 ngrams
let groupEd = groupNgramsBy (\(NgramsT t1 n1) (NgramsT t2 n2) -> if (((==) t1 t2) && ((==) n1 n2)) then (Just (n1,n2)) else Nothing) ng
let groupEd = groupNgramsBy (\(NgramsT t1 n1) (NgramsT t2 n2) -> if (((==) t1 t2) && ((==) n1 n2)) then (Just (n1,n2)) else Nothing) ngs
_ <- insertGroups lId groupEd
-- compute Candidate / Map
let lists = ngrams2list ng
_ <- insertLists lId lists
let lists = ngrams2list ngs
printDebug "lists:" lists
is <- insertLists lId lists
printDebug "listNgrams inserted :" is
pure lId
......@@ -230,18 +233,19 @@ insertGroups :: ListId -> Map NgramsIndexed NgramsIndexed -> Cmd Int
insertGroups lId ngrs =
insertNodeNgramsNgramsNew [ NodeNgramsNgrams lId ng1 ng2 (Just 1)
| (ng1, ng2) <- map (both _ngramsId) $ DM.toList ngrs
, ng1 /= ng2
]
------------------------------------------------------------------------
-- TODO: verify NgramsT lost here
ngrams2list :: Map (NgramsT NgramsIndexed) (Map NodeId Int) -> Map ListType NgramsIndexed
ngrams2list = DM.fromList . zip (repeat Candidate) . map (\(NgramsT _lost_t ng) -> ng) . DM.keys
ngrams2list :: Map (NgramsT NgramsIndexed) (Map NodeId Int) -> [(ListType,NgramsIndexed)]
ngrams2list = zip (repeat Candidate) . map (\(NgramsT _lost_t ng) -> ng) . DM.keys
-- | TODO: weight of the list could be a probability
insertLists :: ListId -> Map ListType NgramsIndexed -> Cmd Int
insertLists lId list2ngrams =
insertLists :: ListId -> [(ListType,NgramsIndexed)] -> Cmd Int
insertLists lId lngs =
insertNodeNgrams [ NodeNgram Nothing lId ngr (fromIntegral $ listId l) (listId l)
| (l,ngr) <- map (second _ngramsId) $ DM.toList list2ngrams
| (l,ngr) <- map (second _ngramsId) lngs
]
------------------------------------------------------------------------
......
src/Gargantext/Database/Node.hs
View file @ 2adb8ebd
......@@ -379,14 +379,14 @@ nodeContactW maybeName maybeContact aId = node NodeContact name contact (Just aI
name = maybe "Contact" identity maybeName
contact = maybe defaultContact identity maybeContact
------------------------------------------------------------------------
defaultList :: HyperdataList
defaultList = HyperdataList (Just "Preferences")
arbitraryList :: HyperdataList
arbitraryList = HyperdataList (Just "Preferences")
nodeListW :: Maybe Name -> Maybe HyperdataList -> ParentId -> UserId -> NodeWrite'
nodeListW maybeName maybeList pId = node NodeList name list (Just pId)
where
name = maybe "Listes" identity maybeName
list = maybe defaultList identity maybeList
list = maybe arbitraryList identity maybeList
------------------------------------------------------------------------
node :: (ToJSON a, Hyperdata a) => NodeType -> Name -> a -> Maybe ParentId -> UserId -> NodeWrite'
......@@ -470,7 +470,6 @@ mkNode' ns = mkCmd $ \conn -> runInsertMany conn nodeTable' ns
mkNodeR' :: [NodeWriteT] -> Cmd [Int]
mkNodeR' ns = mkCmd $ \conn -> runInsertManyReturning conn nodeTable' ns (\(i,_,_,_,_,_,_) -> i)
------------------------------------------------------------------------
data NewNode = NewNode { _newNodeId :: Int
......
src/Gargantext/Database/NodeNgram.hs
View file @ 2adb8ebd
......@@ -29,6 +29,7 @@ if Node is a List then it is listing (either Stop, Candidate or Map)
-- TODO NodeNgrams
module Gargantext.Database.NodeNgram where
import Data.Text (Text)
import Control.Lens.TH (makeLensesWith, abbreviatedFields)
import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
......@@ -98,16 +99,18 @@ insertNodeNgramW nns =
mkCmd $ \c -> fromIntegral
<$> runInsertMany c nodeNgramTable nns
type NgramsText = Text
updateNodeNgrams :: PGS.Connection -> [(ListId, NgramsId, ListTypeId)] -> IO [PGS.Only Int]
updateNodeNgrams :: PGS.Connection -> [(ListId, NgramsText, ListTypeId)] -> IO [PGS.Only Int]
updateNodeNgrams c input = PGS.query c updateQuery (PGS.Only $ Values fields $ input)
where
fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","int4","int4"]
fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","text","int4"]
updateQuery = [sql| UPDATE nodes_ngrams as old SET
ngrams_type = new.typeList
from (?) as new(node_id,ngram_id,typeList)
from (?) as new(node_id,terms,typeList)
JOIN ngrams ON ngrams.terms = new.terms
WHERE old.node_id = new.node_id
AND old.gram_id = new.gram_id
RETURNING new.ngram_id
AND old.ngram_id = ngrams.id;
-- RETURNING new.ngram_id
|]
src/Gargantext/Database/NodeNgramsNgrams.hs
View file @ 2adb8ebd
......@@ -32,6 +32,7 @@ module Gargantext.Database.NodeNgramsNgrams
where
import Control.Lens.TH (makeLensesWith, abbreviatedFields)
import Data.Text (Text)
import Data.Maybe (Maybe)
import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
import Database.PostgreSQL.Simple.SqlQQ (sql)
......@@ -117,11 +118,14 @@ insertNodeNgramsNgramsW ns =
------------------------------------------------------------------------
data Action = Del | Add
ngramsGroup :: Action -> [NodeNgramsNgrams] -> Cmd [Int]
type NgramsParent = Text
type NgramsChild = Text
ngramsGroup :: Action -> [(Int, NgramsParent, NgramsChild, Maybe Double)] -> Cmd [Int]
ngramsGroup a ngs = mkCmd $ \c -> ngramsGroup' c a ngs
-- TODO: remove this function (use Reader Monad only)
ngramsGroup' :: DPS.Connection -> Action -> [NodeNgramsNgrams] -> IO [Int]
ngramsGroup' :: DPS.Connection -> Action -> [(Int, NgramsParent, NgramsChild, Maybe Double)] -> IO [Int]
ngramsGroup' c action ngs = runNodeNgramsNgrams c q ngs
where
q = case action of
......@@ -129,32 +133,34 @@ ngramsGroup' c action ngs = runNodeNgramsNgrams c q ngs
Add -> queryInsertNodeNgramsNgrams
runNodeNgramsNgrams :: DPS.Connection -> DPS.Query -> [NodeNgramsNgrams] -> IO [Int]
runNodeNgramsNgrams :: DPS.Connection -> DPS.Query -> [(Int, NgramsParent, NgramsChild, Maybe Double)] -> IO [Int]
runNodeNgramsNgrams c q ngs = map (\(DPS.Only a) -> a) <$> DPS.query c q (DPS.Only $ Values fields ngs' )
where
ngs' = map (\(NodeNgramsNgrams n ng1 ng2 w) -> (n,ng1,ng2,maybe 0 identity w)) ngs
ngs' = map (\(n,ng1,ng2,w) -> (n,ng1,ng2,maybe 0 identity w)) ngs
fields = map (\t -> QualifiedIdentifier Nothing t)
["int4","int4","int4","double"]
["int4","text","text","double"]
--------------------------------------------------------------------
-- TODO: on conflict update weight
queryInsertNodeNgramsNgrams :: DPS.Query
queryInsertNodeNgramsNgrams = [sql|
WITH input_rows(nId,ng1,ng2,w) AS (?)
, ins AS (
INSERT INTO nodes_ngrams_ngrams (node_id,ngram1_id,ngram2_id,weight)
SELECT * FROM input_rows
ON CONFLICT (node_id,ngram1_id,ngram2_id) DO NOTHING -- unique index created here
)
INSERT INTO nodes_ngrams_ngrams (node_id,ngram1_id,ngram2_id,weight)
SELECT nId,ngrams1.id,ngrams2.id,w FROM input_rows
JOIN ngrams ngrams1 ON ngrams1.terms = ng1
JOIN ngrams ngrams2 ON ngrams2.terms = ng2
ON CONFLICT (node_id,ngram1_id,ngram2_id) DO NOTHING -- unique index created here
|]
queryDelNodeNgramsNgrams :: DPS.Query
queryDelNodeNgramsNgrams = [sql|
WITH input(nId,ng1,ng2,w) AS (?)
, DELETE FROM nodes_ngrams_ngrams
WHERE node_id = input.nId
AND ngram1_id = input.ng1
AND ngram2_id = input.ng2
DELETE FROM nodes_ngrams_ngrams nnn
JOIN ngrams ngrams1 ON ngrams.terms = ng1
JOIN ngrams ngrams2 ON ngrams.terms = ng2
WHERE nnn.node_id = input.nId
AND nnn.ngram1_id = ngrams1.id
AND nnn.ngram2_id = ngrams2.id
;)
|]
src/Gargantext/Text/List/Types.hs
View file @ 2adb8ebd
......@@ -29,6 +29,8 @@ import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
-------------------------------------------------------------------
-- TODO : clean multiples types declaration
data ListType = GraphList | StopList | CandidateList
deriving (Show, Eq, Ord, Enum, Bounded, Generic)
......
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