currycarbon 0.5.0.0 → 0.6.0.0
raw patch · 14 files changed
+508/−140 lines, 14 filesdep +bytestringdep +cassavadep +textdep ~file-embeddep ~randomPVP ok
version bump matches the API change (PVP)
Dependencies added: bytestring, cassava, text, unordered-containers
Dependency ranges changed: file-embed, random
API changes (from Hackage documentation)
- Currycarbon.CLI.RunCalibrate: [_calibrateExprFiles] :: CalibrateOptions -> [FilePath]
- Currycarbon.CLI.RunCalibrate: [_calibrateExprs] :: CalibrateOptions -> [NamedCalExpr]
- Currycarbon.Calibration.Utils: interpolateCalCurve :: CalCurveBP -> CalCurveBP
+ Currycarbon: CombProduct :: CombinationStrategy
+ Currycarbon: CombSum :: CombinationStrategy
+ Currycarbon: TSV :: FilePath -> Header -> Vector TSVRow -> TSV
+ Currycarbon: TSVRow :: String -> Maybe (ListColumn String) -> Maybe (ListColumn Word) -> Maybe (ListColumn Word) -> Maybe Int -> Maybe Int -> TSVRow
+ Currycarbon: [_tsvFile] :: TSV -> FilePath
+ Currycarbon: [_tsvHeader] :: TSV -> Header
+ Currycarbon: [_tsvRowDateBCADStart] :: TSVRow -> Maybe Int
+ Currycarbon: [_tsvRowDateBCADStop] :: TSVRow -> Maybe Int
+ Currycarbon: [_tsvRowDateC14Labnr] :: TSVRow -> Maybe (ListColumn String)
+ Currycarbon: [_tsvRowDateC14UncalBPErr] :: TSVRow -> Maybe (ListColumn Word)
+ Currycarbon: [_tsvRowDateC14UncalBP] :: TSVRow -> Maybe (ListColumn Word)
+ Currycarbon: [_tsvRowID] :: TSVRow -> String
+ Currycarbon: [_tsvRows] :: TSV -> Vector TSVRow
+ Currycarbon: data CombinationStrategy
+ Currycarbon: data TSV
+ Currycarbon: data TSVRow
+ Currycarbon: evalNamedCalExpr :: CalibrationMethod -> CalibrateDatesConf -> CalCurveBP -> NamedCalExpr -> Either CurrycarbonException CalPDF
+ Currycarbon: readTSV :: FilePath -> IO TSV
+ Currycarbon: tsv2NamedCalExprs :: CombinationStrategy -> TSV -> [Either CurrycarbonException NamedCalExpr]
+ Currycarbon: writeRandomAgeSamples :: FilePath -> [RandomAgeSample] -> IO ()
+ Currycarbon.CLI.RunCalibrate: CalibrateExprFile :: FilePath -> CalibrateInput
+ Currycarbon.CLI.RunCalibrate: CalibrateExprs :: [NamedCalExpr] -> CalibrateInput
+ Currycarbon.CLI.RunCalibrate: CalibrateTSVFile :: FilePath -> CombinationStrategy -> CalibrateInput
+ Currycarbon.CLI.RunCalibrate: [_calibrateInput] :: CalibrateOptions -> CalibrateInput
+ Currycarbon.CLI.RunCalibrate: data CalibrateInput
+ Currycarbon.CalCurves: interpolateCalCurve :: CalCurveBP -> CalCurveBP
+ Currycarbon.Calibration.Calibration: validateCalPDF :: CalPDF -> Either CurrycarbonException ()
+ Currycarbon.TSV: CombProduct :: CombinationStrategy
+ Currycarbon.TSV: CombSum :: CombinationStrategy
+ Currycarbon.TSV: ListColumn :: [a] -> ListColumn a
+ Currycarbon.TSV: TSV :: FilePath -> Header -> Vector TSVRow -> TSV
+ Currycarbon.TSV: TSVRow :: String -> Maybe (ListColumn String) -> Maybe (ListColumn Word) -> Maybe (ListColumn Word) -> Maybe Int -> Maybe Int -> TSVRow
+ Currycarbon.TSV: [_tsvFile] :: TSV -> FilePath
+ Currycarbon.TSV: [_tsvHeader] :: TSV -> Header
+ Currycarbon.TSV: [_tsvRowDateBCADStart] :: TSVRow -> Maybe Int
+ Currycarbon.TSV: [_tsvRowDateBCADStop] :: TSVRow -> Maybe Int
+ Currycarbon.TSV: [_tsvRowDateC14Labnr] :: TSVRow -> Maybe (ListColumn String)
+ Currycarbon.TSV: [_tsvRowDateC14UncalBPErr] :: TSVRow -> Maybe (ListColumn Word)
+ Currycarbon.TSV: [_tsvRowDateC14UncalBP] :: TSVRow -> Maybe (ListColumn Word)
+ Currycarbon.TSV: [_tsvRowID] :: TSVRow -> String
+ Currycarbon.TSV: [_tsvRows] :: TSV -> Vector TSVRow
+ Currycarbon.TSV: [getListColumn] :: ListColumn a -> [a]
+ Currycarbon.TSV: cleanInput :: Maybe ByteString -> Maybe ByteString
+ Currycarbon.TSV: data CombinationStrategy
+ Currycarbon.TSV: data TSV
+ Currycarbon.TSV: data TSVRow
+ Currycarbon.TSV: decodingOptions :: DecodeOptions
+ Currycarbon.TSV: filterLookup :: FromField a => NamedRecord -> ByteString -> Parser a
+ Currycarbon.TSV: filterLookupMulti :: FromField a => NamedRecord -> [ByteString] -> Parser a
+ Currycarbon.TSV: filterLookupOptional :: FromField a => NamedRecord -> ByteString -> Parser (Maybe a)
+ Currycarbon.TSV: foldC14 :: CombinationStrategy -> [(String, Word, Word)] -> CalExpr
+ Currycarbon.TSV: instance Data.Csv.Conversion.FromField a => Data.Csv.Conversion.FromField (Currycarbon.TSV.ListColumn a)
+ Currycarbon.TSV: instance Data.Csv.Conversion.FromNamedRecord Currycarbon.TSV.TSVRow
+ Currycarbon.TSV: instance GHC.Classes.Eq a => GHC.Classes.Eq (Currycarbon.TSV.ListColumn a)
+ Currycarbon.TSV: instance GHC.Classes.Ord a => GHC.Classes.Ord (Currycarbon.TSV.ListColumn a)
+ Currycarbon.TSV: instance GHC.Show.Show Currycarbon.TSV.CombinationStrategy
+ Currycarbon.TSV: instance GHC.Show.Show Currycarbon.TSV.TSVRow
+ Currycarbon.TSV: instance GHC.Show.Show a => GHC.Show.Show (Currycarbon.TSV.ListColumn a)
+ Currycarbon.TSV: newtype ListColumn a
+ Currycarbon.TSV: parseCombinationStrategy :: Parser CombinationStrategy
+ Currycarbon.TSV: readCombinationStrategy :: String -> Either String CombinationStrategy
+ Currycarbon.TSV: readTSV :: FilePath -> IO TSV
+ Currycarbon.TSV: tsv2NamedCalExprs :: CombinationStrategy -> TSV -> [Either CurrycarbonException NamedCalExpr]
+ Currycarbon.TSV: tsvRow2NamedCalExprs :: CombinationStrategy -> TSVRow -> Either CurrycarbonException NamedCalExpr
+ Currycarbon.Types: eitherToFail :: MonadFail m => Either CurrycarbonException b -> m b
+ Currycarbon.Types: makeTimeWindowBCAD :: String -> YearBCAD -> YearBCAD -> Either CurrycarbonException TimeWindowBCAD
+ Currycarbon.Types: makeTimeWindowBP :: String -> YearBP -> YearBP -> Either CurrycarbonException TimeWindowBP
+ Currycarbon.Utils: CurrycarbonMakeCalExprException :: String -> CurrycarbonException
+ Currycarbon.Utils: CurrycarbonTSV2CalExprException :: String -> CurrycarbonException
+ Currycarbon.Utils: CurrycarbonTSVParsingException :: String -> CurrycarbonException
- Currycarbon: renderCalDatePretty :: Bool -> (NamedCalExpr, CalPDF, CalC14) -> String
+ Currycarbon: renderCalDatePretty :: Bool -> CalCurveBP -> Bool -> (NamedCalExpr, CalPDF, CalC14) -> String
- Currycarbon.CLI.RunCalibrate: CalibrateOptions :: [NamedCalExpr] -> [FilePath] -> CalCurveSelection -> CalibrationMethod -> Bool -> Bool -> Bool -> Bool -> Bool -> String -> Maybe FilePath -> Maybe FilePath -> Maybe FilePath -> Maybe (Maybe Word, Word, FilePath) -> Maybe FilePath -> Maybe FilePath -> CalibrateOptions
+ Currycarbon.CLI.RunCalibrate: CalibrateOptions :: CalibrateInput -> CalCurveSelection -> CalibrationMethod -> Bool -> Bool -> Bool -> Bool -> Bool -> String -> Maybe FilePath -> Maybe FilePath -> Maybe FilePath -> Maybe (Maybe Word, Word, FilePath) -> Maybe FilePath -> Maybe FilePath -> CalibrateOptions
- Currycarbon.Parsers: renderCLIPlotCalCurve :: Bool -> Int -> Int -> CalPDF -> NamedCalExpr -> String
+ Currycarbon.Parsers: renderCLIPlotCalCurve :: Bool -> Int -> Int -> CalCurveBP -> CalPDF -> NamedCalExpr -> String
- Currycarbon.Parsers: renderCalDatePretty :: Bool -> (NamedCalExpr, CalPDF, CalC14) -> String
+ Currycarbon.Parsers: renderCalDatePretty :: Bool -> CalCurveBP -> Bool -> (NamedCalExpr, CalPDF, CalC14) -> String
Files
- CHANGELOG.md +8/−0
- README.md +42/−12
- currycarbon.cabal +8/−3
- src-executables/Main-currycarbon.hs +49/−9
- src/Currycarbon.hs +37/−16
- src/Currycarbon/CLI/RunCalibrate.hs +85/−35
- src/Currycarbon/CalCurves.hs +34/−0
- src/Currycarbon/Calibration/Calibration.hs +15/−7
- src/Currycarbon/Calibration/Utils.hs +4/−34
- src/Currycarbon/Parsers.hs +26/−23
- src/Currycarbon/TSV.hs +171/−0
- src/Currycarbon/Types.hs +16/−0
- src/Currycarbon/Utils.hs +12/−1
- test/GoldenSpec.hs +1/−0
CHANGELOG.md view
@@ -1,3 +1,11 @@+- V 0.6.0.0:+ - New input method: Read .tsv files in a Poseidon .janno file-inspired format.+ - Simplified CLI input options: Either read calibration expressions directly from the command line, or read them from one expression file (now called `--inputExprFile`), or read them from one .tsv file (`--inputTSVFile`). Combining the input methods or reading from multiple files at once is not possible any more.+ - Added a lower limit for the size of the calibration curve segment in `getRelevantCalCurveSegment`.+ - Added a mechanism to collect and show calibration errors at the end of a sequence of dates.+ - Separated command line output with visual separators of the form `--- 1 ---`, `--- 2 ---`, etc.+ - Fixed the calibration curve command line plot: It was always set to an interpolated `intcal20`, no matter the context. Now it properly considers the input settings.+ - Turned off command line plots for the `--noInterpolation` case; the plotting code assumes year-wise resolution and is not trivial to adjust. - V 0.5.0.0: Cleaned up parser error behaviour: - Parsing errors are now more helpful with better positional information, using a modified `showParsecErr` and a new `showParsecErrOneLine`. - Breaking change: The type of `readCalCurve` changed. It is now safe, returning `Either String CalCurveBP`. The old version is preserved in `readCalCurveUnsafe`.
README.md view
@@ -32,10 +32,11 @@ ``` ```-currycarbon v0.4.0.2 (UTF-8)+currycarbon v0.6.0.0 (UTF-8) Method: Bchron {distribution = StudentTDist {ndf = 100.0}} Curve: IntCal20 Calibrating...+--- 1 --- CalEXPR: [1] Sample1:4990±30BP Calibrated: 3936BC >> 3794BC > 3757BC < 3662BC << 3654BC 1-sigma: 3794-3707BC, 3666-3662BC@@ -63,10 +64,14 @@ ──────────────── ─ ─────────── ────────────────── ────── Done.+---+No breaking issues. ``` ```-Usage: currycarbon [--version] [CalEXPRs] [-i|--inputFile FILE]+Usage: currycarbon [--version]+ [[CalEXPRs] | (-i|--inputExprFile FILE) |+ (-t|--inputTSVFile FILE) [--combStrat Sum | Product]] [--calCurve IntCal20 | SHCal20 | Marine20 | FILE] [--method DSL] [--allowOutside] [--noInterpolation] [--noTrimCalCurve] [--noTrimOutCalPDF] [-q|--quiet]@@ -120,14 +125,34 @@ 3. Compile a complex, named expression: "Ex3: ((3000,30) + (3100,40)) * rangeBP(3200,3000)" ---- -i,--inputFile FILE A file with a list of calibration expressions.+ -i,--inputExprFile FILE A file with a list of calibration expressions. Formatted just as CalEXPRs, but with a new line for- each input expression. CalEXPRs and --inputFile can- be combined and you can provide multiple instances of- --inputFile. Note that syntactic sugar allows to read- simple radiocarbon dates from a headless .csv file- with one sample per row: <sample name>,<mean age- BP>,<one sigma standard deviation>.+ each input expression. Note that syntactic sugar+ allows to read simple radiocarbon dates from a+ headless .csv file with one sample per row: <sample+ name>,<mean age BP>,<one sigma standard deviation>.+ -t,--inputTSVFile FILE A tab-separated file with dates to calibrate. Can+ read Poseidon .janno files, which inspire this input+ format. The rows are transformed to calibration+ expressions upon reading, following a priority order+ based on the provided columns:+ - <Date_ID> (or <Poseidon_ID>):+ Mandatory identifier, used in calExpr(id = <id>).+ - <Date_C14_Labnr> <Date_C14_Uncal_BP>+ <Date_C14_Uncal_BP_Err>:+ Gets transformed to uncalC14(id = <labnr>, yearBP =+ <bp>, sigma = <err>). Each of these columns can be a+ list column with multiple entries separated by ;.+ Multiple uncalibrated dates are then combined with+ the strategy set in --combStrat when they are+ evaluated.+ - <Date_BC_AD_Start> <Date_BC_AD_Stop>:+ Gets transformed to rangeBCAD(start = <start>, stop =+ <stop>).+ --combStrat Sum | Product+ Strategy that should be applied to combine multiple+ C14 ages (uncalC14) from one row when reading from+ --inputTSVFile. (default: Product) --calCurve IntCal20 | SHCal20 | Marine20 | FILE Either one of the included calibration curves, or a file path to an calibration curve file in '.14c'@@ -204,11 +229,16 @@ `stack` allows to upload a release candidate with ```-stack haddock --haddock-for-hackage-stack upload . --test-tarball --candidate --documentation --no-save-hackage-creds+stack upload . --test-tarball --candidate --no-save-hackage-creds ``` -using my Hackage credentials.+using my Hackage credentials. It can then be published at https://hackage.haskell.org/package/currycarbon/candidates++The building of the haddock documentation can be tested with++```+stack haddock --haddock-for-hackage+``` #### Preparing a new stable release
currycarbon.cabal view
@@ -1,5 +1,5 @@ name: currycarbon-version: 0.5.0.0+version: 0.6.0.0 synopsis: A package for simple, fast radiocarbon calibration description: Radiocarbon calibration library and command line tool. homepage: https://github.com/nevrome/currycarbon@@ -30,6 +30,7 @@ Currycarbon.ParserHelpers Currycarbon.Parsers Currycarbon.SumCalibration+ Currycarbon.TSV Currycarbon.Types Currycarbon.Utils hs-source-dirs:@@ -41,8 +42,12 @@ , vector >= 0.12 && < 0.14 , math-functions >= 0.3 && < 0.4 , MonadRandom >= 0.6 && < 1- , random > 1.2 && < 1.4- , file-embed > 0.0.11.1 && < 0.1.0.0+ , random >= 1.2 && < 1.4+ , file-embed >= 0.0.11.1 && < 0.1+ , cassava >= 0.5 && < 0.6+ , bytestring >= 0.10.8 && < 0.13+ , unordered-containers >= 0.2.7.1 && < 0.3+ , text >= 1.2.2.1 && < 2.2 default-language: Haskell2010
src-executables/Main-currycarbon.hs view
@@ -1,9 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} import Currycarbon.CalCurves-import Currycarbon.CLI.RunCalibrate (CalibrateOptions (..),+import Currycarbon.CLI.RunCalibrate (CalibrateInput (..),+ CalibrateOptions (..), runCalibrate) import Currycarbon.Parsers+import Currycarbon.TSV import Currycarbon.Types import Currycarbon.Utils import Paths_currycarbon (version)@@ -57,8 +59,7 @@ optParser = CmdCalibrate <$> calibrateOptParser calibrateOptParser :: OP.Parser CalibrateOptions-calibrateOptParser = CalibrateOptions <$> optParseNamedCalExprString- <*> optParseNamedCalExprFromFile+calibrateOptParser = CalibrateOptions <$> optParseCalibrateInput <*> optParseCalCurveSelection <*> optParseCalibrationMethod <*> optParseAllowOutside@@ -79,6 +80,11 @@ -- $inputParsing -- -- These functions define and handle the CLI input arguments+optParseCalibrateInput :: OP.Parser CalibrateInput+optParseCalibrateInput =+ (CalibrateExprs <$> optParseNamedCalExprString)+ OP.<|> (CalibrateExprFile <$> optParseNamedCalExprFromFile)+ OP.<|> (CalibrateTSVFile <$> optParseInputTSVFile <*> optParseCombStrat) optParseNamedCalExprString :: OP.Parser [NamedCalExpr] optParseNamedCalExprString = concat <$> OP.many (OP.argument (OP.eitherReader readNamedCalExprs) (@@ -132,19 +138,53 @@ s2d :: String -> OH.Doc s2d str = OH.fillSep $ map OH.pretty $ words str -optParseNamedCalExprFromFile :: OP.Parser [FilePath]-optParseNamedCalExprFromFile = OP.many (OP.strOption (- OP.long "inputFile" <>+optParseNamedCalExprFromFile :: OP.Parser FilePath+optParseNamedCalExprFromFile = OP.strOption (+ OP.long "inputExprFile" <> OP.short 'i' <> OP.metavar "FILE" <> OP.help "A file with a list of calibration expressions. \ \Formatted just as CalEXPRs, but with a new line for each input expression. \- \CalEXPRs and --inputFile can be combined and you can provide multiple \- \instances of --inputFile. \ \Note that syntactic sugar allows to read simple radiocarbon dates from \ \a headless .csv file with one sample per row: \ \<sample name>,<mean age BP>,<one sigma standard deviation>."- ))+ )++optParseInputTSVFile :: OP.Parser FilePath+optParseInputTSVFile = OP.strOption (+ OP.long "inputTSVFile" <>+ OP.short 't' <>+ OP.metavar "FILE" <>+ OP.helpDoc ( Just (+ s2d "A tab-separated file with dates to calibrate. Can read Poseidon .janno files, \+ \which inspire this input format. The rows are transformed to calibration expressions \+ \upon reading, following a priority order based on the provided columns:"+ <> OH.hardline <>+ s2d "- <Date_ID> (or <Poseidon_ID>):"+ <> OH.hardline <>+ s2d "Mandatory identifier, used in calExpr(id = <id>)."+ <> OH.hardline <>+ s2d "- <Date_C14_Labnr> <Date_C14_Uncal_BP> <Date_C14_Uncal_BP_Err>:"+ <> OH.hardline <>+ s2d "Gets transformed to uncalC14(id = <labnr>, yearBP = <bp>, sigma = <err>). \+ \Each of these columns can be a list column with multiple entries separated by ;. \+ \Multiple uncalibrated dates are then combined with the strategy set in --combStrat \+ \when they are evaluated."+ <> OH.hardline <>+ s2d "- <Date_BC_AD_Start> <Date_BC_AD_Stop>:"+ <> OH.hardline <>+ s2d "Gets transformed to rangeBCAD(start = <start>, stop = <stop>)."+ )))++optParseCombStrat :: OP.Parser CombinationStrategy+optParseCombStrat = OP.option (OP.eitherReader readCombinationStrategy) (+ OP.long "combStrat" <>+ OP.metavar "Sum | Product" <>+ OP.help "Strategy that should be applied to combine multiple C14 ages (uncalC14) \+ \from one row when reading from --inputTSVFile." <>+ OP.value CombProduct <>+ OP.showDefault+ ) optParseCalCurveSelection :: OP.Parser CalCurveSelection optParseCalCurveSelection = OP.option (OP.eitherReader readCalCurveSelection) (
src/Currycarbon.hs view
@@ -5,17 +5,17 @@ module Currycarbon ( - -- * Calibration+ -- * Basic calibration -- $calibration calibrateDates, -- ** Configuration CalibrationMethod (..), CalibrateDatesConf (..), defaultCalConf,- -- ** Input+ -- ** Basic input UncalC14 (..), readUncalC14FromFile,- -- ** Output+ -- ** Basic output CalPDF (..), writeCalPDFs, @@ -42,20 +42,30 @@ writeCalC14HDRs, renderCalDatePretty, + -- * Drawing random samples from CalPDFs+ -- $randsamp+ AgeSamplingConf (..),+ sampleAgesFromCalPDF,+ RandomAgeSample (..),+ writeRandomAgeSamples,+ -- * Sum (and product) calibration -- $sumcal evalCalExpr,+ evalNamedCalExpr, CalExpr (..), addPDFs, multiplyPDFs, normalizeCalPDF, trimLowDensityEdgesCalPDF, - -- * Drawing random samples from CalPDFs- -- $randsamp- AgeSamplingConf (..),- sampleAgesFromCalPDF,- RandomAgeSample (..)+ -- * Reading input from .tsv files+ -- $tsv+ TSV (..),+ TSVRow (..),+ readTSV,+ tsv2NamedCalExprs,+ CombinationStrategy (..) ) where import Currycarbon.CalCurves@@ -64,6 +74,7 @@ trimLowDensityEdgesCalPDF) import Currycarbon.Parsers import Currycarbon.SumCalibration+import Currycarbon.TSV import Currycarbon.Types {- $calibration@@ -128,6 +139,18 @@ result for a given sample. -} +{- $randsamp++Another common requirement for archaeological data analysis is temporal resampling,+where random age samples are drawn from 'CalPDF's according to the probability+density distribution.++currycarbon supports this with 'sampleAgesFromCalPDF', which takes a configuration+data type 'AgeSamplingConf' including a random number generator and the number of+requested age samples, and an arbitrary 'CalPDF'. It returns an object of type+'RandomAgeSample' with a vector of sampled 'YearBCAD's.+-}+ {- $sumcal Calculating the sum or product of two calibration curves is a common@@ -142,14 +165,12 @@ -} -{- $randsamp+{- $tsv -Another common requirement for archaeological data analysis is temporal resampling,-where random age samples are drawn from 'CalPDF's according to the probability-density distribution.+Currycarbon can read calibration expressions from a tab-separated (.tsv)+file format inspired by the [Poseidon](https://www.poseidon-adna.org) .janno file.+`tsv2NamedCalExprs` turns the 'TSV' input to 'NamedCalExpr's, prioritizing+C14 age information over "contextual" start and stop ranges, to hook it into+the calibration pipeline. -currycarbon supports this with 'sampleAgesFromCalPDF', which takes a configuration-data type 'AgeSamplingConf' including a random number generator and the number of-requested age samples, and an arbitrary 'CalPDF'. It returns an object of type-'RandomAgeSample' with a vector of sampled 'YearBCAD's. -}
src/Currycarbon/CLI/RunCalibrate.hs view
@@ -1,24 +1,27 @@+{-# LANGUAGE LambdaCase #-}+ module Currycarbon.CLI.RunCalibrate- (CalibrateOptions (..), runCalibrate) where+ (CalibrateOptions (..), CalibrateInput (..), runCalibrate) where import Currycarbon.CalCurves import Currycarbon.Calibration.Calibration import Currycarbon.Calibration.Utils import Currycarbon.Parsers import Currycarbon.SumCalibration+import Currycarbon.TSV import Currycarbon.Types import Currycarbon.Utils import Control.Exception (throwIO) import Control.Monad (unless, when) import Data.Maybe (fromJust, isJust)+import System.Exit (exitFailure, exitSuccess) import System.IO (hPutStrLn, stderr) import qualified System.Random as R -- | A data type to represent the options to the CLI module function runCalibrate data CalibrateOptions = CalibrateOptions {- _calibrateExprs :: [NamedCalExpr] -- ^ String listing the uncalibrated dates that should be calibrated- , _calibrateExprFiles :: [FilePath] -- ^ List of files with uncalibrated dates to be calibrated+ _calibrateInput :: CalibrateInput , _calibrateCalCurveFile :: CalCurveSelection -- ^ Either a preloaded calibration curve or a path to a .14c file , _calibrateCalibrationMethod :: CalibrationMethod -- ^ Calibration algorithm that should be used , _calibrateAllowOutside :: Bool -- ^ Allow calibration to run outside of the range of the calibration curve@@ -35,11 +38,18 @@ , _calibrateCalCurveMatrixFile :: Maybe FilePath -- ^ Path to an output file } +-- | A data type with input options for the calibration+data CalibrateInput =+ CalibrateExprs [NamedCalExpr] -- ^ String listing the uncalibrated dates in CalExpr format that should be calibrated+ | CalibrateExprFile FilePath -- ^ A file with uncalibrated dates in CalExpr to be calibrated+ | CalibrateTSVFile FilePath CombinationStrategy -- ^ A file with uncalibrated dates in .tsv format to be calibrated and+ -- a strategy to combine multiple C14 ages+ -- | Interface function to trigger calibration from the command line runCalibrate :: CalibrateOptions -> IO () runCalibrate ( CalibrateOptions- exprs exprFiles+ input calCurveSelection method allowOutside noInterpolate noTrimCalCurve noTrimOutCalPDF quiet encoding basicFile densityFile hdrFile@@ -48,9 +58,17 @@ ) = do let ascii = encoding /= "UTF-8" -- compile dates- exprsFromFile <- mapM readNamedCalExprsFromFile exprFiles- let exprsCombined = exprs ++ concat exprsFromFile- exprsRenamed = replaceEmptyNames exprsCombined+ (errOrExprs,_) <- case input of+ CalibrateExprs exprs -> do+ return (map Right exprs, Nothing)+ CalibrateExprFile path -> do+ exprs <- readNamedCalExprsFromFile path+ return (map Right exprs, Nothing)+ CalibrateTSVFile path combStrat -> do+ tsv <- readTSV path+ let exprs = tsv2NamedCalExprs combStrat tsv+ return (exprs, Just tsv)+ let exprsRenamed = replaceEmptyNames errOrExprs if null exprsRenamed then hPutStrLn stderr "Nothing to calibrate. See currycarbon -h for help" else do@@ -69,7 +87,8 @@ -- handle the special debug cases when (isJust calCurveSegmentFile || isJust calCurveMatrixFile) $ do case exprsRenamed of- [NamedCalExpr _ (UnCalDate uncal)] -> do+ [Left e] -> throwIO e+ [Right (NamedCalExpr _ (UnCalDate uncal))] -> do let calCurveSegment = prepareCalCurveSegment (not noInterpolate) $ getRelevantCalCurveSegment uncal calCurve when (isJust calCurveSegmentFile) $@@ -83,7 +102,7 @@ \a single uncalibrated radiocarbon date." -- run calibration hPutStrLn stderr "Calibrating..."- let errorOrCalPDFs = map (evalNamedCalExpr method calConf calCurve) exprsRenamed+ let errorOrCalPDFs = fmap (either Left (evalNamedCalExpr method calConf calCurve)) exprsRenamed -- trim output calRes = if not noTrimOutCalPDF then map (mapEither id trimLowDensityEdgesCalPDF) errorOrCalPDFs@@ -95,41 +114,67 @@ Nothing -> Just <$> R.initStdGen Just seed -> return $ Just $ R.mkStdGen (fromIntegral seed) -- prepare and write the output per expression- handleExprs ascii True calCurve maybeRNG $ zip exprsRenamed calRes- where+ handleExprs ascii True maybeRNG calCurve $ zip3 [1..] exprsRenamed calRes+ -- final conclusion+ let calibrationErrors =+ [ (i, e)+ | (i, Left e) <- zip [1..] calRes+ ]+ refinementErrors =+ [ (i, e)+ | (i, Right calPDF) <- zip [1..] calRes+ , Left e <- [validateCalPDF calPDF]+ ]+ errors = calibrationErrors ++ refinementErrors+ if null errors+ then do+ hPutStrLn stderr "---"+ hPutStrLn stderr "No breaking issues."+ exitSuccess+ else do+ hPutStrLn stderr "---"+ hPutStrLn stderr "Failed expressions:"+ mapM_ (uncurry printE) errors+ exitFailure ++ where -- loop over first and subsequent expressions handleExprs :: Bool -- encoding -> Bool -- is this expression the first in the list of expressions?- -> CalCurveBP -> Maybe R.StdGen -- rng for the age sampling seeds- -> [(NamedCalExpr, Either CurrycarbonException CalPDF)]+ -> CalCurveBP+ -> [(Integer, Either CurrycarbonException NamedCalExpr, Either CurrycarbonException CalPDF)] -> IO () handleExprs _ _ _ _ [] = hPutStrLn stderr "Done." -- first expression- handleExprs _ascii True calCurve maybeRNG (firstDate:otherDates) =+ handleExprs _ascii True maybeRNG calCurve (firstDate:otherDates) = case firstDate of- (_, Left e) -> do- printE e- handleExprs _ascii True calCurve maybeRNG otherDates- (namedCalExpr, Right cPDF) -> do+ (i, Right ex, Right cPDF) -> do+ unless quiet $ hPutStrLn stderr $ "--- " ++ show i ++ " ---" let (sampleSeed, newRNG) = drawSeed maybeRNG- flexOut _ascii namedCalExpr cPDF sampleSeed writeCalPDF writeCalC14CalRangeSummary writeCalC14HDR writeRandomAgeSample- handleExprs _ascii False calCurve newRNG otherDates+ flexOut _ascii calCurve i ex cPDF sampleSeed writeCalPDF writeCalC14CalRangeSummary writeCalC14HDR writeRandomAgeSample+ handleExprs _ascii False newRNG calCurve otherDates+ (i, _, Left e) -> do+ printE i e+ handleExprs _ascii True maybeRNG calCurve otherDates+ _ -> error "can not happen" -- subsequent expression- handleExprs _ascii False calCurve maybeRNG (nextDate:otherDates) =+ handleExprs _ascii False maybeRNG calCurve (nextDate:otherDates) = case nextDate of- (_, Left e) -> do- printE e- handleExprs _ascii False calCurve maybeRNG otherDates- (namedCalExpr, Right cPDF) -> do+ (i, Right ex, Right cPDF) -> do+ unless quiet $ hPutStrLn stderr $ "--- " ++ show i ++ " ---" let (sampleSeed, newRNG) = drawSeed maybeRNG- flexOut _ascii namedCalExpr cPDF sampleSeed appendCalPDF appendCalC14CalRangeSummary appendCalC14HDR appendRandomAgeSample- handleExprs _ascii False calCurve newRNG otherDates+ flexOut _ascii calCurve i ex cPDF sampleSeed appendCalPDF appendCalC14CalRangeSummary appendCalC14HDR appendRandomAgeSample+ handleExprs _ascii False newRNG calCurve otherDates+ (i, _, Left e) -> do+ printE i e+ handleExprs _ascii False maybeRNG calCurve otherDates+ _ -> error "can not happen" - printE :: CurrycarbonException -> IO ()- printE e = hPutStrLn stderr $ renderCurrycarbonException e+ printE :: Integer -> CurrycarbonException -> IO ()+ printE i e = hPutStrLn stderr $ show i ++ ": " ++ renderCurrycarbonException e drawSeed :: Maybe R.StdGen -> (Maybe Int, Maybe R.StdGen) drawSeed maybeRNG = (\x -> (fromIntegral . fst <$> x, snd <$> x)) (R.genWord32 <$> maybeRNG)@@ -137,6 +182,8 @@ -- flexible expression handler flexOut :: Bool+ -> CalCurveBP+ -> Integer -> NamedCalExpr -> CalPDF -> Maybe Int@@ -145,19 +192,19 @@ -> (FilePath -> CalC14 -> IO ()) -> (FilePath -> RandomAgeSample -> IO ()) -> IO ()- flexOut _ascii namedCalExpr calPDF maybeSeed calPDFToFile calC14CalRangeSummaryToFile calC14HDRToFile randomAgeSampleToFile = do+ flexOut _ascii calCurve i namedCalExpr calPDF maybeSeed calPDFToFile calC14CalRangeSummaryToFile calC14HDRToFile randomAgeSampleToFile = do case refineCalDate calPDF of Left e -> do unless quiet $ do putStrLn ("CalEXPR: " ++ renderNamedCalExpr namedCalExpr)- printE e+ printE i e when (isJust basicFile) $ unless quiet $ hPutStrLn stderr "<!> Error: Can not create --basicFile" when (isJust hdrFile) $ unless quiet $ hPutStrLn stderr "<!> Error: Can not create --hdrFile" Right calC14 -> do unless quiet $ do- putStrLn (renderCalDatePretty _ascii (namedCalExpr, calPDF, calC14))+ putStrLn (renderCalDatePretty _ascii calCurve (not noInterpolate) (namedCalExpr, calPDF, calC14)) when (isJust basicFile) $ calC14CalRangeSummaryToFile (fromJust basicFile) calC14 when (isJust hdrFile) $@@ -169,7 +216,7 @@ case sampleAgesFromCalPDF conf calPDF of Left e -> do unless quiet $ do- printE e+ printE i e hPutStrLn stderr "<!> Error: Can not create --samplesFile" Right res -> randomAgeSampleToFile path res when (isJust densityFile) $@@ -177,9 +224,12 @@ -- | Helper function to replace empty input names with a sequence of numbers, -- to get each input date an unique identifier-replaceEmptyNames :: [NamedCalExpr] -> [NamedCalExpr]-replaceEmptyNames = zipWith (modifyNamedExpr . show) ([1..] :: [Integer])+replaceEmptyNames :: [Either CurrycarbonException NamedCalExpr] -> [Either CurrycarbonException NamedCalExpr]+replaceEmptyNames = zipWith modify [1..] where+ modify :: Integer -> Either CurrycarbonException NamedCalExpr -> Either CurrycarbonException NamedCalExpr+ modify _ (Left e) = Left e+ modify i (Right x) = Right $ modifyNamedExpr (show i) x modifyNamedExpr :: String -> NamedCalExpr -> NamedCalExpr modifyNamedExpr i nexpr = if _exprID nexpr == ""
src/Currycarbon/CalCurves.hs view
@@ -109,3 +109,37 @@ marine20 = readCalCurveUnsafe marine20String marine20String :: String marine20String = $(FE.makeRelativeToProject "data/marine20.14c" >>= FE.embedStringFile)++-- | Calibration curves usually do not have yearly resolution.+-- This function completes the curves with a most basic linear interpolation.+interpolateCalCurve :: CalCurveBP -> CalCurveBP+interpolateCalCurve (CalCurveBP cals uncals sigmas) =+ let obs = VU.zip3 cals uncals sigmas+ timeWindows = getTimeWindows obs+ obsFilled = VU.concatMap fillTimeWindows timeWindows+ in uncurry3 CalCurveBP $ VU.unzip3 obsFilled+ where+ getTimeWindows :: VU.Vector (YearBP,YearBP,YearRange) -> VU.Vector ((YearBP,YearBP,YearRange),(YearBP,YearBP,YearRange))+ getTimeWindows xs = VU.zipWith (,) (VU.init xs) (VU.tail xs)+ fillTimeWindows :: ((YearBP,YearBP,YearRange),(YearBP,YearBP,YearRange)) -> VU.Vector (YearBP,YearBP,YearRange)+ fillTimeWindows ((calbp1,bp1,sigma1),(calbp2,bp2,sigma2)) =+ if calbp1 == calbp2 || calbp1+1 == calbp2 || calbp1-1 == calbp2+ then VU.singleton (calbp1,bp1,sigma1)+ else+ let newCals = VU.fromList [calbp1,calbp1-1..calbp2+1] -- range definition like this to trigger counting down+ newBPs = VU.map (snd . getInBetweenPointsInt (calbp1,bp1) (calbp2,bp2)) newCals+ newSigmas = VU.map (snd . getInBetweenPointsInt (calbp1,sigma1) (calbp2,sigma2)) newCals+ in VU.zip3 newCals newBPs newSigmas+ getInBetweenPointsInt :: (Word, Word) -> (Word, Word) -> Word -> (Word, Word)+ getInBetweenPointsInt (x1,y1) (x2,y2) xPred =+ let (_,yPred) = getInBetweenPoints (fromIntegral x1,fromIntegral y1) (fromIntegral x2,fromIntegral y2) $ fromIntegral xPred+ in (xPred, round yPred)+ getInBetweenPoints :: (Double, Double) -> (Double, Double) -> Double -> (Double, Double)+ getInBetweenPoints (x1,y1) (x2,y2) xPred =+ let yDiff = y2 - y1+ xDiff = abs $ x1 - x2+ yDiffPerxDiff = yDiff/xDiff+ xPredRel = x1 - xPred+ in (xPred, y1 + xPredRel * yDiffPerxDiff)+ uncurry3 :: (a -> b -> c -> d) -> ((a, b, c) -> d)+ uncurry3 f ~(a,b,c) = f a b c
src/Currycarbon/Calibration/Calibration.hs view
@@ -14,6 +14,7 @@ , calibrateDates , refineCalDates , refineCalDate+ , validateCalPDF , CalibrateDatesConf (..) , defaultCalConf , AgeSamplingConf (..)@@ -56,21 +57,28 @@ -- calibration failed for some reason, or a 'CalPDF' calibrateDate method config calCurve uncalDate = head $ calibrateDates method config calCurve [uncalDate] +validateCalPDF :: CalPDF -> Either CurrycarbonException ()+validateCalPDF calPDF+ | isInvalidCalPDF calPDF = Left $ CurrycarbonInvalidCalPDFException "refinement"+ | otherwise = Right ()+ -- | Transforms the raw, calibrated probability density table to a meaningful representation of a -- calibrated radiocarbon date refineCalDates :: [CalPDF] -> [Either CurrycarbonException CalC14] refineCalDates = map refineCalDate refineCalDate :: CalPDF -> Either CurrycarbonException CalC14-refineCalDate calPDF@(CalPDF name cals dens)- -- don't calculate CalC14, if it's not meaningful- | isInvalidCalPDF calPDF =- Left $ CurrycarbonInvalidCalPDFException "refinement"+refineCalDate calPDF = do+ validateCalPDF calPDF+ pure (refineValidCalDate calPDF)++refineValidCalDate :: CalPDF -> CalC14+refineValidCalDate (CalPDF name cals dens) -- for simple uniform age ranges | VU.length (VU.uniq dens) == 1 = let start = VU.head cals stop = VU.last cals- in Right $ CalC14 {+ in CalC14 { _calC14id = name , _calC14RangeSummary = CalRangeSummary { _calRangeStartTwoSigma = start@@ -84,7 +92,7 @@ } -- for normal post-calibration probability distributions | otherwise =- Right $ CalC14 {+ CalC14 { _calC14id = name , _calC14RangeSummary = CalRangeSummary { _calRangeStartTwoSigma = _hdrstart $ head hdrs95@@ -156,4 +164,4 @@ where m = sequence . repeat . CMR.fromList $ weights isInvalidCalPDF :: CalPDF -> Bool-isInvalidCalPDF (CalPDF _ _ dens) = VU.sum dens == 0 || VU.any (>= 1.0) dens+isInvalidCalPDF (CalPDF _ _ dens) = VU.sum dens == 0 || VU.any (> 1.0) dens
src/Currycarbon/Calibration/Utils.hs view
@@ -2,6 +2,7 @@ module Currycarbon.Calibration.Utils where +import Currycarbon.CalCurves (interpolateCalCurve) import Currycarbon.Types import Data.Maybe (fromMaybe)@@ -51,8 +52,9 @@ -- the relevant segment of the calibration curve getRelevantCalCurveSegment :: UncalC14 -> CalCurveBP -> CalCurveBP getRelevantCalCurveSegment (UncalC14 _ mean std) (CalCurveBP cals uncals sigmas) =- let start = mean+6*std- stop = mean-6*std+ let std' = max std 10+ start = mean+6*std'+ stop = mean-6*std' startIndex = fromMaybe 0 $ VU.findIndex (<= start) uncals stopIndex = (VU.length uncals - 1) - fromMaybe 0 (VU.findIndex (>= stop) $ VU.reverse uncals) toIndex = stopIndex - startIndex@@ -86,38 +88,6 @@ bcad2BP :: YearBCAD -> YearBP bcad2BP y = 1950 - fromIntegral y--interpolateCalCurve :: CalCurveBP -> CalCurveBP-interpolateCalCurve (CalCurveBP cals uncals sigmas) =- let obs = VU.zip3 cals uncals sigmas- timeWindows = getTimeWindows obs- obsFilled = VU.concatMap fillTimeWindows timeWindows- in uncurry3 CalCurveBP $ VU.unzip3 obsFilled- where- getTimeWindows :: VU.Vector (YearBP,YearBP,YearRange) -> VU.Vector ((YearBP,YearBP,YearRange),(YearBP,YearBP,YearRange))- getTimeWindows xs = VU.zipWith (,) (VU.init xs) (VU.tail xs)- fillTimeWindows :: ((YearBP,YearBP,YearRange),(YearBP,YearBP,YearRange)) -> VU.Vector (YearBP,YearBP,YearRange)- fillTimeWindows ((calbp1,bp1,sigma1),(calbp2,bp2,sigma2)) =- if calbp1 == calbp2 || calbp1+1 == calbp2 || calbp1-1 == calbp2- then VU.singleton (calbp1,bp1,sigma1)- else- let newCals = VU.fromList [calbp1,calbp1-1..calbp2+1] -- range definition like this to trigger counting down- newBPs = VU.map (snd . getInBetweenPointsInt (calbp1,bp1) (calbp2,bp2)) newCals- newSigmas = VU.map (snd . getInBetweenPointsInt (calbp1,sigma1) (calbp2,sigma2)) newCals- in VU.zip3 newCals newBPs newSigmas- getInBetweenPointsInt :: (Word, Word) -> (Word, Word) -> Word -> (Word, Word)- getInBetweenPointsInt (x1,y1) (x2,y2) xPred =- let (_,yPred) = getInBetweenPoints (fromIntegral x1,fromIntegral y1) (fromIntegral x2,fromIntegral y2) $ fromIntegral xPred- in (xPred, round yPred)- getInBetweenPoints :: (Double, Double) -> (Double, Double) -> Double -> (Double, Double)- getInBetweenPoints (x1,y1) (x2,y2) xPred =- let yDiff = y2 - y1- xDiff = abs $ x1 - x2- yDiffPerxDiff = yDiff/xDiff- xPredRel = x1 - xPred- in (xPred, y1 + xPredRel * yDiffPerxDiff)- uncurry3 :: (a -> b -> c -> d) -> ((a, b, c) -> d)- uncurry3 f ~(a,b,c) = f a b c -- | Subset the calibration curve to the non-zero density range. The threshold is set to 0.00001. trimLowDensityEdgesCalPDF :: CalPDF -> CalPDF
src/Currycarbon/Parsers.hs view
@@ -2,7 +2,7 @@ module Currycarbon.Parsers where -import Currycarbon.CalCurves (intcal20)+import Currycarbon.CalCurves (interpolateCalCurve) import Currycarbon.Calibration.Utils import Currycarbon.ParserHelpers import Currycarbon.Types@@ -75,16 +75,25 @@ -- renderCalDatePretty :: Bool -- ^ Should the CLI plot be restricted to (boring) ASCII symbols?+ -> CalCurveBP+ -> Bool -> (NamedCalExpr, CalPDF, CalC14) -> String-renderCalDatePretty ascii (calExpr, calPDF, calC14) =- "CalEXPR: " ++ intercalate "\n" [+renderCalDatePretty ascii calCurve interpolate (calExpr, calPDF, calC14) =+ "CalEXPR: " ++ intercalate "" [ renderNamedCalExpr calExpr+ , "\n" , renderCalC14 calC14- , ""- , renderCLIPlotCalCurve ascii 8 50 calPDF calExpr- , renderCLIPlotCalPDF ascii 6 50 calPDF calC14- ]+ , "\n"+ ] +++ if interpolate+ then intercalate "" [+ "\n"+ , renderCLIPlotCalCurve ascii 8 50 calCurve calPDF calExpr+ , "\n"+ , renderCLIPlotCalPDF ascii 6 50 calPDF calC14+ ]+ else [] -- write and read calibration expressions @@ -117,15 +126,11 @@ name <- parseArgument "id" parseAnyString start <- parseArgument "start" parseWord stop <- parseArgument "stop" parseWord- construct name start stop+ eitherToFail $ makeTimeWindowBP name start stop short = do start <- parseArgument "start" parseWord stop <- parseArgument "stop" parseWord- construct "" start stop- construct name start stop = do- if start >= stop- then return (TimeWindowBP name start stop)- else fail "the BP stop date can not be larger than the start date"+ eitherToFail $ makeTimeWindowBP "" start stop parseTimeWindowBCAD :: P.Parser TimeWindowBCAD parseTimeWindowBCAD = parseRecordType "rangeBCAD" $ P.try long P.<|> short@@ -134,15 +139,11 @@ name <- parseArgument "id" parseAnyString start <- parseArgument "start" parseInt stop <- parseArgument "stop" parseInt- construct name start stop+ eitherToFail $ makeTimeWindowBCAD name start stop short = do start <- parseArgument "start" parseInt stop <- parseArgument "stop" parseInt- construct "" start stop- construct name start stop = do- if start <= stop- then return (TimeWindowBCAD name start stop)- else fail "the BC/AD stop date can not be smaller than the start date"+ eitherToFail $ makeTimeWindowBCAD "" start stop -- https://gist.github.com/abhin4v/017a36477204a1d57745 addFun :: P.Parser CalExpr@@ -500,14 +501,16 @@ roundedDec = if rest >= 5 then dec + 1 else dec in roundedDec * 10 * signum x -renderCLIPlotCalCurve :: Bool -> Int -> Int -> CalPDF -> NamedCalExpr -> String+renderCLIPlotCalCurve :: Bool -> Int -> Int -> CalCurveBP -> CalPDF -> NamedCalExpr -> String renderCLIPlotCalCurve- ascii rows cols (CalPDF _ cals _)+ ascii rows cols+ calCurve+ (CalPDF _ cals _) (NamedCalExpr _ (UnCalDate (UncalC14 _ yearBP sigma))) = let startYear = VU.head cals stopYear = VU.last cals -- prepare calcurve- calcurvePrep = makeBCADCalCurve $ interpolateCalCurve intcal20+ calcurvePrep = makeBCADCalCurve $ interpolateCalCurve calCurve calCurveSegment = punchOutCalCurveBCAD startYear stopYear calcurvePrep calCurveUncals = VU.map fromIntegral $ _calCurveBCADUnCals calCurveSegment calCurveUncalStart = bcad2BP $ round $ VU.head calCurveUncals@@ -553,7 +556,7 @@ | otherwise = ' ' makeTick :: (Integral n) => n -> String makeTick n = padString 6 (show $ roundTo10 $ fromIntegral n) ++ " " ++ getSymbol ascii YAxisTick : " "-renderCLIPlotCalCurve _ _ _ _ _ = ""+renderCLIPlotCalCurve _ _ _ _ _ _ = "" renderCLIPlotCalPDF :: Bool -> Int -> Int -> CalPDF -> CalC14 -> String renderCLIPlotCalPDF ascii rows cols (CalPDF _ cals dens) c14 =
+ src/Currycarbon/TSV.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE OverloadedStrings #-}++module Currycarbon.TSV where++import Currycarbon.ParserHelpers+import Currycarbon.Types+import Currycarbon.Utils++import Control.Applicative (empty)+import Control.Exception (throwIO)+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy as BL+import Data.Char (ord)+import qualified Data.Csv as Csv+import qualified Data.HashMap.Strict as HM+import Data.Maybe (catMaybes)+import qualified Data.Vector as V+import qualified Text.Parsec as P+import qualified Text.Parsec.String as P++-- | Turn 'TSV' to 'NamedCalExpr's for further processing (see 'evalNamedCalExpr')+tsv2NamedCalExprs :: CombinationStrategy -> TSV -> [Either CurrycarbonException NamedCalExpr]+tsv2NamedCalExprs combStrat (TSV _ _ rows) = V.toList $ V.map (tsvRow2NamedCalExprs combStrat) rows++tsvRow2NamedCalExprs :: CombinationStrategy -> TSVRow -> Either CurrycarbonException NamedCalExpr+-- C14 age with n dates and a labcode+tsvRow2NamedCalExprs combStrat+ (TSVRow i (Just (ListColumn lcs)) (Just (ListColumn bps)) (Just (ListColumn errs)) _ _) |+ (length lcs == length bps) && (length bps == length errs) =+ Right $ NamedCalExpr i $ foldC14 combStrat $ zip3 lcs bps errs+-- C14 age with n dates and no labcode+tsvRow2NamedCalExprs combStrat+ (TSVRow i _ (Just (ListColumn bps)) (Just (ListColumn errs)) _ _) |+ length bps == length errs =+ Right $ NamedCalExpr i $ foldC14 combStrat $ zip3 (repeat "") bps errs+-- contextual age+tsvRow2NamedCalExprs _ (TSVRow i _ _ _ (Just start) (Just stop)) =+ NamedCalExpr i . WindowBCAD <$> makeTimeWindowBCAD "" start stop+-- error case if nothing fits+tsvRow2NamedCalExprs _ (TSVRow i _ _ _ _ _) =+ Left $ CurrycarbonTSV2CalExprException i++-- | A data type for the strategy to combine multiple C14 dates.+data CombinationStrategy =+ CombSum -- ^ Form a normalised sum of the 'CalPDF's.+ | CombProduct -- ^ Form a normalised product of the 'CalPDF's.++instance Show CombinationStrategy where+ show CombSum = "Sum"+ show CombProduct = "Product"++readCombinationStrategy :: String -> Either String CombinationStrategy+readCombinationStrategy s =+ case P.runParser parseCombinationStrategy () s s of+ Left err -> Left $ showParsecErrOneLine err+ Right x -> Right x++parseCombinationStrategy :: P.Parser CombinationStrategy+parseCombinationStrategy = do+ x <- P.many P.anyChar+ case x of+ "Sum" -> pure CombSum+ "Product" -> pure CombProduct+ _ -> fail "must be either Sum or Product"++foldC14 :: CombinationStrategy -> [(String, Word, Word)] -> CalExpr+foldC14 CombSum xs = foldl1 SumCal $ map (\(lc,bp,err) -> UnCalDate $ UncalC14 lc bp err) xs+foldC14 CombProduct xs = foldl1 ProductCal $ map (\(lc,bp,err) -> UnCalDate $ UncalC14 lc bp err) xs++-- | Read calibration expressions from a .tsv file. The file should have the following columns:+--+-- @+-- Date_ID Date_C14_Labnr Date_C14_Uncal_BP Date_C14_Uncal_BP_Err Date_BC_AD_Start Date_BC_AD_Stop+-- Sample1 -200 100+-- Sample2 TEST-1 1000 30+-- Sample3 TEST-2;TEST-3 3000;3200 30;50+-- @+--+-- Subsets like <Date_ID> + <Date_C14_Uncal_BP> + <Date_C14_Uncal_BP_Err> or+-- <Date_ID> + <Date_BC_AD_Start> + <Date_BC_AD_Stop> are also sufficient.+-- The structure is inspired by the Poseidon .janno file.+--+readTSV :: FilePath -> IO TSV+readTSV path = do+ bs <- BL.readFile path+ case Csv.decodeByNameWith decodingOptions bs of+ Left s -> throwIO $ CurrycarbonTSVParsingException s+ Right (header, rows) -> return (TSV path header rows)++decodingOptions :: Csv.DecodeOptions+decodingOptions = Csv.defaultDecodeOptions { Csv.decDelimiter = fromIntegral (ord '\t') }++-- | A data type for tab-separated (.tsv) files+data TSV = TSV {+ _tsvFile :: FilePath+ , _tsvHeader :: Csv.Header+ , _tsvRows :: V.Vector TSVRow+ }++-- | A data type to represent the relevant fields of one row in a .tsv file+data TSVRow = TSVRow {+ -- | Identifier of the expression+ _tsvRowID :: String+ -- | Lab codes of radiocarbon dates+ , _tsvRowDateC14Labnr :: Maybe (ListColumn String)+ -- | C14 ages in years BP+ , _tsvRowDateC14UncalBP :: Maybe (ListColumn Word)+ -- | C14 standard deviations (one sigma in years)+ , _tsvRowDateC14UncalBPErr :: Maybe (ListColumn Word)+ -- | Start of time window in years BC+ , _tsvRowDateBCADStart :: Maybe Int+ -- | End of time window in years BC+ , _tsvRowDateBCADStop :: Maybe Int+ -- for any other columns+ -- , _tsvRowAllColumns :: Csv.NamedRecord+ }+ deriving Show++instance Csv.FromNamedRecord TSVRow where+ parseNamedRecord m = do+ i <- filterLookupMulti m ["Date_ID", "Poseidon_ID"]+ labnr <- filterLookupOptional m "Date_C14_Labnr"+ uncalBP <- filterLookupOptional m "Date_C14_Uncal_BP"+ uncalBPErr <- filterLookupOptional m "Date_C14_Uncal_BP_Err"+ start <- filterLookupOptional m "Date_BC_AD_Start"+ stop <- filterLookupOptional m "Date_BC_AD_Stop"+ pure $ TSVRow {+ _tsvRowID = i+ , _tsvRowDateC14Labnr = labnr+ , _tsvRowDateC14UncalBP = uncalBP+ , _tsvRowDateC14UncalBPErr = uncalBPErr+ , _tsvRowDateBCADStart = start+ , _tsvRowDateBCADStop = stop+ -- for any other columns+ -- , _tsvRowAllColumns = m+ }++-- lookup column by name+filterLookup :: Csv.FromField a => Csv.NamedRecord -> B8.ByteString -> Csv.Parser a+filterLookup m name = maybe empty Csv.parseField $ cleanInput $ HM.lookup name m++-- lookup optional column by name+filterLookupOptional :: Csv.FromField a => Csv.NamedRecord -> B8.ByteString -> Csv.Parser (Maybe a)+filterLookupOptional m name = maybe (pure Nothing) (\bs -> Just <$> Csv.parseField bs) $+ cleanInput $ HM.lookup name m++-- lookup column by multiple different names and keep the first match+filterLookupMulti :: Csv.FromField a => Csv.NamedRecord -> [B8.ByteString] -> Csv.Parser a+filterLookupMulti m names =+ maybe empty Csv.parseField $ cleanInput $ lookupMulti names+ where+ lookupMulti :: [B8.ByteString] -> Maybe B8.ByteString+ lookupMulti ns =+ let vals = map (`HM.lookup` m) ns+ in case catMaybes vals of+ [] -> Nothing+ (x:_) -> Just x++cleanInput :: Maybe B8.ByteString -> Maybe B8.ByteString+cleanInput Nothing = Nothing+cleanInput (Just rawInputBS) = transNA rawInputBS+ where+ transNA ".." = Nothing+ transNA "" = Nothing+ transNA "n/a" = Nothing+ transNA x = Just x++newtype ListColumn a = ListColumn {getListColumn :: [a]}+ deriving (Eq, Ord, Show)+instance (Csv.FromField a) => Csv.FromField (ListColumn a) where+ parseField x = fmap ListColumn . mapM Csv.parseField $ B8.splitWith (==';') x
src/Currycarbon/Types.hs view
@@ -2,6 +2,8 @@ module Currycarbon.Types where +import Currycarbon.Utils+ import qualified Data.Vector as V import qualified Data.Vector.Unboxed as VU @@ -164,8 +166,22 @@ data TimeWindowBP = TimeWindowBP String YearBP YearBP deriving (Show, Eq) +makeTimeWindowBP :: String -> YearBP -> YearBP -> Either CurrycarbonException TimeWindowBP+makeTimeWindowBP n start stop+ | start < stop = Left $ CurrycarbonMakeCalExprException "the BP start age can not be younger than stop age"+ | otherwise = Right $ TimeWindowBP n start stop+ data TimeWindowBCAD = TimeWindowBCAD String YearBCAD YearBCAD deriving (Show, Eq)++makeTimeWindowBCAD :: String -> YearBCAD -> YearBCAD -> Either CurrycarbonException TimeWindowBCAD+makeTimeWindowBCAD n start stop+ | start > stop = Left $ CurrycarbonMakeCalExprException "the BC/AD start age can not be younger than the stop age"+ | otherwise = Right $ TimeWindowBCAD n start stop++eitherToFail :: MonadFail m => Either CurrycarbonException b -> m b+eitherToFail (Left e) = fail $ renderCurrycarbonException e+eitherToFail (Right x) = return x -- | A data type to represent a human readable summary of a calibrated radiocarbon date data CalC14 = CalC14 {
src/Currycarbon/Utils.hs view
@@ -16,6 +16,12 @@ | CurrycarbonInvalidCalPDFException String -- | An exception for any issues with the CLI | CurrycarbonCLIException String+ -- | An exception for issues with the .tsv file parsing+ | CurrycarbonTSVParsingException String+ -- | An exception for incomplete rows in .tsv files+ | CurrycarbonTSV2CalExprException String+ -- | An exception for issues when making CalEXPRs+ | CurrycarbonMakeCalExprException String deriving (Show) instance Exception CurrycarbonException@@ -30,4 +36,9 @@ ", either because all densities are 0 or one density is > 1" renderCurrycarbonException (CurrycarbonCLIException s) = "<!> Error: " ++ s-+renderCurrycarbonException (CurrycarbonTSVParsingException s) =+ "<!> Error: " ++ s+renderCurrycarbonException (CurrycarbonTSV2CalExprException i) =+ "<!> Error: Incomplete information in .tsv entry " ++ show i+renderCurrycarbonException (CurrycarbonMakeCalExprException s) =+ "<!> Error: Issue when making CalExpr: " ++ s
test/GoldenSpec.hs view
@@ -25,6 +25,7 @@ , "hdr_file" , "samples_file" , "cal_curve_seg_file"+ , "tsv_file_reading" ] runFileOutputTests file_output_tests