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
3d407136
Verified
Commit
3d407136
authored
Jul 24, 2025
by
Przemyslaw Kaminski
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
[phylo] implement hh/mm/ss, also some refactorings
parent
9aa41862
Pipeline
#7780
passed with stages
in 100 minutes and 55 seconds
Changes
10
Pipelines
1
Hide whitespace changes
Inline
Side-by-side
Showing
10 changed files
with
221 additions
and
81 deletions
+221
-81
Common.hs
bin/gargantext-cli/CLI/Phylo/Common.hs
+22
-11
gargantext.cabal
gargantext.cabal
+1
-1
DateUtils.hs
src/Gargantext/Core/Utils/DateUtils.hs
+34
-1
Chart.hs
src/Gargantext/Core/Viz/Chart.hs
+3
-3
Phylo.hs
src/Gargantext/Core/Viz/Phylo.hs
+13
-1
Tools.hs
src/Gargantext/Core/Viz/Phylo/API/Tools.hs
+74
-26
PhyloTools.hs
src/Gargantext/Core/Viz/Phylo/PhyloTools.hs
+22
-10
NodeContext.hs
src/Gargantext/Database/Query/Table/NodeContext.hs
+4
-5
NodeNode.hs
src/Gargantext/Database/Query/Table/NodeNode.hs
+4
-5
Utils.hs
test/Test/Core/Utils.hs
+44
-18
No files found.
bin/gargantext-cli/CLI/Phylo/Common.hs
View file @
3d407136
...
@@ -62,11 +62,17 @@ wosToDocs limit patterns time path = do
...
@@ -62,11 +62,17 @@ wosToDocs limit patterns time path = do
in
Document
(
toPhyloDate
in
Document
(
toPhyloDate
(
fromIntegral
$
fromJust
$
_hd_publication_year
d
)
(
fromIntegral
$
fromJust
$
_hd_publication_year
d
)
(
fromJust
$
_hd_publication_month
d
)
(
fromJust
$
_hd_publication_month
d
)
(
fromJust
$
_hd_publication_day
d
)
time
)
(
fromJust
$
_hd_publication_day
d
)
(
fromJust
$
_hd_publication_hour
d
)
(
fromJust
$
_hd_publication_minute
d
)
(
fromJust
$
_hd_publication_second
d
)
time
)
(
toPhyloDate'
(
toPhyloDate'
(
fromIntegral
$
fromJust
$
_hd_publication_year
d
)
(
fromIntegral
$
fromJust
$
_hd_publication_year
d
)
(
fromJust
$
_hd_publication_month
d
)
(
fromJust
$
_hd_publication_month
d
)
(
fromJust
$
_hd_publication_day
d
)
time
)
(
fromJust
$
_hd_publication_day
d
)
(
fromJust
$
_hd_publication_hour
d
)
(
fromJust
$
_hd_publication_minute
d
)
(
fromJust
$
_hd_publication_second
d
)
time
)
(
termsInText
patterns
$
title
<>
" "
<>
abstr
)
Nothing
[]
time
)
(
termsInText
patterns
$
title
<>
" "
<>
abstr
)
Nothing
[]
time
)
<$>
concat
<$>
concat
<$>
mapConcurrently
(
\
file
->
<$>
mapConcurrently
(
\
file
->
...
@@ -82,8 +88,9 @@ tsvToDocs parser patterns time path =
...
@@ -82,8 +88,9 @@ tsvToDocs parser patterns time path =
Wos
_
->
errorTrace
"tsvToDocs: unimplemented"
Wos
_
->
errorTrace
"tsvToDocs: unimplemented"
Tsv
limit
->
Vector
.
toList
Tsv
limit
->
Vector
.
toList
<$>
Vector
.
take
limit
<$>
Vector
.
take
limit
<$>
Vector
.
map
(
\
row
->
Document
(
toPhyloDate
(
Tsv
.
fromMIntOrDec
Tsv
.
defaultYear
$
tsv_publication_year
row
)
(
fromMaybe
Tsv
.
defaultMonth
$
tsv_publication_month
row
)
(
fromMaybe
Tsv
.
defaultDay
$
tsv_publication_day
row
)
time
)
-- NOTE: TSV doesn't have hour/minute/second information
(
toPhyloDate'
(
Tsv
.
fromMIntOrDec
Tsv
.
defaultYear
$
tsv_publication_year
row
)
(
fromMaybe
Tsv
.
defaultMonth
$
tsv_publication_month
row
)
(
fromMaybe
Tsv
.
defaultDay
$
tsv_publication_day
row
)
time
)
<$>
Vector
.
map
(
\
row
->
Document
(
toPhyloDate
(
Tsv
.
fromMIntOrDec
Tsv
.
defaultYear
$
tsv_publication_year
row
)
(
fromMaybe
Tsv
.
defaultMonth
$
tsv_publication_month
row
)
(
fromMaybe
Tsv
.
defaultDay
$
tsv_publication_day
row
)
0
0
0
time
)
(
toPhyloDate'
(
Tsv
.
fromMIntOrDec
Tsv
.
defaultYear
$
tsv_publication_year
row
)
(
fromMaybe
Tsv
.
defaultMonth
$
tsv_publication_month
row
)
(
fromMaybe
Tsv
.
defaultDay
$
tsv_publication_day
row
)
0
0
0
time
)
(
termsInText
patterns
$
(
tsv_title
row
)
<>
" "
<>
(
tsv_abstract
row
))
(
termsInText
patterns
$
(
tsv_title
row
)
<>
" "
<>
(
tsv_abstract
row
))
Nothing
Nothing
[]
[]
...
@@ -91,8 +98,9 @@ tsvToDocs parser patterns time path =
...
@@ -91,8 +98,9 @@ tsvToDocs parser patterns time path =
)
<$>
snd
<$>
either
(
\
err
->
panicTrace
$
"TSV error"
<>
(
show
err
))
identity
<$>
Tsv
.
readTSVFile
path
)
<$>
snd
<$>
either
(
\
err
->
panicTrace
$
"TSV error"
<>
(
show
err
))
identity
<$>
Tsv
.
readTSVFile
path
Tsv'
limit
->
Vector
.
toList
Tsv'
limit
->
Vector
.
toList
<$>
Vector
.
take
limit
<$>
Vector
.
take
limit
<$>
Vector
.
map
(
\
row
->
Document
(
toPhyloDate
(
tsv'_publication_year
row
)
(
tsv'_publication_month
row
)
(
tsv'_publication_day
row
)
time
)
-- NOTE: TSV doesn't have hour/minute/second information
(
toPhyloDate'
(
tsv'_publication_year
row
)
(
tsv'_publication_month
row
)
(
tsv'_publication_day
row
)
time
)
<$>
Vector
.
map
(
\
row
->
Document
(
toPhyloDate
(
tsv'_publication_year
row
)
(
tsv'_publication_month
row
)
(
tsv'_publication_day
row
)
0
0
0
time
)
(
toPhyloDate'
(
tsv'_publication_year
row
)
(
tsv'_publication_month
row
)
(
tsv'_publication_day
row
)
0
0
0
time
)
(
termsInText
patterns
$
(
tsv'_title
row
)
<>
" "
<>
(
tsv'_abstract
row
))
(
termsInText
patterns
$
(
tsv'_title
row
)
<>
" "
<>
(
tsv'_abstract
row
))
(
Just
$
tsv'_weight
row
)
(
Just
$
tsv'_weight
row
)
(
map
(
T
.
strip
.
pack
)
$
splitOn
";"
(
unpack
$
(
tsv'_source
row
)))
(
map
(
T
.
strip
.
pack
)
$
splitOn
";"
(
unpack
$
(
tsv'_source
row
)))
...
@@ -157,11 +165,14 @@ fileToList parser path =
...
@@ -157,11 +165,14 @@ fileToList parser path =
-- Config time parameters to label
-- Config time parameters to label
timeToLabel
::
PhyloConfig
->
[
Char
]
timeToLabel
::
PhyloConfig
->
[
Char
]
timeToLabel
config
=
case
(
timeUnit
config
)
of
timeToLabel
config
=
case
(
timeUnit
config
)
of
Epoch
p
s
f
->
(
"time_epochs"
<>
"_"
<>
(
show
p
)
<>
"_"
<>
(
show
s
)
<>
"_"
<>
(
show
f
))
Epoch
p
s
f
->
(
"time_epochs"
<>
"_"
<>
(
show
p
)
<>
"_"
<>
(
show
s
)
<>
"_"
<>
(
show
f
))
Year
p
s
f
->
(
"time_years"
<>
"_"
<>
(
show
p
)
<>
"_"
<>
(
show
s
)
<>
"_"
<>
(
show
f
))
Year
p
s
f
->
(
"time_years"
<>
"_"
<>
(
show
p
)
<>
"_"
<>
(
show
s
)
<>
"_"
<>
(
show
f
))
Month
p
s
f
->
(
"time_months"
<>
"_"
<>
(
show
p
)
<>
"_"
<>
(
show
s
)
<>
"_"
<>
(
show
f
))
Month
p
s
f
->
(
"time_months"
<>
"_"
<>
(
show
p
)
<>
"_"
<>
(
show
s
)
<>
"_"
<>
(
show
f
))
Week
p
s
f
->
(
"time_weeks"
<>
"_"
<>
(
show
p
)
<>
"_"
<>
(
show
s
)
<>
"_"
<>
(
show
f
))
Week
p
s
f
->
(
"time_weeks"
<>
"_"
<>
(
show
p
)
<>
"_"
<>
(
show
s
)
<>
"_"
<>
(
show
f
))
Day
p
s
f
->
(
"time_days"
<>
"_"
<>
(
show
p
)
<>
"_"
<>
(
show
s
)
<>
"_"
<>
(
show
f
))
Day
p
s
f
->
(
"time_days"
<>
"_"
<>
(
show
p
)
<>
"_"
<>
(
show
s
)
<>
"_"
<>
(
show
f
))
Hour
p
s
f
->
(
"time_hours"
<>
"_"
<>
(
show
p
)
<>
"_"
<>
(
show
s
)
<>
"_"
<>
(
show
f
))
Minute
p
s
f
->
(
"time_minutes"
<>
"_"
<>
(
show
p
)
<>
"_"
<>
(
show
s
)
<>
"_"
<>
(
show
f
))
Second
p
s
f
->
(
"time_seconds"
<>
"_"
<>
(
show
p
)
<>
"_"
<>
(
show
s
)
<>
"_"
<>
(
show
f
))
seaToLabel
::
PhyloConfig
->
[
Char
]
seaToLabel
::
PhyloConfig
->
[
Char
]
...
...
gargantext.cabal
View file @
3d407136
...
@@ -258,6 +258,7 @@ library
...
@@ -258,6 +258,7 @@ library
Gargantext.Core.Types.Query
Gargantext.Core.Types.Query
Gargantext.Core.Utils
Gargantext.Core.Utils
Gargantext.Core.Utils.Aeson
Gargantext.Core.Utils.Aeson
Gargantext.Core.Utils.DateUtils
Gargantext.Core.Utils.Prefix
Gargantext.Core.Utils.Prefix
Gargantext.Core.Viz.Graph.Index
Gargantext.Core.Viz.Graph.Index
Gargantext.Core.Viz.Graph.Tools
Gargantext.Core.Viz.Graph.Tools
...
@@ -418,7 +419,6 @@ library
...
@@ -418,7 +419,6 @@ library
Gargantext.Core.Text.Terms.Multi.PosTagging
Gargantext.Core.Text.Terms.Multi.PosTagging
Gargantext.Core.Text.Terms.Multi.PosTagging.Types
Gargantext.Core.Text.Terms.Multi.PosTagging.Types
Gargantext.Core.Types.Search
Gargantext.Core.Types.Search
Gargantext.Core.Utils.DateUtils
Gargantext.Core.Utils.Swagger
Gargantext.Core.Utils.Swagger
Gargantext.Core.Viz
Gargantext.Core.Viz
Gargantext.Core.Viz.Chart
Gargantext.Core.Viz.Chart
...
...
src/Gargantext/Core/Utils/DateUtils.hs
View file @
3d407136
...
@@ -11,8 +11,14 @@ Portability : POSIX
...
@@ -11,8 +11,14 @@ Portability : POSIX
module
Gargantext.Core.Utils.DateUtils
where
module
Gargantext.Core.Utils.DateUtils
where
import
Data.Text
qualified
as
T
import
Data.Time
(
UTCTime
(
..
),
fromGregorian
,
toGregorian
,
utctDay
)
import
Data.Time.Format
(
parseTimeM
,
defaultTimeLocale
)
import
Data.Time.Format.ISO8601
(
iso8601ParseM
)
import
Data.Time.LocalTime
(
TimeOfDay
(
..
),
timeOfDayToTime
)
import
Gargantext.Defaults
qualified
as
Def
import
Gargantext.Prelude
import
Gargantext.Prelude
import
Data.Time
(
UTCTime
,
toGregorian
,
utctDay
)
import
Text.Printf
(
printf
)
--
--
--readInt :: IO [Char] -> IO Int
--readInt :: IO [Char] -> IO Int
...
@@ -38,3 +44,30 @@ averageLength l = fromIntegral (sum (map length l)) / fromIntegral (length l)
...
@@ -38,3 +44,30 @@ averageLength l = fromIntegral (sum (map length l)) / fromIntegral (length l)
-- c <- getCurrentTime
-- c <- getCurrentTime
-- print c -- $ toYear $ toGregorian $ utctDay c
-- print c -- $ toYear $ toGregorian $ utctDay c
makeUTCTime
::
Int
->
Int
->
Int
->
Int
->
Int
->
Int
->
UTCTime
makeUTCTime
year
month
day
hour
minute
second'
=
UTCTime
dayPart
timePart
where
dayPart
=
fromGregorian
(
fromIntegral
year
)
month
day
timePart
=
timeOfDayToTime
(
TimeOfDay
hour
minute
(
fromIntegral
second'
))
-- | Parse with multiple format attempts
parseFlexibleTime
::
Text
->
Maybe
UTCTime
parseFlexibleTime
t
=
msum
[
iso8601ParseM
s
,
parseTimeM
True
defaultTimeLocale
"%Y-%m-%d %H:%M:%S UTC"
s
,
parseTimeM
True
defaultTimeLocale
"%Y-%m-%d"
s
]
where
s
=
T
.
unpack
t
-- | Parse date and return date parts (list of [yyyy, mm, dd])
dateParts
::
Text
->
[
Text
]
dateParts
t
=
[
T
.
pack
$
printf
"%04d"
y
,
T
.
pack
$
printf
"%02d"
m
,
T
.
pack
$
printf
"%02d"
d
]
where
mParsed
=
parseFlexibleTime
t
parsed
=
fromMaybe
(
makeUTCTime
(
fromIntegral
Def
.
year
)
Def
.
month
Def
.
day
Def
.
hour
Def
.
minute
Def
.
second
)
mParsed
(
y
,
m
,
d
)
=
toGregorian
$
utctDay
parsed
src/Gargantext/Core/Viz/Chart.hs
View file @
3d407136
...
@@ -31,19 +31,19 @@ import Gargantext.Database.Admin.Config ( userMaster )
...
@@ -31,19 +31,19 @@ import Gargantext.Database.Admin.Config ( userMaster )
import
Gargantext.Database.Prelude
(
DBQuery
)
import
Gargantext.Database.Prelude
(
DBQuery
)
import
Gargantext.Database.Query.Table.Node
(
getListsWithParentId
)
import
Gargantext.Database.Query.Table.Node
(
getListsWithParentId
)
import
Gargantext.Database.Query.Table.Node.Select
(
selectNodesWithUsername
)
import
Gargantext.Database.Query.Table.Node.Select
(
selectNodesWithUsername
)
import
Gargantext.Database.Query.Table.NodeContext
(
selectDocs
Date
s
)
import
Gargantext.Database.Query.Table.NodeContext
(
selectDocs
Year
s
)
import
Gargantext.Database.Schema.Node
(
NodePoly
(
_node_id
)
)
import
Gargantext.Database.Schema.Node
(
NodePoly
(
_node_id
)
)
import
Gargantext.Prelude
hiding
(
toList
)
import
Gargantext.Prelude
hiding
(
toList
)
histoData
::
CorpusId
->
DBQuery
err
x
Histo
histoData
::
CorpusId
->
DBQuery
err
x
Histo
histoData
cId
=
do
histoData
cId
=
do
dates
<-
selectDocsDate
s
cId
years
<-
selectDocsYear
s
cId
let
(
ls
,
css
)
=
V
.
unzip
let
(
ls
,
css
)
=
V
.
unzip
$
V
.
fromList
$
V
.
fromList
$
sortOn
fst
-- TODO Vector.sortOn
$
sortOn
fst
-- TODO Vector.sortOn
$
toList
$
toList
$
countOccurrences
date
s
$
countOccurrences
year
s
pure
(
Histo
ls
css
)
pure
(
Histo
ls
css
)
...
...
src/Gargantext/Core/Viz/Phylo.hs
View file @
3d407136
...
@@ -135,6 +135,18 @@ data TimeUnit =
...
@@ -135,6 +135,18 @@ data TimeUnit =
{
_day_period
::
Int
{
_day_period
::
Int
,
_day_step
::
Int
,
_day_step
::
Int
,
_day_matchingFrame
::
Int
}
,
_day_matchingFrame
::
Int
}
|
Hour
{
_hour_period
::
Int
,
_hour_step
::
Int
,
_hour_matchingFrame
::
Int
}
|
Minute
{
_minute_period
::
Int
,
_minute_step
::
Int
,
_minute_matchingFrame
::
Int
}
|
Second
{
_second_period
::
Int
,
_second_step
::
Int
,
_second_matchingFrame
::
Int
}
deriving
(
Show
,
Generic
,
Eq
,
NFData
,
ToExpr
)
deriving
(
Show
,
Generic
,
Eq
,
NFData
,
ToExpr
)
instance
ToSchema
TimeUnit
where
instance
ToSchema
TimeUnit
where
...
@@ -341,7 +353,7 @@ defaultPhyloParam =
...
@@ -341,7 +353,7 @@ defaultPhyloParam =
-- | Document | --
-- | Document | --
------------------
------------------
-- | Date : a simple Integer
-- | Date : a simple Integer
(maxInt on 64 bit is good enough for storing number of seconds since year 0)
type
Date
=
Int
type
Date
=
Int
-- | DateStr : the string version of a Date
-- | DateStr : the string version of a Date
...
...
src/Gargantext/Core/Viz/Phylo/API/Tools.hs
View file @
3d407136
...
@@ -25,7 +25,9 @@ import Data.Map.Strict qualified as Map
...
@@ -25,7 +25,9 @@ import Data.Map.Strict qualified as Map
import
Data.Set
qualified
as
Set
import
Data.Set
qualified
as
Set
import
Data.Text
(
pack
)
import
Data.Text
(
pack
)
import
Data.Time.Calendar
(
fromGregorian
,
diffGregorianDurationClip
,
cdMonths
,
diffDays
,
showGregorian
)
import
Data.Time.Calendar
(
fromGregorian
,
diffGregorianDurationClip
,
cdMonths
,
diffDays
,
showGregorian
)
import
Data.Time.Clock.POSIX
(
posixSecondsToUTCTime
)
import
Data.Time.Clock
(
UTCTime
(
..
))
import
Data.Time.Clock.POSIX
(
posixSecondsToUTCTime
,
utcTimeToPOSIXSeconds
)
import
Data.Time.Format
(
defaultTimeLocale
,
formatTime
)
import
Gargantext.API.Ngrams.Prelude
(
getTermList
)
import
Gargantext.API.Ngrams.Prelude
(
getTermList
)
import
Gargantext.API.Ngrams.Types
(
NgramsTerm
(
..
))
import
Gargantext.API.Ngrams.Types
(
NgramsTerm
(
..
))
import
Gargantext.Core
(
withDefaultLanguage
,
Lang
)
import
Gargantext.Core
(
withDefaultLanguage
,
Lang
)
...
@@ -33,6 +35,7 @@ import Gargantext.Core.NodeStory.Types (HasNodeStory, NodeStoryEnv, HasNodeStory
...
@@ -33,6 +35,7 @@ import Gargantext.Core.NodeStory.Types (HasNodeStory, NodeStoryEnv, HasNodeStory
import
Gargantext.Core.Text.Ngrams
(
NgramsType
(
..
))
import
Gargantext.Core.Text.Ngrams
(
NgramsType
(
..
))
import
Gargantext.Core.Text.Terms.WithList
(
Patterns
,
buildPatterns
,
termsInText
)
import
Gargantext.Core.Text.Terms.WithList
(
Patterns
,
buildPatterns
,
termsInText
)
import
Gargantext.Core.Types.Main
(
ListType
(
MapTerm
))
import
Gargantext.Core.Types.Main
(
ListType
(
MapTerm
))
import
Gargantext.Core.Utils.DateUtils
(
makeUTCTime
)
import
Gargantext.Core.Viz.Phylo
(
TimeUnit
(
..
),
Date
,
Document
(
..
),
PhyloConfig
(
..
),
Phylo
(
_phylo_computeTime
),
trackComputeTime
,
ComputeTimeHistory
)
import
Gargantext.Core.Viz.Phylo
(
TimeUnit
(
..
),
Date
,
Document
(
..
),
PhyloConfig
(
..
),
Phylo
(
_phylo_computeTime
),
trackComputeTime
,
ComputeTimeHistory
)
import
Gargantext.Core.Viz.Phylo.PhyloExport
(
toPhyloExport
,
dotToFile
)
import
Gargantext.Core.Viz.Phylo.PhyloExport
(
toPhyloExport
,
dotToFile
)
import
Gargantext.Core.Viz.Phylo.PhyloMaker
(
toPhylo
,
toPhyloWithoutLink
)
import
Gargantext.Core.Viz.Phylo.PhyloMaker
(
toPhylo
,
toPhyloWithoutLink
)
...
@@ -50,7 +53,6 @@ import Gargantext.Database.Schema.Node ( NodePoly(_node_hyperdata), node_hyperda
...
@@ -50,7 +53,6 @@ import Gargantext.Database.Schema.Node ( NodePoly(_node_hyperdata), node_hyperda
import
Gargantext.Prelude
hiding
(
to
)
import
Gargantext.Prelude
hiding
(
to
)
import
Gargantext.System.Logging
(
MonadLogger
,
LogLevel
(
DEBUG
),
logLocM
)
import
Gargantext.System.Logging
(
MonadLogger
,
LogLevel
(
DEBUG
),
logLocM
)
import
Gargantext.Utils.UTCTime
(
timeMeasured
,
timeMeasured''
)
import
Gargantext.Utils.UTCTime
(
timeMeasured
,
timeMeasured''
)
import
Prelude
qualified
import
System.FilePath
((
</>
))
import
System.FilePath
((
</>
))
import
System.IO.Temp
(
withTempDirectory
)
import
System.IO.Temp
(
withTempDirectory
)
import
System.Process
qualified
as
Shell
import
System.Process
qualified
as
Shell
...
@@ -156,13 +158,19 @@ toPhyloDocs lang patterns time d =
...
@@ -156,13 +158,19 @@ toPhyloDocs lang patterns time d =
let
title
=
fromMaybe
""
(
_hd_title
d
)
let
title
=
fromMaybe
""
(
_hd_title
d
)
abstr
=
fromMaybe
""
(
_hd_abstract
d
)
abstr
=
fromMaybe
""
(
_hd_abstract
d
)
in
Document
(
toPhyloDate
in
Document
(
toPhyloDate
(
from
Integral
$
from
Maybe
1
$
_hd_publication_year
d
)
(
fromMaybe
1
$
_hd_publication_year
d
)
(
fromMaybe
1
$
_hd_publication_month
d
)
(
fromMaybe
1
$
_hd_publication_month
d
)
(
fromMaybe
1
$
_hd_publication_day
d
)
time
)
(
fromMaybe
1
$
_hd_publication_day
d
)
(
fromMaybe
1
$
_hd_publication_hour
d
)
(
fromMaybe
1
$
_hd_publication_minute
d
)
(
fromMaybe
1
$
_hd_publication_second
d
)
time
)
(
toPhyloDate'
(
toPhyloDate'
(
from
Integral
$
from
Maybe
1
$
_hd_publication_year
d
)
(
fromMaybe
1
$
_hd_publication_year
d
)
(
fromMaybe
1
$
_hd_publication_month
d
)
(
fromMaybe
1
$
_hd_publication_month
d
)
(
fromMaybe
1
$
_hd_publication_day
d
)
time
)
(
fromMaybe
1
$
_hd_publication_day
d
)
(
fromMaybe
1
$
_hd_publication_hour
d
)
(
fromMaybe
1
$
_hd_publication_minute
d
)
(
fromMaybe
1
$
_hd_publication_second
d
)
time
)
(
termsInText'
lang
patterns
$
title
<>
" "
<>
abstr
)
Nothing
[]
time
(
termsInText'
lang
patterns
$
title
<>
" "
<>
abstr
)
Nothing
[]
time
...
@@ -189,35 +197,75 @@ context2date :: Context HyperdataDocument -> TimeUnit -> Maybe (Date, Text)
...
@@ -189,35 +197,75 @@ context2date :: Context HyperdataDocument -> TimeUnit -> Maybe (Date, Text)
context2date
context
timeUnit
=
do
context2date
context
timeUnit
=
do
let
hyperdata
=
_context_hyperdata
context
let
hyperdata
=
_context_hyperdata
context
let
let
year
=
fromMaybe
1
$
_hd_publication_year
hyperdata
year
=
fromMaybe
1
$
_hd_publication_year
hyperdata
month
=
fromMaybe
1
$
_hd_publication_month
hyperdata
month
=
fromMaybe
1
$
_hd_publication_month
hyperdata
day
=
fromMaybe
1
$
_hd_publication_day
hyperdata
day
=
fromMaybe
1
$
_hd_publication_day
hyperdata
pure
(
toPhyloDate
year
month
day
timeUnit
,
toPhyloDate'
year
month
day
timeUnit
)
hour
=
fromMaybe
1
$
_hd_publication_hour
hyperdata
minute
=
fromMaybe
1
$
_hd_publication_minute
hyperdata
second'
=
fromMaybe
1
$
_hd_publication_second
hyperdata
pure
(
toPhyloDate
year
month
day
hour
minute
second'
timeUnit
,
toPhyloDate'
year
month
day
hour
minute
second'
timeUnit
)
---------------
---------------
-- | Dates | --
-- | Dates | --
---------------
---------------
toMonths
::
Int
eger
->
Int
->
Int
->
Date
toMonths
::
Int
->
Int
->
Int
->
Date
toMonths
y
m
d
=
fromIntegral
$
cdMonths
toMonths
y
m
d
=
fromIntegral
$
cdMonths
$
diffGregorianDurationClip
(
fromGregorian
y
m
d
)
$
diffGregorianDurationClip
(
fromGregorian
(
fromIntegral
y
)
m
d
)
(
fromGregorian
0000
0
0
)
(
fromGregorian
0000
0
0
)
toDays
::
Int
eger
->
Int
->
Int
->
Date
toDays
::
Int
->
Int
->
Int
->
Date
toDays
y
m
d
=
fromIntegral
toDays
y
m
d
=
fromIntegral
$
diffDays
(
fromGregorian
y
m
d
)
(
fromGregorian
0000
0
0
)
$
diffDays
(
fromGregorian
(
fromIntegral
y
)
m
d
)
(
fromGregorian
0000
0
0
)
toPhyloDate
::
Int
->
Int
->
Int
->
TimeUnit
->
Date
-- Convert UTCTime to seconds since year 0
toPhyloDate
y
m
d
tu
=
case
tu
of
utcTimeToSecondsFromYear0
::
UTCTime
->
Integer
Year
{}
->
y
utcTimeToSecondsFromYear0
utcTime
=
Month
{}
->
toMonths
(
Prelude
.
toInteger
y
)
m
d
let
posixSeconds
=
utcTimeToPOSIXSeconds
utcTime
Week
{}
->
div
(
toDays
(
Prelude
.
toInteger
y
)
m
d
)
7
-- POSIX epoch is 1970-01-01, need to add seconds from year 0 to 1970
Day
{}
->
toDays
(
Prelude
.
toInteger
y
)
m
d
year0To1970Seconds
=
1970
*
365.25
*
24
*
3600
-- Approximate
_
->
panic
"[G.C.V.Phylo.API] toPhyloDate"
in
floor
(
posixSeconds
+
year0To1970Seconds
)
toPhyloDate'
::
Int
->
Int
->
Int
->
TimeUnit
->
Text
toPhyloDate'
y
_m
_d
(
Epoch
{})
=
pack
$
show
$
posixSecondsToUTCTime
$
fromIntegral
y
toHours
::
Int
->
Int
->
Int
->
Int
->
Date
toPhyloDate'
y
m
d
_
=
pack
$
showGregorian
$
fromGregorian
(
toInteger
y
)
m
d
toHours
y
m
d
hh
=
fromIntegral
$
(
utcTimeToSecondsFromYear0
$
makeUTCTime
y
m
d
hh
0
0
)
`
div
`
(
60
*
60
)
toMinutes
::
Int
->
Int
->
Int
->
Int
->
Int
->
Date
toMinutes
y
m
d
hh
mm
=
fromIntegral
$
(
utcTimeToSecondsFromYear0
$
makeUTCTime
y
m
d
hh
mm
0
)
`
div
`
60
toSeconds
::
Int
->
Int
->
Int
->
Int
->
Int
->
Int
->
Date
toSeconds
y
m
d
hh
mm
ss
=
fromIntegral
$
utcTimeToSecondsFromYear0
$
makeUTCTime
y
m
d
hh
mm
ss
-- | This is kinda like a hashing function that assigns different
-- 'Date' (in fact an 'Int') to different period, depending on the
-- 'TimeUnit'
toPhyloDate
::
Int
->
Int
->
Int
->
Int
->
Int
->
Int
->
TimeUnit
->
Date
toPhyloDate
y
m
d
hh
mm
ss
tu
=
case
tu
of
Year
{}
->
y
Month
{}
->
toMonths
y
m
d
Week
{}
->
div
(
toDays
y
m
d
)
7
Day
{}
->
toDays
y
m
d
Hour
{}
->
toHours
y
m
d
hh
Minute
{}
->
toMinutes
y
m
d
hh
mm
Second
{}
->
toSeconds
y
m
d
hh
mm
ss
Epoch
{}
->
panic
"[G.C.V.Phylo.API.Tools] toPhyloDate doesn't support Epoch"
toPhyloDate'
::
Int
->
Int
->
Int
->
Int
->
Int
->
Int
->
TimeUnit
->
Text
toPhyloDate'
y
_m
_d
_hh
_mm
_ss
(
Epoch
{})
=
pack
$
show
$
posixSecondsToUTCTime
$
fromIntegral
y
toPhyloDate'
y
m
d
_hh
_mm
_ss
(
Year
{})
=
pack
$
showGregorian
$
fromGregorian
(
toInteger
y
)
m
d
toPhyloDate'
y
m
d
_hh
_mm
_ss
(
Month
{})
=
pack
$
showGregorian
$
fromGregorian
(
toInteger
y
)
m
d
toPhyloDate'
y
m
d
_hh
_mm
_ss
(
Week
{})
=
pack
$
showGregorian
$
fromGregorian
(
toInteger
y
)
m
d
toPhyloDate'
y
m
d
_hh
_mm
_ss
(
Day
{})
=
pack
$
showGregorian
$
fromGregorian
(
toInteger
y
)
m
d
toPhyloDate'
y
m
d
hh
_mm
_ss
(
Hour
{})
=
pack
$
formatTime
defaultTimeLocale
"%Y-%m-%d %H"
$
makeUTCTime
y
m
d
hh
0
0
toPhyloDate'
y
m
d
hh
mm
_ss
(
Minute
{})
=
pack
$
formatTime
defaultTimeLocale
"%Y-%m-%d %H:%M"
$
makeUTCTime
y
m
d
hh
mm
0
toPhyloDate'
y
m
d
hh
mm
ss
(
Second
{})
=
pack
$
formatTime
defaultTimeLocale
"%Y-%m-%d %H:%M:%S"
$
makeUTCTime
y
m
d
hh
mm
ss
-- Utils
-- Utils
...
...
src/Gargantext/Core/Viz/Phylo/PhyloTools.hs
View file @
3d407136
...
@@ -174,11 +174,14 @@ toLstDate ds = snd
...
@@ -174,11 +174,14 @@ toLstDate ds = snd
getTimeScale
::
Phylo
->
[
Char
]
getTimeScale
::
Phylo
->
[
Char
]
getTimeScale
p
=
case
(
timeUnit
$
getConfig
p
)
of
getTimeScale
p
=
case
(
timeUnit
$
getConfig
p
)
of
Epoch
{}
->
"epoch"
Epoch
{}
->
"epoch"
Year
{}
->
"year"
Year
{}
->
"year"
Month
{}
->
"month"
Month
{}
->
"month"
Week
{}
->
"week"
Week
{}
->
"week"
Day
{}
->
"day"
Day
{}
->
"day"
Hour
{}
->
"hour"
Minute
{}
->
"minute"
Second
{}
->
"second"
-- | Get a regular & ascendante timeScale from a given list of dates
-- | Get a regular & ascendante timeScale from a given list of dates
...
@@ -190,11 +193,14 @@ toTimeScale dates step =
...
@@ -190,11 +193,14 @@ toTimeScale dates step =
getTimeStep
::
TimeUnit
->
Int
getTimeStep
::
TimeUnit
->
Int
getTimeStep
time
=
case
time
of
getTimeStep
time
=
case
time
of
Epoch
{
..
}
->
_epoch_step
Epoch
{
..
}
->
_epoch_step
Year
{
..
}
->
_year_step
Year
{
..
}
->
_year_step
Month
{
..
}
->
_month_step
Month
{
..
}
->
_month_step
Week
{
..
}
->
_week_step
Week
{
..
}
->
_week_step
Day
{
..
}
->
_day_step
Day
{
..
}
->
_day_step
Hour
{
..
}
->
_hour_step
Minute
{
..
}
->
_minute_step
Second
{
..
}
->
_second_step
getTimePeriod
::
TimeUnit
->
Int
getTimePeriod
::
TimeUnit
->
Int
getTimePeriod
time
=
case
time
of
getTimePeriod
time
=
case
time
of
...
@@ -203,6 +209,9 @@ getTimePeriod time = case time of
...
@@ -203,6 +209,9 @@ getTimePeriod time = case time of
Month
{
..
}
->
_month_period
Month
{
..
}
->
_month_period
Week
{
..
}
->
_week_period
Week
{
..
}
->
_week_period
Day
{
..
}
->
_day_period
Day
{
..
}
->
_day_period
Hour
{
..
}
->
_hour_period
Minute
{
..
}
->
_minute_period
Second
{
..
}
->
_second_period
getTimeFrame
::
TimeUnit
->
Int
getTimeFrame
::
TimeUnit
->
Int
getTimeFrame
time
=
case
time
of
getTimeFrame
time
=
case
time
of
...
@@ -211,6 +220,9 @@ getTimeFrame time = case time of
...
@@ -211,6 +220,9 @@ getTimeFrame time = case time of
Month
{
..
}
->
_month_matchingFrame
Month
{
..
}
->
_month_matchingFrame
Week
{
..
}
->
_week_matchingFrame
Week
{
..
}
->
_week_matchingFrame
Day
{
..
}
->
_day_matchingFrame
Day
{
..
}
->
_day_matchingFrame
Hour
{
..
}
->
_hour_matchingFrame
Minute
{
..
}
->
_minute_matchingFrame
Second
{
..
}
->
_second_matchingFrame
-------------
-------------
-- | Fis | --
-- | Fis | --
...
...
src/Gargantext/Database/Query/Table/NodeContext.hs
View file @
3d407136
...
@@ -20,7 +20,7 @@ commentary with @some markup@.
...
@@ -20,7 +20,7 @@ commentary with @some markup@.
module
Gargantext.Database.Query.Table.NodeContext
module
Gargantext.Database.Query.Table.NodeContext
(
module
Gargantext
.
Database
.
Schema
.
NodeContext
(
module
Gargantext
.
Database
.
Schema
.
NodeContext
,
queryNodeContextTable
,
queryNodeContextTable
,
selectDocs
Date
s
,
selectDocs
Year
s
,
selectDocNodes
,
selectDocNodes
,
selectDocNodesOnlyId
,
selectDocNodesOnlyId
,
selectDocs
,
selectDocs
...
@@ -44,12 +44,12 @@ module Gargantext.Database.Query.Table.NodeContext
...
@@ -44,12 +44,12 @@ module Gargantext.Database.Query.Table.NodeContext
import
Control.Arrow
(
returnA
)
import
Control.Arrow
(
returnA
)
import
Control.Lens
(
view
)
import
Control.Lens
(
view
)
import
Data.Text
(
splitOn
)
import
Data.Time
(
UTCTime
)
import
Data.Time
(
UTCTime
)
import
Database.PostgreSQL.Simple
qualified
as
PGS
(
In
(
..
),
Query
,
Only
(
..
))
import
Database.PostgreSQL.Simple
qualified
as
PGS
(
In
(
..
),
Query
,
Only
(
..
))
import
Database.PostgreSQL.Simple.SqlQQ
(
sql
)
import
Database.PostgreSQL.Simple.SqlQQ
(
sql
)
import
Database.PostgreSQL.Simple.Types
(
Values
(
..
),
QualifiedIdentifier
(
..
))
import
Database.PostgreSQL.Simple.Types
(
Values
(
..
),
QualifiedIdentifier
(
..
))
import
Gargantext.Core
(
HasDBid
(
toDBid
)
)
import
Gargantext.Core
(
HasDBid
(
toDBid
)
)
import
Gargantext.Core.Utils.DateUtils
(
dateParts
)
import
Gargantext.Database.Admin.Types.Node
import
Gargantext.Database.Admin.Types.Node
import
Gargantext.Database.Admin.Types.Hyperdata.Document
(
HyperdataDocument
,
hd_publication_date
)
import
Gargantext.Database.Admin.Types.Hyperdata.Document
(
HyperdataDocument
,
hd_publication_date
)
import
Gargantext.Database.Admin.Types.Hyperdata.Prelude
(
Hyperdata
)
import
Gargantext.Database.Admin.Types.Hyperdata.Prelude
(
Hyperdata
)
...
@@ -379,9 +379,8 @@ selectCountDocs cId = mkOpaCountQuery (queryCountDocs cId)
...
@@ -379,9 +379,8 @@ selectCountDocs cId = mkOpaCountQuery (queryCountDocs cId)
returnA
-<
c
returnA
-<
c
-- | TODO use UTCTime fast
selectDocsYears
::
HasDBid
NodeType
=>
CorpusId
->
DBQuery
err
x
[
Text
]
selectDocsDates
::
HasDBid
NodeType
=>
CorpusId
->
DBQuery
err
x
[
Text
]
selectDocsYears
cId
=
map
(
head'
"G.D.Q.T.NodeContext.selectDocsYears"
.
dateParts
)
selectDocsDates
cId
=
map
(
head'
"selectDocsDates"
.
splitOn
"-"
)
<$>
catMaybes
<$>
catMaybes
<$>
map
(
view
hd_publication_date
)
<$>
map
(
view
hd_publication_date
)
<$>
selectDocs
cId
<$>
selectDocs
cId
...
...
src/Gargantext/Database/Query/Table/NodeNode.hs
View file @
3d407136
...
@@ -32,7 +32,7 @@ module Gargantext.Database.Query.Table.NodeNode
...
@@ -32,7 +32,7 @@ module Gargantext.Database.Query.Table.NodeNode
,
isNodeReadOnly
,
isNodeReadOnly
,
selectDocNodes
,
selectDocNodes
,
selectDocs
,
selectDocs
,
selectDocs
Date
s
,
selectDocs
Year
s
,
selectPublicNodes
,
selectPublicNodes
,
selectPublishedNodes
,
selectPublishedNodes
...
@@ -56,8 +56,8 @@ import Control.Lens (view)
...
@@ -56,8 +56,8 @@ import Control.Lens (view)
import
Database.PostgreSQL.Simple
qualified
as
PGS
import
Database.PostgreSQL.Simple
qualified
as
PGS
import
Database.PostgreSQL.Simple.SqlQQ
(
sql
)
import
Database.PostgreSQL.Simple.SqlQQ
(
sql
)
import
Database.PostgreSQL.Simple.Types
(
Values
(
..
),
QualifiedIdentifier
(
..
),
Only
(
..
))
import
Database.PostgreSQL.Simple.Types
(
Values
(
..
),
QualifiedIdentifier
(
..
),
Only
(
..
))
import
Data.Text
(
splitOn
)
import
Gargantext.Core
(
HasDBid
(
toDBid
)
)
import
Gargantext.Core
(
HasDBid
(
toDBid
)
)
import
Gargantext.Core.Utils.DateUtils
(
dateParts
)
import
Gargantext.Database.Admin.Types.Hyperdata.Document
(
HyperdataDocument
,
hd_publication_date
)
import
Gargantext.Database.Admin.Types.Hyperdata.Document
(
HyperdataDocument
,
hd_publication_date
)
import
Gargantext.Database.Admin.Types.Hyperdata.Prelude
(
Hyperdata
)
import
Gargantext.Database.Admin.Types.Hyperdata.Prelude
(
Hyperdata
)
import
Gargantext.Database.Admin.Types.Node
import
Gargantext.Database.Admin.Types.Node
...
@@ -222,9 +222,8 @@ _selectCountDocs cId = mkOpaCountQuery (queryCountDocs cId)
...
@@ -222,9 +222,8 @@ _selectCountDocs cId = mkOpaCountQuery (queryCountDocs cId)
-- | TODO use UTCTime fast
selectDocsYears
::
HasDBid
NodeType
=>
CorpusId
->
DBQuery
err
x
[
Text
]
selectDocsDates
::
HasDBid
NodeType
=>
CorpusId
->
DBQuery
err
x
[
Text
]
selectDocsYears
cId
=
map
(
head'
"G.D.Q.T.NodeNode.selectDocsYears"
.
dateParts
)
selectDocsDates
cId
=
map
(
head'
"selectDocsDates"
.
splitOn
"-"
)
<$>
catMaybes
<$>
catMaybes
<$>
map
(
view
hd_publication_date
)
<$>
map
(
view
hd_publication_date
)
<$>
selectDocs
cId
<$>
selectDocs
cId
...
...
test/Test/Core/Utils.hs
View file @
3d407136
...
@@ -11,28 +11,54 @@ Portability : POSIX
...
@@ -11,28 +11,54 @@ Portability : POSIX
module
Test.Core.Utils
where
module
Test.Core.Utils
where
import
Data.Time
(
toGregorian
,
utctDay
,
utctDayTime
)
import
Data.Time.LocalTime
(
TimeOfDay
(
..
),
timeOfDayToTime
)
import
Gargantext.Core.Utils
import
Gargantext.Core.Utils
import
Gargantext.Core.Utils.DateUtils
(
dateParts
,
parseFlexibleTime
)
import
Gargantext.Prelude
import
Gargantext.Prelude
import
Test.Hspec
import
Test.Hspec
-- | Core.Utils tests
-- | Core.Utils tests
test
::
Spec
test
::
Spec
test
=
do
test
=
do
describe
"check if groupWithCounts works"
$
do
describe
"array utils work"
$
do
it
"simple integer array"
$
groupWithCounts
testArray
`
shouldBe
`
groupedArray
describe
"check if groupWithCounts works"
$
do
it
"string"
$
groupWithCounts
testString
`
shouldBe
`
groupedString
it
"simple integer array"
$
do
describe
"check nonemptyIntercalate"
$
do
let
testArray
::
[
Int
]
it
"empty list"
$
nonemptyIntercalate
","
[]
`
shouldBe
`
""
testArray
=
[
1
,
2
,
3
,
1
,
2
,
3
]
it
"simple list"
$
nonemptyIntercalate
","
[
"x"
]
`
shouldBe
`
"x"
groupedArray
::
[(
Int
,
Int
)]
it
"two-element list"
$
nonemptyIntercalate
","
[
"x"
,
"y"
]
`
shouldBe
`
"x,y"
groupedArray
=
[(
1
,
2
),
(
2
,
2
),
(
3
,
2
)]
it
"with empty strings"
$
nonemptyIntercalate
","
[
"a"
,
""
,
"b"
,
""
,
"c"
,
""
]
`
shouldBe
`
"a,b,c"
groupWithCounts
testArray
`
shouldBe
`
groupedArray
where
it
"string"
$
do
testArray
::
[
Int
]
let
testString
::
[
Char
]
testArray
=
[
1
,
2
,
3
,
1
,
2
,
3
]
testString
=
"abccba"
groupedArray
::
[(
Int
,
Int
)]
groupedString
::
[(
Char
,
Int
)]
groupedArray
=
[(
1
,
2
),
(
2
,
2
),
(
3
,
2
)]
groupedString
=
[(
'a'
,
2
),
(
'b'
,
2
),
(
'c'
,
2
)]
testString
::
[
Char
]
groupWithCounts
testString
`
shouldBe
`
groupedString
testString
=
"abccba"
describe
"check nonemptyIntercalate"
$
do
groupedString
::
[(
Char
,
Int
)]
it
"empty list"
$
nonemptyIntercalate
","
[]
`
shouldBe
`
""
groupedString
=
[(
'a'
,
2
),
(
'b'
,
2
),
(
'c'
,
2
)]
it
"simple list"
$
nonemptyIntercalate
","
[
"x"
]
`
shouldBe
`
"x"
it
"two-element list"
$
nonemptyIntercalate
","
[
"x"
,
"y"
]
`
shouldBe
`
"x,y"
it
"with empty strings"
$
nonemptyIntercalate
","
[
"a"
,
""
,
"b"
,
""
,
"c"
,
""
]
`
shouldBe
`
"a,b,c"
describe
"DateUtils works"
$
do
describe
"parseFlexibleTime works"
$
do
it
"ISO8601 format works 1"
$
do
let
parsed
=
parseFlexibleTime
"2025-05-04T12:05:01.000Z"
(
toGregorian
.
utctDay
)
<$>
parsed
`
shouldBe
`
(
Just
(
2025
,
5
,
4
))
utctDayTime
<$>
parsed
`
shouldBe
`
(
Just
$
timeOfDayToTime
$
TimeOfDay
12
5
1
)
it
"ISO8601 format works 2"
$
do
let
parsed
=
parseFlexibleTime
"2025-05-04T12:05:01Z"
(
toGregorian
.
utctDay
)
<$>
parsed
`
shouldBe
`
(
Just
(
2025
,
5
,
4
))
utctDayTime
<$>
parsed
`
shouldBe
`
(
Just
$
timeOfDayToTime
$
TimeOfDay
12
5
1
)
it
"'2025-07-20 01:00:13 UTC' format works"
$
do
let
parsed
=
parseFlexibleTime
"2025-07-20 01:00:13 UTC"
(
toGregorian
.
utctDay
)
<$>
parsed
`
shouldBe
`
(
Just
(
2025
,
7
,
20
))
utctDayTime
<$>
parsed
`
shouldBe
`
(
Just
$
timeOfDayToTime
$
TimeOfDay
1
0
13
)
describe
"dateParts works"
$
do
it
"ISO8601 format works 1"
$
dateParts
"2025-05-04T12:05:01.000Z"
`
shouldBe
`
[
"2025"
,
"05"
,
"04"
]
it
"ISO8601 format works 2"
$
dateParts
"2025-05-04T12:05:01Z"
`
shouldBe
`
[
"2025"
,
"05"
,
"04"
]
it
"'2025-07-20 01:00:13 UTC' format works"
$
dateParts
"2025-07-20 01:00:13 UTC"
`
shouldBe
`
[
"2025"
,
"07"
,
"20"
]
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