Commit fb994e16 authored by Valentin Reis's avatar Valentin Reis
Browse files

Merge branch 'sensor-tests' into 'master'

Adds sensor unit tests and bugfixes.

See merge request !60
parents 19e0c3d0 f325af9f
Pipeline #11355 passed with stages
in 3 minutes and 5 seconds
......@@ -9,11 +9,14 @@
- name: [NoOverloadedLists]
- name: [QuasiQuotes]
- name: [ScopedTypeVariables]
- name: [NoRecordWildCards]
- name: [TypeApplications]
- flags:
- default: false
- {name: ["-fno-warn-partial-fields","-fno-warn-orphans"]}
- {name: ["-fno-warn-partial-fields","-fno-warn-orphans","-fno-warn-monomorphism-restriction",
"-fno-warn-missing-export-lists"]}
- {name: ["-F -pgmF tasty-discover -optF --tree-display"]}
- {name: ["-fno-warn-missing-signatures"], within: ["Export", "PyExport"]}
- modules:
......
packages: hsnrm/
hsnrm-bin/
hsnrm-extra/
tests: true
......@@ -12,8 +12,10 @@ let defexts =
, types.Extension.RankNTypes True
, types.Extension.TypeSynonymInstances True
, types.Extension.StandaloneDeriving True
, types.Extension.NamedFieldPuns True
, types.Extension.FlexibleInstances True
, types.Extension.TupleSections True
, types.Extension.ScopedTypeVariables True
, types.Extension.MultiParamTypeClasses True
, types.Extension.ImplicitPrelude False
, types.Extension.OverloadedStrings True
......@@ -95,6 +97,9 @@ let deps =
, iso-deriving = nobound "iso-deriving"
, pretty-simple = nobound "pretty-simple"
, protolude = nobound "protolude"
, tasty = nobound "tasty"
, tasty-hunit = nobound "tasty-hunit"
, tasty-discover = nobound "tasty-discover"
, Chart = nobound "Chart"
, Chart-cairo = nobound "Chart-cairo"
, gtk3 = nobound "gtk3"
......
......@@ -28,15 +28,15 @@ executable nrm.so
default-language: Haskell2010
default-extensions: LambdaCase QuasiQuotes DefaultSignatures
OverloadedLists ExistentialQuantification RecordWildCards
RankNTypes TypeSynonymInstances StandaloneDeriving
FlexibleInstances TupleSections MultiParamTypeClasses
NoImplicitPrelude OverloadedStrings ViewPatterns PatternSynonyms
DeriveFunctor DeriveTraversable TypeFamilies DeriveAnyClass
DeriveGeneric DeriveDataTypeable OverloadedLabels DeriveFoldable
DerivingStrategies TypeApplications MultiWayIf NoTemplateHaskell
BlockArguments GADTs FlexibleContexts TypeOperators DataKinds
PolyKinds AllowAmbiguousTypes FunctionalDependencies
UndecidableInstances
RankNTypes TypeSynonymInstances StandaloneDeriving NamedFieldPuns
FlexibleInstances TupleSections ScopedTypeVariables
MultiParamTypeClasses NoImplicitPrelude OverloadedStrings
ViewPatterns PatternSynonyms DeriveFunctor DeriveTraversable
TypeFamilies DeriveAnyClass DeriveGeneric DeriveDataTypeable
OverloadedLabels DeriveFoldable DerivingStrategies TypeApplications
MultiWayIf NoTemplateHaskell BlockArguments GADTs FlexibleContexts
TypeOperators DataKinds PolyKinds AllowAmbiguousTypes
FunctionalDependencies UndecidableInstances
extra-lib-dirs: /nix/store/lz67bgzcwjf8wf23j2cb69g01pa7x4sf-ghc-8.6.5/lib/ghc-8.6.5/rts/
ghc-options: -Wall -O0 -Wcompat -Wincomplete-uni-patterns
-Wmissing-home-modules -Widentities -Wredundant-constraints
......@@ -62,15 +62,15 @@ executable nrm
default-language: Haskell2010
default-extensions: LambdaCase QuasiQuotes DefaultSignatures
OverloadedLists ExistentialQuantification RecordWildCards
RankNTypes TypeSynonymInstances StandaloneDeriving
FlexibleInstances TupleSections MultiParamTypeClasses
NoImplicitPrelude OverloadedStrings ViewPatterns PatternSynonyms
DeriveFunctor DeriveTraversable TypeFamilies DeriveAnyClass
DeriveGeneric DeriveDataTypeable OverloadedLabels DeriveFoldable
DerivingStrategies TypeApplications MultiWayIf NoTemplateHaskell
BlockArguments GADTs FlexibleContexts TypeOperators DataKinds
PolyKinds AllowAmbiguousTypes FunctionalDependencies
UndecidableInstances
RankNTypes TypeSynonymInstances StandaloneDeriving NamedFieldPuns
FlexibleInstances TupleSections ScopedTypeVariables
MultiParamTypeClasses NoImplicitPrelude OverloadedStrings
ViewPatterns PatternSynonyms DeriveFunctor DeriveTraversable
TypeFamilies DeriveAnyClass DeriveGeneric DeriveDataTypeable
OverloadedLabels DeriveFoldable DerivingStrategies TypeApplications
MultiWayIf NoTemplateHaskell BlockArguments GADTs FlexibleContexts
TypeOperators DataKinds PolyKinds AllowAmbiguousTypes
FunctionalDependencies UndecidableInstances
ghc-options: -Wall -O0 -Wcompat -Wincomplete-uni-patterns
-Wmissing-home-modules -Widentities -Wredundant-constraints
-Wcpp-undef -fwarn-tabs -fwarn-unused-imports
......
......@@ -28,15 +28,15 @@ executable pynrm.so
default-language: Haskell2010
default-extensions: LambdaCase QuasiQuotes DefaultSignatures
OverloadedLists ExistentialQuantification RecordWildCards
RankNTypes TypeSynonymInstances StandaloneDeriving
FlexibleInstances TupleSections MultiParamTypeClasses
NoImplicitPrelude OverloadedStrings ViewPatterns PatternSynonyms
DeriveFunctor DeriveTraversable TypeFamilies DeriveAnyClass
DeriveGeneric DeriveDataTypeable OverloadedLabels DeriveFoldable
DerivingStrategies TypeApplications MultiWayIf NoTemplateHaskell
BlockArguments GADTs FlexibleContexts TypeOperators DataKinds
PolyKinds AllowAmbiguousTypes FunctionalDependencies
UndecidableInstances
RankNTypes TypeSynonymInstances StandaloneDeriving NamedFieldPuns
FlexibleInstances TupleSections ScopedTypeVariables
MultiParamTypeClasses NoImplicitPrelude OverloadedStrings
ViewPatterns PatternSynonyms DeriveFunctor DeriveTraversable
TypeFamilies DeriveAnyClass DeriveGeneric DeriveDataTypeable
OverloadedLabels DeriveFoldable DerivingStrategies TypeApplications
MultiWayIf NoTemplateHaskell BlockArguments GADTs FlexibleContexts
TypeOperators DataKinds PolyKinds AllowAmbiguousTypes
FunctionalDependencies UndecidableInstances
extra-lib-dirs: /nix/store/lz67bgzcwjf8wf23j2cb69g01pa7x4sf-ghc-8.6.5/lib/ghc-8.6.5/rts/
ghc-options: -Wall -O0 -Wcompat -Wincomplete-uni-patterns
-Wmissing-home-modules -Widentities -Wredundant-constraints
......
......@@ -108,15 +108,15 @@ library
default-language: Haskell2010
default-extensions: LambdaCase QuasiQuotes DefaultSignatures
OverloadedLists ExistentialQuantification RecordWildCards
RankNTypes TypeSynonymInstances StandaloneDeriving
FlexibleInstances TupleSections MultiParamTypeClasses
NoImplicitPrelude OverloadedStrings ViewPatterns PatternSynonyms
DeriveFunctor DeriveTraversable TypeFamilies DeriveAnyClass
DeriveGeneric DeriveDataTypeable OverloadedLabels DeriveFoldable
DerivingStrategies TypeApplications MultiWayIf NoTemplateHaskell
BlockArguments GADTs FlexibleContexts TypeOperators DataKinds
PolyKinds AllowAmbiguousTypes FunctionalDependencies
UndecidableInstances
RankNTypes TypeSynonymInstances StandaloneDeriving NamedFieldPuns
FlexibleInstances TupleSections ScopedTypeVariables
MultiParamTypeClasses NoImplicitPrelude OverloadedStrings
ViewPatterns PatternSynonyms DeriveFunctor DeriveTraversable
TypeFamilies DeriveAnyClass DeriveGeneric DeriveDataTypeable
OverloadedLabels DeriveFoldable DerivingStrategies TypeApplications
MultiWayIf NoTemplateHaskell BlockArguments GADTs FlexibleContexts
TypeOperators DataKinds PolyKinds AllowAmbiguousTypes
FunctionalDependencies UndecidableInstances
ghc-options: -Wall -O0 -Wcompat -Wincomplete-uni-patterns
-Wmissing-home-modules -Widentities -Wredundant-constraints
-Wcpp-undef -fwarn-tabs -fwarn-unused-imports
......@@ -192,3 +192,40 @@ library
filepath -any,
lens -any
test-suite discover
type: exitcode-stdio-1.0
main-is: Driver.hs
hs-source-dirs: tests
other-modules:
Test.CPD.Integrated
default-language: Haskell2010
default-extensions: LambdaCase QuasiQuotes DefaultSignatures
OverloadedLists ExistentialQuantification RecordWildCards
RankNTypes TypeSynonymInstances StandaloneDeriving NamedFieldPuns
FlexibleInstances TupleSections ScopedTypeVariables
MultiParamTypeClasses NoImplicitPrelude OverloadedStrings
ViewPatterns PatternSynonyms DeriveFunctor DeriveTraversable
TypeFamilies DeriveAnyClass DeriveGeneric DeriveDataTypeable
OverloadedLabels DeriveFoldable DerivingStrategies TypeApplications
MultiWayIf NoTemplateHaskell BlockArguments GADTs FlexibleContexts
TypeOperators DataKinds PolyKinds AllowAmbiguousTypes
FunctionalDependencies UndecidableInstances
ghc-options: -Wall -O0 -Wcompat -Wincomplete-uni-patterns
-Wmissing-home-modules -Widentities -Wredundant-constraints
-Wcpp-undef -fwarn-tabs -fwarn-unused-imports
-fwarn-missing-signatures -fwarn-name-shadowing
-fprint-potential-instances -Wmissing-export-lists
-fwarn-unused-do-bind -fwarn-wrong-do-bind
-fwarn-incomplete-patterns -Wincomplete-record-updates
-Wmonomorphism-restriction -Wimplicit-prelude
-Wmissing-local-signatures -Wmissing-exported-signatures
-Wmissing-export-lists -Wmissing-home-modules -Widentities
-Wredundant-constraints -Wpartial-fields -threaded
build-depends:
base -any,
protolude -any,
hsnrm -any,
tasty-hunit -any,
tasty -any,
tasty-discover -any
......@@ -24,6 +24,27 @@ in λ(ghcPath : Text)
}
⫽ common.copts ([] : List Text)
)
, test-suites =
[ { name = "discover"
, test-suite =
λ(config : types.Config)
→ prelude.defaults.TestSuite
⫽ { type =
types.TestType.exitcode-stdio { main-is = "Driver.hs" }
, other-modules = [ "Test.CPD.Integrated" ]
, build-depends =
[ common.deps.base
, common.deps.protolude
, common.nobound "hsnrm"
, common.deps.tasty-hunit
, common.deps.tasty
, common.deps.tasty-discover
]
, hs-source-dirs = [ "tests" ]
}
⫽ common.copts [ "-threaded" ]
}
]
, extra-source-files = [] : List Text
, license = types.License.BSD3
, license-files = [] : List Text
......
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE NoRecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-partial-fields #-}
-- |
......@@ -10,17 +11,20 @@ module CPD.Integrated
( Integrator (..),
IntegratorAction (..),
MeasurementState (..),
M (..),
trapezoidArea,
initIntegrator,
measureValue,
squeeze,
averageArea,
)
where
--calculate,
--Calculate (..),
import CPD.Core
import Control.Lens
import qualified Data.Aeson as A
import Data.Data
import Data.Generics.Labels ()
import Data.JSON.Schema
import qualified Data.Map as M
import Data.MessagePack
......@@ -33,90 +37,108 @@ data Integrator
= Integrator
{ tLast :: Time,
minimumControlInterval :: Time,
measured :: Map SensorID MeasurementState
measured :: Map SensorID (MeasurementState M)
}
deriving (Generic)
trapezoidArea :: (Time, Double) -> (Time, Double) -> Double
trapezoidArea (t1, v1) (t2, v2) =
min v1 v2 * fromuS (t2 - t1)
+ abs (v2 - v1)
/ (2 * fromuS (t2 - t1))
measureValue :: Time -> (Time, Double) -> MeasurementState -> MeasurementState
measureValue thresholdTime (newTime, newValue) Never
| thresholdTime <= newTime = Done newValue newTime newValue
| otherwise = Running newTime newTime newValue newValue
measureValue _ (newTime, newValue) (Done totalAvg _lastTime _lastValue) =
Done totalAvg newTime newValue
measureValue thresholdTime (newTime, newValue) (Running firstT lastT lastV avg)
| newTime < thresholdTime =
Running
{ firstTime = firstT,
lastTime = newTime,
lastValue = newValue,
average =
( trapezoidArea (lastT, lastV) (newTime, newValue)
+ avg
* fromuS (lastT - firstT)
)
/ fromuS (newTime - firstT)
}
| otherwise =
Done
{ lastTimeDone = newTime,
lastValueDone = newValue,
totalAverageDone =
( trapezoidArea (lastT, lastV) (newTime, newValue)
+ avg
* fromuS (lastT - firstT)
)
/ fromuS (newTime - firstT)
}
data MeasurementState a
= Never -- no value received in this measurement period yet
| Discarded -- first value received and discarded, ready to start measuring
| Running a -- measurements ongoing
| Done a -- measurements complete, but still absorbing values
deriving (Show, Eq, Data, MessagePack, Generic, Inject, Interpret, Functor)
squeeze ::
Time ->
Map SensorID MeasurementState ->
Maybe (Map SensorID Double, Map SensorID MeasurementState)
squeeze _t mstM =
if all isDone (M.elems mstM)
then Just (mstM <&> totalAverageDone, newMeasurements)
else Nothing
where
newMeasurements = mstM <&> newround
newround (Done _totalAverageDone lastTimeDone lastValueDone) =
Running lastTimeDone lastTimeDone lastValueDone lastValueDone
newround _ = Never
isDone Done {} = True
isDone _ = False
data MeasurementState
= Never
| Running
instance Applicative MeasurementState where
pure = Running
Never <*> _ = Never
Discarded <*> _ = Discarded
Running f <*> m = fmap f m
Done f <*> m = fmap f m
deriving via GenericJSON (MeasurementState a) instance (JSONSchema a) => JSONSchema (MeasurementState a)
deriving via GenericJSON (MeasurementState a) instance (A.ToJSON a) => A.ToJSON (MeasurementState a)
deriving via GenericJSON (MeasurementState a) instance (A.FromJSON a) => A.FromJSON (MeasurementState a)
data M
= M
{ firstTime :: Time,
lastTime :: Time,
lastValue :: Double,
average :: Double
}
| Done
{ totalAverageDone :: Double,
lastTimeDone :: Time,
lastValueDone :: Double
area :: Double
}
deriving (Show, Data, MessagePack, Generic, Inject, Interpret)
deriving (Show, Eq, Data, MessagePack, Generic, Inject, Interpret)
deriving
(JSONSchema, A.ToJSON, A.FromJSON)
via GenericJSON MeasurementState
via GenericJSON M
data IntegratorAction = IntegratorPasses | TriggerStep Integrator
trapezoidArea :: (Time, Double) -> (Time, Double) -> Double
trapezoidArea (t1, v1) (t2, v2) =
if deltaT <= 0 then 0 else min v1 v2 * deltaT + (abs (v2 - v1) * deltaT / 2)
where
deltaT = fromuS (t2 - t1)
measureValue :: Time -> (Time, Double) -> MeasurementState M -> MeasurementState M
measureValue delta (newTime, newValue) = \case
Never -> Discarded
Discarded -> Running initial
Done m -> Done $ measure m
Running m ->
( if newTime >= delta + firstTime m
then Done
else Running
)
$ measure m
where
initial = M newTime newTime newValue 0
measure = measureM newTime newValue
measureM :: Time -> Double -> M -> M
measureM newTime newValue M {firstTime, lastTime, lastValue, area} =
M
{ firstTime = firstTime,
lastTime = newTime,
lastValue = newValue,
area = trapezoidArea (lastTime, lastValue) (newTime, newValue) + area
}
averageArea :: M -> Double
averageArea M {firstTime, lastTime, area} = area / fromuS (lastTime - firstTime)
squeeze ::
Time ->
Map SensorID (MeasurementState M) ->
Maybe (Map SensorID Double, Map SensorID (MeasurementState M))
squeeze _t mstM =
case traverse throughTuple (M.toList mstM) of
Done (M.fromList -> m) -> Just (m <&> averageArea, m <&> newround)
_ -> Nothing
where
throughTuple :: Functor f => (a, f b) -> f (a, b)
throughTuple (id, m) = (id,) <$> m
newround :: M -> MeasurementState M
newround M {lastTime, lastValue} =
Running $
M
{ firstTime = lastTime,
lastTime = lastTime,
lastValue = lastValue,
area = lastValue
}
initIntegrator ::
Time ->
Time ->
[SensorID] ->
Integrator
initIntegrator t tmin sensorIDs = Integrator
{ tLast = t,
minimumControlInterval = tmin,
measured = M.fromList (sensorIDs <&> (,Never))
}
initIntegrator t tmin sensorIDs =
Integrator
{ tLast = t,
minimumControlInterval = tmin,
measured = M.fromList (sensorIDs <&> (,Never))
}
......@@ -23,27 +23,34 @@ type LensMap s k a = M.Map k (ScopedLens s a)
class HasLensMap s k a where
lenses :: s -> LensMap s k a
instance (Ord k, Ord key, HasLensMap (k, v) key a) => HasLensMap (M.Map k v) key a where
lenses s = M.fromList . mconcat $ M.toList s <&> \(k, v) -> go k (lenses (k, v))
where
go ::
forall key k v a.
(Ord k) =>
k ->
M.Map key (ScopedLens (k, v) a) ->
[(key, ScopedLens (M.Map k v) a)]
go k lensMap =
M.toList lensMap <&> second (augmentedLens k)
augmentedLens ::
forall k v a.
Ord k =>
k ->
ScopedLens (k, v) a ->
ScopedLens (M.Map k v) a
augmentedLens k = addPath $ lens getter setter
where
getter m = fromJust $ M.lookup k m <&> (k,)
setter m (_, value) = M.insert k value m
go ::
forall key k v a.
(Ord k) =>
k ->
M.Map key (ScopedLens (k, v) a) ->
[(key, ScopedLens (M.Map k v) a)]
go k lensMap =
M.toList lensMap <&> second (augmentedLens k)
augmentedLens ::
forall k v a.
Ord k =>
k ->
ScopedLens (k, v) a ->
ScopedLens (M.Map k v) a
augmentedLens k = addPath $ lens getter setter
where
getter m = fromJust $ M.lookup k m <&> (k,)
setter m (_, value) = M.insert k value m
instance
(Ord k, Ord key, HasLensMap (k, v) key a) =>
HasLensMap (M.Map k v) key a
where
lenses s =
M.fromList . mconcat $
M.toList s
<&> \(k, v) -> go k (lenses (k, v))
addPath :: Lens' s' s -> ScopedLens s a -> ScopedLens s' a
addPath l (ScopedLens sl) = ScopedLens (l . sl)
......@@ -135,7 +135,7 @@ banditCartesianProductControl ccfg cpd (Event t ms) mRefActions = do
delta
( measuredM
& ix sensorID
%~ measureValue (tlast + delta) (sensorTime, sensorValue)
%~ measureValue delta (sensorTime, sensorValue)
)
tryControlStep ccfg cpd t mRefActions
......
......@@ -32,6 +32,10 @@ newtype Dummy a = Dummy a
emptyRuntime :: Dummy (Map SliceID a)
emptyRuntime = Dummy $ fromList []
killIfRegistered :: (MonadIO m) => ApplicationProcess -> m ()
killIfRegistered (Registered _ pid) = liftIO $ signalProcess Signals.sigKILL pid
killIfRegistered (Unregistered _) = pass
instance (MonadIO m) => SliceRuntime m DummyRuntime () () where
doEnableRuntime _ = return $ Right emptyRuntime
......@@ -39,10 +43,6 @@ instance (MonadIO m) => SliceRuntime m DummyRuntime () () where
doDisableRuntime (Dummy m) = do
for_ m $ mapM_ killIfRegistered
return $ Right emptyRuntime
where
killIfRegistered :: (MonadIO m) => ApplicationProcess -> m ()
killIfRegistered (Registered _ pid) = liftIO $ signalProcess Signals.sigKILL pid
killIfRegistered (Unregistered _) = pass
doCreateSlice runtime () =
liftIO $
......
{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-}
{-# OPTIONS_GHC -fno-warn-missing-export-lists #-}
{-# OPTIONS_GHC -fno-warn-monomorphism-restriction #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Test.CPD.Integrated where
import CPD.Integrated
import NRM.Types.Units
import Protolude hiding (one, zero)
import Test.Tasty.HUnit
unit_trapezoidArea :: IO ()
unit_trapezoidArea = do
trapezoidArea (1, 1) (1, 1) @?= 0
trapezoidArea (0, 1) (0.5, 1) @?= 0.5
trapezoidArea (0, 1) (1, 1) @?= 1
trapezoidArea (0, 0) (1, 1) @?= 0.5
trapezoidArea (0, 0) (2, 1) @?= 1
trapezoidArea (0, 2) (2, 2) @?= 4
trapezoidArea (0, 2) (2, 3) @?= 5
trapezoidArea (0, 3) (2, 2) @?= 5
trapezoidArea (0, 1) (1, 0) @?= 0.5
trapezoidArea (1, 0) (2, 1) @?= 0.5
trapezoidArea (2, 1) (10, 1) @?= 8
unit_measureValue :: IO ()
unit_measureValue = do
feed Never [(0, 1)] @?= Discarded
Running
( M
{ firstTime = 2,
lastTime = 2,
lastValue = 1,
area = 0
}
)
@=? feed Never [(1, 1), (2, 1)]
Running
( M
{ firstTime = 1,
lastTime = 1,
lastValue = 1,
area = 0
}
)
@=? feed Never [(0, 1), (1, 1)]
Done
( M
{ firstTime = 1,
lastTime = 11,
lastValue = 1,
area = 10
}
)
@=? feed Never [(0, 0), (1, 1), (2, 1), (11, 1)]
-- |
-- |
-- 1 |
-- |\
-- 0 L_\__________________
-- 0 1 2 3 4 5 6 7 8 9 10
Done 0.5 @=? feedAvg Never [(0, 0), (1, 1), (2, 0), (11, 0)]
-- |
-- |
-- 1 | ________________
-- |\ /
-- 0 L_\/_________________
-- 0 1 2 3 4 5 6 7 8 9 10
Running 8 @=? feedAvg Never [(0, 0), (1, 1), (2, 0), (3, 1), (10, 1)]
Done 9 @=? feedAvg Never [(0, 0), (1, 1), (2, 0), (3, 1), (11, 1)]
Done 10 @=? feedAvg Never [(0, 0), (1, 1), (11, 1)]
Done
( M
{ firstTime = 0,
lastTime = 2,
lastValue = 2,
area = arbitrary + 1.50
}
)
@=? feed
( Done $
M
{ firstTime = 0,
lastTime = 1,
lastValue = 1,
area = arbitrary
}
)
[(2, 2)]
where
feed :: MeasurementState M -> [(Time, Double)] -> MeasurementState M
feed initialState ts = execState (for_ ts (modify . measure)) initialState
feedAvg i ts = area <$> feed i ts