Commit 1ddc5819 authored by Ben Gamari's avatar Ben Gamari 🐢

Add missing file

parent 795869f7
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
module MeasurementTree where
import Data.Align
import Data.These
import Data.String (IsString)
import Control.Applicative
import Control.Monad
import Data.Aeson
import qualified Data.Map.Strict as M
import GHC.Generics
import qualified Data.ByteString.Lazy as BSL
newtype Label = Label { getLabel :: [String] }
deriving (Eq, Ord, Show, Monoid, Semigroup,
ToJSON, FromJSON, ToJSONKey, FromJSONKey)
instance IsString Label where
fromString s = Label [s]
type MeasurementTree = MeasurementTree' Double
data MeasurementTree' a = Sample a
-- ^ A measurement result
| Group (M.Map Label (MeasurementTree' a))
-- ^ A group of related measurements.
deriving (Functor, Generic)
instance ToJSON a => ToJSON (MeasurementTree' a) where
toJSON (Sample x) = toJSON x
toJSON (Group x) = object [ "type" .= ("group" :: String)
, "children" .= x
]
instance FromJSON a => FromJSON (MeasurementTree' a) where
parseJSON v = parseGroup v <|> fmap Sample (parseJSON v)
where
parseGroup = withObject "group" $ \o -> do
typ <- o .: "type"
guard $ typ == ("group" :: String)
Group <$> o .: "children"
--instance ToJSON a => ToJSON (MeasurementTree' a)
--instance FromJSON a => FromJSON (MeasurementTree' a)
singleton :: Label -> MeasurementTree' a -> MeasurementTree' a
singleton name = Group . M.singleton name
singletonSample :: Label -> a -> MeasurementTree' a
singletonSample name = singleton name . Sample
isSample :: MeasurementTree' a -> Maybe a
isSample (Sample x) = Just x
isSample _ = Nothing
writeFile' :: ToJSON a => FilePath -> MeasurementTree' a -> IO ()
writeFile' fname = BSL.writeFile fname . encode
writeFile :: FilePath -> MeasurementTree -> IO ()
writeFile = writeFile'
readFile' :: FromJSON a => FilePath -> IO (Maybe (MeasurementTree' a))
readFile' fname = decode <$> BSL.readFile fname
readFile :: FilePath -> IO (Maybe MeasurementTree)
readFile = readFile'
group :: [(Label, MeasurementTree' a)] -> MeasurementTree' a
group = Group . M.fromList
collect :: RealFrac a => [MeasurementTree' a] -> MeasurementTree' [a]
collect = go [""]
where
isSample (Sample _) = True
isSample _ = False
isGroup = not . isSample
go path trees
| all isSample trees = Sample [ x | Sample x <- trees ]
| all isGroup trees =
Group $ M.mapWithKey (\k ts -> go (k:path) ts) $ M.fromListWith (<>)
[ (k,[t])
| Group xs <- trees
, (k,t) <- M.toList xs
]
| otherwise = error $ "Measurement tree type mismatch at " ++ show path
flatten :: MeasurementTree' a -> [([Label], a)]
flatten = go []
where
go path (Group xs) = foldMap (\(label,x) -> go (label:path) x) (M.toList xs)
go path (Sample x) = [(reverse path, x)]
mean :: RealFrac a => [a] -> a
mean xs = sum xs / realToFrac (length xs)
geomMean :: RealFloat a => [a] -> a
geomMean = exp . mean . map log
stdDev :: RealFloat a => [a] -> a
stdDev xs = sqrt $ mean $ map (\x -> (x-m)^(2::Int)) xs
where m = mean xs
instance Semialign MeasurementTree' where
align (Sample x) (Sample y) = Sample $ These x y
align (Group x) (Group y) = let f (This a) = fmap This a
f (That b) = fmap That b
f (These a b) = align a b
in Group $ alignWith f x y
align (Sample x) _ = Sample $ This x
align _ (Sample y) = Sample $ That y
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