Skip to content
Projects
Groups
Snippets
Help
Loading...
Help
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
haskell-gargantext
Project
Project
Details
Activity
Releases
Cycle Analytics
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Charts
Issues
199
Issues
199
List
Board
Labels
Milestones
Merge Requests
12
Merge Requests
12
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Charts
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Charts
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
gargantext
haskell-gargantext
Commits
3a6e26c8
Commit
3a6e26c8
authored
Sep 04, 2020
by
Alexandre Delanoë
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
[FIX] temp fix on the textflow (needs refactoring)
parent
8d8471b1
Changes
4
Hide whitespace changes
Inline
Side-by-side
Showing
4 changed files
with
21 additions
and
26 deletions
+21
-26
TFICF.hs
src/Gargantext/Core/Text/Metrics/TFICF.hs
+1
-1
Flow.hs
src/Gargantext/Database/Action/Flow.hs
+5
-4
List.hs
src/Gargantext/Database/Action/Flow/List.hs
+0
-4
Insert.hs
src/Gargantext/Database/Query/Table/Node/Document/Insert.hs
+15
-17
No files found.
src/Gargantext/Core/Text/Metrics/TFICF.hs
View file @
3a6e26c8
...
@@ -47,7 +47,7 @@ tficf :: TficfContext Count Total
...
@@ -47,7 +47,7 @@ tficf :: TficfContext Count Total
->
TFICF
->
TFICF
tficf
(
TficfInfra
(
Count
ic
)
(
Total
it
)
)
tficf
(
TficfInfra
(
Count
ic
)
(
Total
it
)
)
(
TficfSupra
(
Count
sc
)
(
Total
st
)
)
(
TficfSupra
(
Count
sc
)
(
Total
st
)
)
|
it
>=
ic
&&
st
>=
sc
{-&& it <= st-}
=
(
ic
/
it
)
/
log
(
sc
/
st
)
|
it
>=
ic
&&
st
>=
sc
&&
it
<=
st
=
(
ic
/
it
)
/
log
(
sc
/
st
)
|
otherwise
=
panic
$
"[ERR]"
<>
path
<>
" Frequency impossible"
|
otherwise
=
panic
$
"[ERR]"
<>
path
<>
" Frequency impossible"
tficf
_
_
=
panic
$
"[ERR]"
<>
path
<>
"Undefined for these contexts"
tficf
_
_
=
panic
$
"[ERR]"
<>
path
<>
"Undefined for these contexts"
...
...
src/Gargantext/Database/Action/Flow.hs
View file @
3a6e26c8
...
@@ -206,8 +206,8 @@ flowCorpusUser l user corpusName ctype ids = do
...
@@ -206,8 +206,8 @@ flowCorpusUser l user corpusName ctype ids = do
-- TODO: check if present already, ignore
-- TODO: check if present already, ignore
_
<-
Doc
.
add
userCorpusId
ids
_
<-
Doc
.
add
userCorpusId
ids
--
tId <- insertDefaultNode NodeTexts userCorpusId userId
tId
<-
insertDefaultNode
NodeTexts
userCorpusId
userId
-- printDebug "Node Text Id
" tId
printDebug
"Node Text Ids:
"
tId
-- User List Flow
-- User List Flow
(
masterUserId
,
_masterRootId
,
masterCorpusId
)
<-
getOrMk_RootWithCorpus
(
UserName
userMaster
)
(
Left
""
)
ctype
(
masterUserId
,
_masterRootId
,
masterCorpusId
)
<-
getOrMk_RootWithCorpus
(
UserName
userMaster
)
(
Left
""
)
ctype
...
@@ -238,6 +238,7 @@ insertDocs hs uId cId = do
...
@@ -238,6 +238,7 @@ insertDocs hs uId cId = do
printDebug
"docs"
(
length
docs
)
printDebug
"docs"
(
length
docs
)
ids
<-
insertDb
uId
cId
docs
ids
<-
insertDb
uId
cId
docs
printDebug
"ids"
(
length
ids
)
printDebug
"ids"
(
length
ids
)
-- printDebug "inserted" (map reUniqId ids)
let
let
ids'
=
map
reId
ids
ids'
=
map
reId
ids
documentsWithId
=
mergeData
(
toInserted
ids
)
(
Map
.
fromList
$
map
viewUniqId'
docs
)
documentsWithId
=
mergeData
(
toInserted
ids
)
(
Map
.
fromList
$
map
viewUniqId'
docs
)
...
@@ -256,7 +257,7 @@ insertMasterDocs :: ( FlowCmdM env err m
...
@@ -256,7 +257,7 @@ insertMasterDocs :: ( FlowCmdM env err m
insertMasterDocs
c
lang
hs
=
do
insertMasterDocs
c
lang
hs
=
do
(
masterUserId
,
_
,
masterCorpusId
)
<-
getOrMk_RootWithCorpus
(
UserName
userMaster
)
(
Left
corpusMasterName
)
c
(
masterUserId
,
_
,
masterCorpusId
)
<-
getOrMk_RootWithCorpus
(
UserName
userMaster
)
(
Left
corpusMasterName
)
c
(
ids'
,
documentsWithId
)
<-
insertDocs
hs
masterUserId
masterCorpusId
(
ids'
,
documentsWithId
)
<-
insertDocs
hs
masterUserId
masterCorpusId
_
<-
Doc
.
add
masterCorpusId
ids'
-- TODO
-- TODO
-- create a corpus with database name (CSV or PubMed)
-- create a corpus with database name (CSV or PubMed)
-- add documents to the corpus (create node_node link)
-- add documents to the corpus (create node_node link)
...
@@ -303,7 +304,7 @@ viewUniqId' d = maybe err (\h -> (h,d)) (view uniqId d)
...
@@ -303,7 +304,7 @@ viewUniqId' d = maybe err (\h -> (h,d)) (view uniqId d)
toInserted
::
[
ReturnId
]
toInserted
::
[
ReturnId
]
->
Map
HashId
ReturnId
->
Map
HashId
ReturnId
toInserted
=
toInserted
=
Map
.
fromList
.
map
(
\
r
->
(
reUniqId
r
,
r
)
)
Map
.
fromList
.
map
(
\
r
->
(
reUniqId
r
,
r
)
)
.
filter
(
\
r
->
reInserted
r
==
True
)
.
filter
(
\
r
->
reInserted
r
==
True
)
mergeData
::
Map
HashId
ReturnId
mergeData
::
Map
HashId
ReturnId
...
...
src/Gargantext/Database/Action/Flow/List.hs
View file @
3a6e26c8
...
@@ -78,10 +78,6 @@ flowList_Tficf' u m nt f = do
...
@@ -78,10 +78,6 @@ flowList_Tficf' u m nt f = do
-}
-}
-- | TODO check optimization
-- | TODO check optimization
mapNodeIdNgrams
::
[
DocumentIdWithNgrams
a
]
mapNodeIdNgrams
::
[
DocumentIdWithNgrams
a
]
->
Map
Ngrams
(
Map
NgramsType
(
Map
NodeId
Int
))
->
Map
Ngrams
(
Map
NgramsType
(
Map
NodeId
Int
))
...
...
src/Gargantext/Database/Query/Table/Node/Document/Insert.hs
View file @
3a6e26c8
...
@@ -57,12 +57,14 @@ module Gargantext.Database.Query.Table.Node.Document.Insert
...
@@ -57,12 +57,14 @@ module Gargantext.Database.Query.Table.Node.Document.Insert
import
Control.Lens
(
set
,
view
)
import
Control.Lens
(
set
,
view
)
import
Control.Lens.Cons
import
Control.Lens.Cons
import
Control.Lens.Prism
import
Control.Lens.Prism
import
Data.Aeson
(
toJSON
)
import
Data.Aeson
(
toJSON
{-, ToJSON-}
)
import
Data.Maybe
(
maybe
)
import
Data.Maybe
(
maybe
)
import
Data.Text
(
Text
)
import
Data.Text
(
Text
)
-- import Data.ByteString (ByteString)
import
Data.Time.Segment
(
jour
)
import
Data.Time.Segment
(
jour
)
import
Database.PostgreSQL.Simple
(
FromRow
,
Query
,
Only
(
..
))
import
Database.PostgreSQL.Simple
(
FromRow
,
Query
,
Only
(
..
))
import
Database.PostgreSQL.Simple.FromRow
(
fromRow
,
field
)
import
Database.PostgreSQL.Simple.FromRow
(
fromRow
,
field
)
-- import Database.PostgreSQL.Simple.ToRow (toRow, ToRow)
import
Database.PostgreSQL.Simple.SqlQQ
import
Database.PostgreSQL.Simple.SqlQQ
import
Database.PostgreSQL.Simple.ToField
(
toField
,
Action
)
import
Database.PostgreSQL.Simple.ToField
(
toField
,
Action
)
import
Database.PostgreSQL.Simple.Types
(
Values
(
..
),
QualifiedIdentifier
(
..
))
import
Database.PostgreSQL.Simple.Types
(
Values
(
..
),
QualifiedIdentifier
(
..
))
...
@@ -70,7 +72,7 @@ import GHC.Generics (Generic)
...
@@ -70,7 +72,7 @@ import GHC.Generics (Generic)
import
Gargantext.Database.Admin.Config
(
nodeTypeId
)
import
Gargantext.Database.Admin.Config
(
nodeTypeId
)
import
Gargantext.Database.Admin.Types.Hyperdata
import
Gargantext.Database.Admin.Types.Hyperdata
import
Gargantext.Database.Admin.Types.Node
import
Gargantext.Database.Admin.Types.Node
import
Gargantext.Database.Prelude
(
Cmd
,
runPGSQuery
)
import
Gargantext.Database.Prelude
(
Cmd
,
runPGSQuery
{-, formatPGSQuery-}
)
import
Gargantext.Prelude
import
Gargantext.Prelude
import
Gargantext.Prelude.Crypto.Hash
(
hash
)
import
Gargantext.Prelude.Crypto.Hash
(
hash
)
import
qualified
Data.Text
as
DT
(
pack
,
concat
,
take
)
import
qualified
Data.Text
as
DT
(
pack
,
concat
,
take
)
...
@@ -126,7 +128,7 @@ instance InsertDb HyperdataContact
...
@@ -126,7 +128,7 @@ instance InsertDb HyperdataContact
,
toField
u
,
toField
u
,
toField
p
,
toField
p
,
toField
$
maybe
"Contact"
(
DT
.
take
255
)
(
Just
"Name"
)
-- (_hc_name h)
,
toField
$
maybe
"Contact"
(
DT
.
take
255
)
(
Just
"Name"
)
-- (_hc_name h)
,
toField
$
jour
201
0
1
1
-- TODO put default date
,
toField
$
jour
0
1
1
-- TODO put default date
,
(
toField
.
toJSON
)
h
,
(
toField
.
toJSON
)
h
]
]
...
@@ -134,14 +136,14 @@ instance InsertDb HyperdataContact
...
@@ -134,14 +136,14 @@ instance InsertDb HyperdataContact
--
--
-- to print rendered query (Debug purpose) use @formatQuery@ function.
-- to print rendered query (Debug purpose) use @formatQuery@ function.
{-
{-
insertDocuments_Debug :: (Hyperdata a, ToJSON a, ToRow a) => UserId -> ParentId -> [a] -> Cmd ByteString
insertDocuments_Debug :: (Hyperdata a, ToJSON a, ToRow a, InsertDb [a])
=> UserId -> ParentId -> [a] -> Cmd err ByteString
insertDocuments_Debug uId pId hs = formatPGSQuery queryInsert (Only $ Values fields inputData)
insertDocuments_Debug uId pId hs = formatPGSQuery queryInsert (Only $ Values fields inputData)
where
where
fields = map (\t-> QualifiedIdentifier Nothing t) inputSqlTypes
fields = map (\t-> QualifiedIdentifier Nothing t) inputSqlTypes
inputData =
prepare
uId pId hs
inputData =
insertDb'
uId pId hs
-}
-}
-- | Input Tables: types of the tables
-- | Input Tables: types of the tables
inputSqlTypes
::
[
Text
]
inputSqlTypes
::
[
Text
]
inputSqlTypes
=
map
DT
.
pack
[
"int4"
,
"int4"
,
"int4"
,
"text"
,
"date"
,
"jsonb"
]
inputSqlTypes
=
map
DT
.
pack
[
"int4"
,
"int4"
,
"int4"
,
"text"
,
"date"
,
"jsonb"
]
...
@@ -153,27 +155,25 @@ queryInsert = [sql|
...
@@ -153,27 +155,25 @@ queryInsert = [sql|
, ins AS (
, ins AS (
INSERT INTO nodes (typename,user_id,parent_id,name,date,hyperdata)
INSERT INTO nodes (typename,user_id,parent_id,name,date,hyperdata)
SELECT * FROM input_rows
SELECT * FROM input_rows
ON CONFLICT ((hyperdata ->> 'uniqIdBdd')) DO UPDATE SET user_id=EXCLUDED.user_id -- on unique index
-- ON CONFLICT ((hyperdata ->> 'uniqIdBdd')) DO NOTHING -- on unique index -- this does not return the ids
-- ON CONFLICT ((hyperdata ->> 'uniqIdBdd')) DO NOTHING -- on unique index -- this does not return the ids
-- ON CONFLICT (typename, parent_id, (hyperdata ->> 'uniqId')) DO NOTHING
-- on unique index
ON CONFLICT ((hyperdata ->> 'uniqIdBdd')) DO UPDATE SET user_id=EXCLUDED.user_id
-- on unique index
RETURNING id,hyperdata
RETURNING id,hyperdata
)
)
SELECT true AS source -- true for 'newly inserted'
SELECT true AS source -- true for 'newly inserted'
, id
, id
, hyperdata ->> 'uniqId' as doi
, hyperdata ->> 'uniqId
Bdd
' as doi
FROM ins
FROM ins
UNION ALL
UNION ALL
SELECT false AS source -- false for 'not inserted'
SELECT false AS source -- false for 'not inserted'
, c.id
, c.id
, hyperdata ->> 'uniqId' as doi
, hyperdata ->> 'uniqId
Bdd
' as doi
FROM input_rows
FROM input_rows
JOIN nodes c USING (hyperdata); -- columns of unique index
JOIN nodes c USING (hyperdata); -- columns of unique index
|]
|]
------------------------------------------------------------------------
------------------------------------------------------------------------
-- * Main Types used
-- * Main Types used
-- ** Return Types
-- ** Return Types
-- | When documents are inserted
-- | When documents are inserted
...
@@ -229,12 +229,10 @@ addUniqIdsContact hc = set (hc_uniqIdBdd) (Just shaBdd)
...
@@ -229,12 +229,10 @@ addUniqIdsContact hc = set (hc_uniqIdBdd) (Just shaBdd)
-- | TODO add more shaparameters
-- | TODO add more shaparameters
shaParametersContact
::
[(
HyperdataContact
->
Text
)]
shaParametersContact
::
[(
HyperdataContact
->
Text
)]
shaParametersContact
=
[
\
d
->
maybeText
$
view
(
hc_who
.
_Just
.
cw_firstName
)
d
shaParametersContact
=
[
\
d
->
maybeText
$
view
(
hc_who
.
_Just
.
cw_firstName
)
d
,
\
d
->
maybeText
$
view
(
hc_who
.
_Just
.
cw_lastName
)
d
,
\
d
->
maybeText
$
view
(
hc_who
.
_Just
.
cw_lastName
)
d
,
\
d
->
maybeText
$
view
(
hc_where
.
_head
.
cw_touch
.
_Just
.
ct_mail
)
d
,
\
d
->
maybeText
$
view
(
hc_where
.
_head
.
cw_touch
.
_Just
.
ct_mail
)
d
]
]
maybeText
::
Maybe
Text
->
Text
maybeText
::
Maybe
Text
->
Text
maybeText
=
maybe
(
DT
.
pack
""
)
identity
maybeText
=
maybe
(
DT
.
pack
""
)
identity
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment