diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +# Change log + +0.0.0 release candidate (Oct 7, 2020) diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,23 @@ +[The MIT License (MIT)][] + +Copyright (c) 2019-2020 Marco Zocca + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal in +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies +of the Software, and to permit persons to whom the Software is furnished to do +so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. + +[The MIT License (MIT)]: https://opensource.org/licenses/MIT diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,93 @@ +# [heidi][] + +[![Build Status](https://travis-ci.com/ocramz/heidi.png?branch=master)](https://travis-ci.com/ocramz/heidi?branch=master) + + +[heidi]: https://github.com/ocramz/heidi + + +![alt text](https://github.com/ocramz/heidi/raw/master/img/heidi.jpg "Heidi") + +`heidi` : tidy data in Haskell + +This library aims to bridge the gap between Haskell's precise but inflexible type discipline and the dynamic world of dataframes. + +If this sounds interesting to you, read on! + + +## Introduction + +A "dataframe" is conceptually a table of data that can be manipulated with a computer program; it potentially contains numbers, text and anything else that can be rendered as a string of text. + +In scientific practice, a "tidy" dataframe is a specific way of arranging the data in which each row represents a distinct observation ("data point") and each column a "feature" (i.e. some observable aspect) of the data. + +Nowadays, data science is a very established practice and many software libraries offer excellent functionality for working with such dataframes. `R` has `tidyverse` , Python has `pandas`, and so on. + +What about Haskell? + +## TL;DR + +``` +{-# language DeriveGenerics, DeriveAnyClass #-} +module MyDataScienceTask where + +import Heidi + +data Sales = Row String Int deriving (Eq, Show, Generic, Heidi) +``` + +and off you go. + +## Rationale + + +Out of the box, Haskell offers record types, e.g. + +``` +data Row a = MkRow { column1 :: Int, column2 :: String } deriving (Eq, Show) +``` + +which is handy because in one declaration you get a constructor method `MkRow` and accessors `column1`, `column2`, so a simple "data table" could be constructed as a list of such records, simply enough. + +One thing that the language doesn't natively support is lookup by accessor name. For example `column1 :: Row -> Int` can only access a value of type `Row`, since the `column1` name is globally unique (for a discussion on modern techniques to deal with this, see the Advanced section below). + +In addition to lookup, many data tasks require relational operations across pairs of data tables; algorithmically, these require lookups both across rows and columns, and there's nothing in Haskell's implementation of records that supports this. + +There are a number of additional tasks that are routine in data analysis but not so + + +## Advanced + + +Haskell offers a number of advanced workarounds for manipulating types, such as generic traversals, lookups, etc. A brief list of keywords is given in the following, for those inclined to dive into the rabbit hole. + +### Row polymorphism + +Elm, Purescript etc. + +### OverloadedRecordFields + +[1] + +### Row types + +As you might know, the "row types" problem is well understood and has been explored in practice; discussing the various tradeoffs between approaches would be lengthy and quite technical (and your humble author is not too qualified to do full justice to the topic either). + +In Haskell , the Frames [2] library and related ecosystem stands out as a full-featured dataframe implementation that does not compromise on type safety. + +Heidi instead offers generic transformations from the source datatypes to uni-typed values (conceptually, each row is a `Map String T` where `data T = TInt Int | TChar Char` etc.), a domain in which it's convenient to perform lookups and similar operations. + +Exploring further : vinyl [3], heterogeneous lists, sums-of-products ... + + + + +## References + +[1] OverloadedRecordFields : https://downloads.haskell.org/ghc/latest/docs/html/users_guide/glasgow_exts.html#record-field-selector-polymorphism + +[2] Frames : https://hackage.haskell.org/package/Frames + +[3] vinyl : https://hackage.haskell.org/package/vinyl + +[4] generics-sop : https://hackage.haskell.org/package/generics-sop diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,7 @@ +-- This script is used to build and install your package. Typically you don't +-- need to change it. The Cabal documentation has more information about this +-- file: . +import qualified Distribution.Simple + +main :: IO () +main = Distribution.Simple.defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,167 @@ +{-# language DeriveAnyClass #-} +{-# language DeriveGeneric #-} +{-# language OverloadedStrings #-} +{-# options_ghc -Wno-unused-imports #-} +module Main where + +import Control.Applicative (Alternative) +import GHC.Generics (Generic) +import Data.Typeable +import Control.Monad.Catch + +-- import Data.Hashable (Hashable) +-- import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T + +-- import Core.Data.Frame +-- import Core.Data.Frame.Generic +-- import qualified Heidi.Data.Row.GenericTrie as GTR +-- import Data.Generics.Encode.Internal (HasGE, TC, VP) +import Heidi -- (Heidi, Frame, TC, VP, gToFrameGT, filterDecode, mkTyN, mkTyCon) +import Heidi.Data.Frame.Algorithms.GenericTrie (innerJoin) + +-- import Lens.Micro ((^.), (%~), to, has) + +import Prelude hiding (filter, lookup) + +-- | Item +data Item a = Itm String a deriving (Eq, Show, Generic, Heidi) + +-- | Purchase +data Purchase a = Pur { + date :: Int + , pers :: String + , item :: String + , qty :: a + } deriving (Eq, Show, Generic, Heidi) + +items :: [Item Double] +items = [i1, i2, i3] where + i1 = Itm "computer" 1000 + i2 = Itm "car" 5000 + i3 = Itm "legal" 400 + +purchases :: [Purchase Double] +purchases = [p1, p2, p3, p4, p5] where + p1 = Pur 7 "bob" "car" 1 + p2 = Pur 5 "alice" "car" 1 + p3 = Pur 4 "bob" "legal" 20 + p4 = Pur 3 "alice" "computer" 2 + p5 = Pur 1 "bob" "computer" 1 + + +gItems, gPurchases :: Frame (Row [TC] VP) +gItems = encode items +gPurchases = encode purchases + + + +-- FIXME now we use Traversal' rather than Decode + +-- noLegal :: (MonadThrow f, Alternative f) => +-- String +-- -> Frame (GTR.Row [TC] VP) +-- -> f (Frame (GTR.Row [TC] VP)) +-- noLegal k = filterDecode dec where +-- dec r = r ^. GTR.text (keyN k) == "legal" + +noLegal :: String -> Frame (Row [TC] VP) -> Frame (Row [TC] VP) +noLegal k = filter look + where + look = keep (text (keyN k)) (== "legal") + +keyN, keyTyC :: String -> [TC] +keyN k = [mkTyN k] + +keyTyC k = [mkTyCon k] + + +-- joinTables = innerJoin k1 k2 where +-- k1 = keyN "" +-- k2 = keyN "" + + + + +-- joinTables :: (Foldable t, Hashable v, Eq v) => +-- t (Row [TC] v) -> t (Row [TC] v) -> Frame (Row [TC] v) +-- joinTables = innerJoin k1 k2 where +-- k1 = [TC "Itm" "_0"] +-- k2 = itemKey + + + + + + + + + + + + + + + + + + + + + + + + + +{- +Averaged across persons, excluding legal fees, how much money had each person spent by time 6? + +item , price +---------- +computer , 1000 +car , 5000 +legal fees (1 hour) , 400 + +date , person , item-bought , units-bought +------------------------------------ +7 , bob , car , 1 +5 , alice , car , 1 +4 , bob , legal fees (1 hour) , 20 +3 , alice , computer , 2 +1 , bob , computer , 1 + +It would be extra cool if you provided both an in-memory and a streaming solution. + +Principles|operations it illustrates + +Predicate-based indexing|filtering. +Merging (called "joining" in SQL). +Within- and across-group operations. +Sorting. +Accumulation (what Data.List calls "scanning"). +Projection (both the "last row" and the "mean" operations). +Statistics (the "mean" operation). + +Solution and proposed algorithm (it's possible you don't want to read this) + +The answer is $4000. That's because by time 6, Bob had bought 1 computer ($1000) and 20 hours of legal work (excluded), while Alice had bought a car ($5000) and two computers ($2000). In total they had spent $8000, so the across-persons average is $4000. + +One way to compute that would be to: + + Delete any purchase of legal fees. + Merge price and purchase data. + Compute a new column, "money-spent" = units-bought price. + Group by person. + Within each group: Sort by date in increasing order. + Compute a new column, "accumulated-spending" = running total of money spent. + Keep the last row with a date no greater than 6; drop all others. + Across groups, compute the mean of accumulated spending. + +-} + + + + + +main :: IO () +main = pure () diff --git a/bench/Space.hs b/bench/Space.hs new file mode 100644 --- /dev/null +++ b/bench/Space.hs @@ -0,0 +1,16 @@ +module Main where + + +-- -- https://hackage.haskell.org/package/weigh-0.0.14/docs/Weigh.html +-- import Weigh (mainWith, func) + +-- import qualified Heidi.Data.Row.GenericTrie as GTR (Row, fromList) +-- import qualified Heidi.Data.Frame.Algorithms.GenericTrie as GTR (innerJoin, leftOuterJoin, groupBy) +-- import qualified Heidi.Data.Row.HashMap as HMR (Row, fromList) +-- import qualified Heidi.Data.Frame.Algorithms.HashMap as HMR (innerJoin, leftOuterJoin, groupBy) +-- import Heidi (Frame, fromList) + + + +main :: IO () +main = pure () diff --git a/bench/Time.hs b/bench/Time.hs new file mode 100644 --- /dev/null +++ b/bench/Time.hs @@ -0,0 +1,7 @@ +module Main where + +import Criterion.Main + +main :: IO () +main = defaultMain [bench "const" (whnf const ())] + diff --git a/heidi.cabal b/heidi.cabal new file mode 100644 --- /dev/null +++ b/heidi.cabal @@ -0,0 +1,139 @@ +name: heidi +version: 0.0.0 +synopsis: Tidy data in Haskell +description: Tidy data in Haskell, via generics. +homepage: https://github.com/ocramz/heidi#readme +bug-reports: https://github.com/ocramz/heidi/issues +author: Marco Zocca +maintainer: Marco Zocca +license: MIT +copyright: (c) 2019-2020, Marco Zocca +category: Data Science, Data Mining, Generics +build-type: Simple +cabal-version: 1.12 +tested-with: GHC == 8.0.2, GHC == 8.6.3, GHC == 8.6.4, GHC == 8.6.5 +license-file: LICENSE.md +extra-source-files: + CHANGELOG.md + LICENSE.md + README.md + stack.yaml + +source-repository head + type: git + location: https://github.com/ocramz/heidi + +library + exposed-modules: + Heidi + Heidi.Data.Frame.Algorithms.GenericTrie + + other-modules: + Heidi.Data.Row.GenericTrie + + Heidi.Data.Frame.Algorithms.GenericTrie.Generic + Data.Generics.Codec + Data.Generics.Encode.OneHot + Data.Generics.Encode.Internal + Data.Generics.Decode + Core.Data.Frame + Core.Data.Frame.List + Core.Data.Frame.PrettyPrint + Core.Data.Frame.Generic + Core.Data.Row.Internal + hs-source-dirs: + src + ghc-options: -Wall + build-depends: + base > 4.9 && < 4.13 + , boxes >= 0.1.4 + -- , bytestring >= 0.10.8.1 + , containers >= 0.5.7.1 + , exceptions >= 0.8.3 + , generics-sop > 0.3.0 + , generic-trie >= 0.3.1 + , hashable >= 1.2.6.1 + -- , logging-effect + , microlens >= 0.4.8 + , microlens-th >= 0.4.1 + -- , primitive + , scientific >= 0.3.5.1 + , text >= 1.2.2.2 + -- , time >= 1.6.0.1 + -- , transformers + , unordered-containers > 0.2.8 + , vector >= 0.12.0.1 + -- , vector-algorithms + default-language: Haskell2010 + default-extensions: OverloadedStrings + +-- unit tests +test-suite unit + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Unit.GenericTrie + hs-source-dirs: + test + ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N + build-depends: + heidi + , base + , tasty + -- , tasty-hunit + , tasty-hspec + -- , hspec-expectations + default-language: Haskell2010 + +test-suite doctest + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: DocTest.hs + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + heidi + , base + , doctest + +benchmark bench-space + type: exitcode-stdio-1.0 + main-is: Space.hs + other-modules: + hs-source-dirs: + bench + ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N + build-depends: + heidi + , base + , weigh + default-language: Haskell2010 + +benchmark bench-time + type: exitcode-stdio-1.0 + main-is: Time.hs + other-modules: + hs-source-dirs: + bench + ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N + build-depends: + heidi + , base + , criterion + default-language: Haskell2010 + + +executable app + main-is: Main.hs + hs-source-dirs: + app + ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N + build-depends: + heidi + , base + , exceptions + , hashable + , text + , unordered-containers + default-language: Haskell2010 diff --git a/src/Core/Data/Frame.hs b/src/Core/Data/Frame.hs new file mode 100644 --- /dev/null +++ b/src/Core/Data/Frame.hs @@ -0,0 +1,234 @@ +{-# language OverloadedStrings #-} +{-# language FlexibleInstances #-} +{-# language DeriveFunctor, DeriveFoldable, DeriveTraversable, GeneralizedNewtypeDeriving #-} +{-# language ConstraintKinds #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} +{-# OPTIONS_GHC -Wno-type-defaults #-} +-- {-# OPTIONS_HADDOCK show-extensions #-} +----------------------------------------------------------------------------- +-- | +-- Module : Core.Data.Frame +-- Description : A sparse dataframe +-- Copyright : (c) Marco Zocca (2018-2019) +-- License : BSD-style +-- Maintainer : ocramz fripost org +-- Stability : experimental +-- Portability : GHC +-- +-- A general-purpose, row-oriented data frame. +-- +-- As it is common in the sciences, the dataframe should be taken to contain +-- experimental datapoints as its rows, each being defined by a number of /features/. +-- +----------------------------------------------------------------------------- +module Core.Data.Frame ( + -- * Frame + Frame, + -- ** Construction + fromNEList, fromList, + -- ** Access + head, take, drop, zipWith, numRows, + -- ** Filtering + filter, + -- *** 'D.Decode'-based filtering + filterDecode, + -- ** + groupWith, + -- ** Scans (row-wise cumulative operations) + scanl, scanr, + + -- -- * Row + -- Row, + -- -- ** Construction + -- fromKVs, + -- -- *** (unsafe) + -- mkRow, + -- -- ** Update + -- insert, insertRowFun, insertRowFunM, + -- -- ** Access + -- toList, keys, elems, + -- -- *** Decoders + -- D.Decode, D.mkDecode, D.runDecode, + -- real, scientific, text, oneHot, + -- -- ** Lookup + -- HMR.lookup, lookupThrowM, lookupDefault, (!:), elemSatisfies, + -- -- ** Set operations + -- union, unionWith, + -- -- ** Traversals + -- traverseWithKey, + -- -- * One-Hot + -- OneHot, + -- -- * Key constraint + -- HMR.Key + -- ** Vector-related + toVector, fromVector, + -- *** Sorting + ) where + +import qualified Control.Monad as CM (filterM) +import Data.Maybe (fromMaybe) +-- import Control.Applicative (Alternative(..)) +-- import qualified Data.Foldable as F +-- import Data.Foldable (foldl, foldr, foldlM, foldrM) +import qualified Data.Vector as V +-- import qualified Data.Vector.Generic.Mutable as VGM +-- import qualified Data.Vector.Algorithms.Merge as V (sort, sortBy, Comparison) +-- import qualified Data.Text as T (pack) +-- import Data.Text (Text) +-- import qualified Data.Map as M +-- import qualified Data.HashMap.Strict as HM +import qualified Data.List.NonEmpty as NE + +-- import Control.Monad.Catch(Exception(..), MonadThrow(..)) +-- import Data.Scientific (Scientific, toRealFloat) +-- import Data.Typeable (Typeable) + +import qualified Data.Generics.Decode as D (Decode, runDecode) +-- import Data.Generics.Decode ((>>>)) +-- import qualified Data.GenericTrie as GT +-- import Data.Generics.Encode.Internal (VP, getIntM, getFloatM, getDoubleM, getScientificM, getStringM, getTextM, getOneHotM) +-- import Data.Generics.Encode.OneHot (OneHot) + + +import Prelude hiding (filter, zipWith, lookup, foldl, foldr, scanl, scanr, head, take, drop) + +-- $setup +-- >>> import qualified Heidi.Data.Row.HashMap as HMR +-- >>> let row0 = HMR.fromList [(0, 'a'), (3, 'b')] :: HMR.Row Int Char +-- >>> let row1 = HMR.fromList [(0, 'x'), (1, 'b'), (666, 'z')] :: HMR.Row Int Char +-- >>> let book1 = HMR.fromList [("item", "book"), ("id.0", "129"), ("qty", "1")] +-- >>> let book2 = HMR.fromList [("item", "book"), ("id.0", "129"), ("qty", "5")] +-- >>> let ball = HMR.fromList [("item", "ball"), ("id.0", "234"), ("qty", "1")] +-- >>> let bike = HMR.fromList [("item", "bike"), ("id.0", "410"), ("qty", "1")] +-- >>> let t0 = fromList [ book1, ball, bike, book2 ] :: Frame (HMR.Row String String) +-- >>> let r1 = HMR.fromList [("id.1", "129"), ("price", "100")] +-- >>> let r2 = HMR.fromList [("id.1", "234"), ("price", "50")] +-- >>> let r3 = HMR.fromList [("id.1", "3"), ("price", "150")] +-- >>> let r4 = HMR.fromList [("id.1", "99"), ("price", "30")] +-- >>> let t1 = fromList [ r1, r2, r3, r4 ] :: Frame (HMR.Row String String) + + + +-- [NOTE : table Alternative instance] +-- +-- https://github.com/Gabriel439/Haskell-Bears-Library/blob/master/src/Bears.hs +-- +-- 'Table' has Applicative and Alternative instances +-- -- * for Alternative, we need the possibility of an empty table (to implement `empty`). Currently this is impossible due to the 'NonEmpty' list implementation. + +-- [NOTE : column universe and table pretty printing] +-- +-- Currently this 'Table' implementation doesn't know anything of its row type, including the type of its keys and values. +-- To pretty-print our tables, we'd like instead to know the "universe of columns", i.e. all possible columns used in every row (or at least in the first N rows) + + +-- | A 'Frame' is a non-empty list of rows. +newtype Frame row = Frame { + -- nFrameRows :: Maybe Int -- ^ Nothing means unknown + tableRows :: NE.NonEmpty row } deriving (Show, Functor, Foldable, Traversable) + +-- | Take the first row of a 'Frame' +-- +-- >>> head (fromList [row0, row1]) == row0 +-- True +head :: Frame row -> row +head = NE.head . tableRows + +-- | Take the first @n@ rows of a Frame +take :: Int -> Frame r -> [r] +take n = NE.take n . tableRows + +-- | Drop the first @n@ rows of a Frame +drop :: Int -> Frame r -> [r] +drop n = NE.drop n . tableRows + +-- | Construct a table given a non-empty list of rows +-- +-- >>> (head <$> fromNEList [row0, row1]) == Just row0 +-- True +-- >>> fromNEList [] +-- Nothing +fromNEList :: [row] -> Maybe (Frame row) +fromNEList l = Frame <$> NE.nonEmpty l + +-- | Construct a table given a list of rows. Crashes if the input list is empty +fromList :: [row] -> Frame row +fromList = Frame . NE.fromList + +toList :: Frame a -> [a] +toList = NE.toList . tableRows + +-- | Zip two frames with a row combining function +zipWith :: (a -> b -> row) + -> Frame a -> Frame b -> Frame row +zipWith f tt1 tt2 = Frame $ NE.zipWith f (tableRows tt1) (tableRows tt2) + + + +-- | Filters a 'Frame' according to a predicate. Returns Nothing only if the resulting table is empty (i.e. if no rows satisfy the predicate). +-- +filter :: (row -> Bool) -> Frame row -> Maybe (Frame row) +filter ff = fromNEList . NE.filter ff . tableRows + +-- | This generalizes the list-based 'filter' function. +filterA :: Applicative f => + (row -> f Bool) -> Frame row -> f (Maybe (Frame row)) +filterA fm t = fromNEList <$> CM.filterM fm (toList t) + + + +-- | Filter a 'Frame' by decoding row values. +-- +-- This is an intermediate function that doesn't require fixing the row type within the 'Frame'. +-- +-- NB: a 'D.Decode' returning 'Bool' can be declared via its Functor, Applicative and Alternative instances. +filterDecode :: Applicative f => + D.Decode f row Bool -- ^ Row decoder + -> Frame row + -> f (Maybe (Frame row)) +filterDecode dec = filterA (D.runDecode dec) + + +-- filterInt2 k1 k2 = +-- filterDecode ((>=) <$> HMR.scientific k1 <*> HMR.scientific k2) + + + +-- | Left-associative scan +scanl :: (b -> a -> b) -> b -> Frame a -> Frame b +scanl f z tt = Frame $ NE.scanl f z (tableRows tt) + +-- | Right-associative scan +scanr :: (a -> b -> b) -> b -> Frame a -> Frame b +scanr f z tt = Frame $ NE.scanr f z (tableRows tt) + +-- | 'groupWith' takes row comparison function and a list and returns a list of lists such that the concatenation of the result is equal to the argument. Moreover, each sublist in the result contains only elements that satisfy the comparison. +groupWith :: (row -> row -> Bool) -> Frame row -> [Frame row] +groupWith f t = Frame <$> NE.groupBy f (tableRows t) + +-- | 'groupWithM' uses a comparison function that Maybe returns a Bool. This is useful when used in conjuction with lookup-based logic. +groupWithM :: (row -> row -> Maybe Bool) -> Frame row -> [Frame row] +groupWithM fm = groupWith f' where + f' r1 r2 = fromMaybe False (fm r1 r2) + +-- | /O(n)/ Count the number of rows in the table +-- +-- >>> numRows t0 +-- 4 +numRows :: Frame row -> Int +numRows = length + + + +-- | Produce a 'Vector' of rows +toVector :: Frame row -> V.Vector row +toVector = V.fromList . NE.toList . tableRows + +-- | Produce a Frame from a 'Vector' of rows +fromVector :: V.Vector row -> Maybe (Frame row) +fromVector = fromNEList . V.toList + + + + + diff --git a/src/Core/Data/Frame/Generic.hs b/src/Core/Data/Frame/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Core/Data/Frame/Generic.hs @@ -0,0 +1,122 @@ +{-# language DeriveGeneric #-} +{-# language LambdaCase #-} + +-- {-# OPTIONS_GHC -Wall #-} +{-# options_ghc -Wno-unused-imports #-} +----------------------------------------------------------------------------- +-- | +-- Module : Core.Data.Frame.Generic +-- Description : Populate dataframes with generically-encoded data +-- Copyright : (c) Marco Zocca (2019) +-- License : MIT +-- Maintainer : ocramz fripost org +-- Stability : experimental +-- Portability : GHC +-- +-- Generic encoding of algebraic datatypes, using 'generics-sop' +-- +----------------------------------------------------------------------------- +module Core.Data.Frame.Generic ( + -- * GenericTrie-based rows + gToRowGT, encode, + -- -- * Exceptions + -- DataException(..) + ) where + +import qualified Data.Foldable as F (toList) +import Data.Typeable (Typeable) +import Control.Exception (Exception(..)) +import GHC.Generics (Generic(..)) +-- exceptions +import Control.Monad.Catch (MonadThrow(..)) +-- microlens +import Lens.Micro (toListOf) + +import qualified Core.Data.Frame.List as FL (Frame, frameFromList) +import qualified Heidi.Data.Row.GenericTrie as GTR (Row, mkRow) +import Data.Generics.Encode.Internal (gflattenHM, gflattenGT, Heidi, TC(..), VP) + + +-- $setup +-- >>> :set -XDeriveGeneric +-- >>> import qualified GHC.Generics as G +-- >>> import qualified Data.Generics.Encode.Internal as GE +-- >>> data P1 = P1 Int Char deriving (Eq, Show, G.Generic) +-- >>> instance GE.Heidi P1 +-- >>> data P2 = P2 { p2i :: Int, p2c :: Char } deriving (Eq, Show, G.Generic) +-- >>> instance GE.Heidi P2 +-- >>> data Q = Q (Maybe Int) (Either Double Char) deriving (Eq, Show, G.Generic) +-- >>> instance GE.Heidi Q + + +-- | Populate a 'Frame' with the generic encoding of the row data +-- +-- For example, a list of records having two fields each will produce a dataframe with two columns, having the record field names as column labels. +-- +-- @ +-- data P1 = P1 Int Char deriving (Eq, Show, 'G.Generic') +-- instance 'Heidi' P1 +-- +-- data P2 = P2 { p2i :: Int, p2c :: Char } deriving (Eq, Show, Generic) +-- instance Heidi P2 +-- +-- data Q = Q (Maybe Int) (Either Double Char) deriving (Eq, Show, Generic) +-- instance Heidi Q +-- @ +-- +-- >>> encode [P1 42 'z'] +-- Frame {tableRows = [([TC "P1" "_0"],VPInt 42),([TC "P1" "_1"],VPChar 'z')] :| []} +-- +-- >>> encode [P2 42 'z'] +-- Frame {tableRows = [([TC "P2" "p2c"],VPChar 'z'),([TC "P2" "p2i"],VPInt 42)] :| []} +-- +-- Test using 'Maybe' and 'Either' record fields : +-- +-- >>> encode [Q (Just 42) (Left 1.2), Q Nothing (Right 'b')] +-- Frame {tableRows = [([TC "Q" "_0",TC "Maybe" "Just"],VPInt 42),([TC "Q" "_1",TC "Either" "Left"],VPDouble 1.2)] :| [[([TC "Q" "_1",TC "Either" "Right"],VPChar 'b')]]} +-- +-- NB: as the last example above demonstrates, 'Nothing' values are not inserted in the rows, which can be used to encode missing data features. +encode :: (Foldable t, Heidi a) => + t a + -> FL.Frame (GTR.Row [TC] VP) +encode ds = gToFrameWith gToRowGT ds + +-- | Populate a 'Row' with a generic encoding of the input value (generic-trie backend) +gToRowGT :: Heidi a => a -> GTR.Row [TC] VP +gToRowGT = GTR.mkRow . gflattenGT + +gToFrameWith :: Foldable t => (a -> row) -> t a -> FL.Frame row +gToFrameWith f = FL.frameFromList . map f . F.toList + +-- -- | Exceptions related to the input data +-- data DataException = +-- NoDataE -- ^ Dataset has 0 rows +-- deriving (Eq, Typeable) +-- instance Show DataException where +-- show = \case +-- NoDataE -> "The dataset has 0 rows" +-- instance Exception DataException + + + + + + +-- example data + +{- +λ> gToRowGT $ B (A 42 'z') "moo" +[ + ([TC "B" "b1" ,TC "A" "a1" ], 42) +,([TC "B" "b1" ,TC "A" "a2"], z) +,([TC "B" "b2"], moo) +] +-} + + + +data A = A { a1 :: Int, a2 :: Char } deriving (Eq, Show, Generic) +instance Heidi A + +data B = B { b1 :: A, b2 :: String } deriving (Eq, Show, Generic) +instance Heidi B diff --git a/src/Core/Data/Frame/List.hs b/src/Core/Data/Frame/List.hs new file mode 100644 --- /dev/null +++ b/src/Core/Data/Frame/List.hs @@ -0,0 +1,110 @@ +{-# language OverloadedStrings #-} +{-# language FlexibleInstances #-} +{-# language DeriveFunctor, DeriveFoldable, DeriveTraversable, GeneralizedNewtypeDeriving #-} +{-# language ConstraintKinds #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} +{-# OPTIONS_GHC -Wno-type-defaults #-} +----------------------------------------------------------------------------- +-- | +-- Module : Core.Data.Frame.List +-- Description : List-based dataframe +-- Copyright : (c) Marco Zocca (2018-2019) +-- License : BSD-style +-- Maintainer : ocramz fripost org +-- Stability : experimental +-- Portability : GHC +-- +-- A general-purpose, row-oriented data frame, encoded as a list of rows +-- +----------------------------------------------------------------------------- +module Core.Data.Frame.List ( + -- * Frame + Frame, + -- ** Construction + frameFromList, + -- ** Access + Core.Data.Frame.List.head, + Core.Data.Frame.List.take, + Core.Data.Frame.List.drop, Core.Data.Frame.List.zipWith, numRows, + -- ** Filtering + Core.Data.Frame.List.filter, + -- *** 'D.Decode'-based filtering helpers + filterA, + -- ** + groupWith, + -- ** Scans (row-wise cumulative operations) + Core.Data.Frame.List.scanl, Core.Data.Frame.List.scanr, + -- ** Vector-related + toVector, fromVector, + -- *** Sorting + ) where + +import qualified Control.Monad as CM (filterM) +import Data.List (groupBy) + +import qualified Data.Vector as V + + +-- | A 'Frame' is a list of rows. +newtype Frame row = Frame { + tableRows :: [row] } deriving (Show, Functor, Foldable, Traversable) + +head :: Frame row -> row +head = Prelude.head . tableRows + +-- | Retain n rows +take :: Int -> Frame row -> Frame row +take n = Frame . Prelude.take n . tableRows + +-- | Drop n rows +drop :: Int -> Frame row -> Frame row +drop n = Frame . Prelude.drop n . tableRows + +zipWith :: (a -> b -> c) -> Frame a -> Frame b -> Frame c +zipWith f x y = frameFromList $ Prelude.zipWith f (tableRows x) (tableRows y) + +frameFromList :: [row] -> Frame row +frameFromList = Frame + +toList :: Frame row -> [row] +toList = tableRows + +numRows :: Frame row -> Int +numRows = length . tableRows + +filter :: (row -> Bool) -> Frame row -> Frame row +filter p = Frame . Prelude.filter p . tableRows + + +-- | This generalizes the list-based 'filter' function. +filterA :: Applicative f => + (row -> f Bool) -> Frame row -> f (Frame row) +filterA fm t = frameFromList <$> CM.filterM fm (toList t) + + + + + + +-- | Left-associative scan +scanl :: (b -> a -> b) -> b -> Frame a -> Frame b +scanl f z tt = Frame $ Prelude.scanl f z (tableRows tt) + +-- | Right-associative scan +scanr :: (a -> b -> b) -> b -> Frame a -> Frame b +scanr f z tt = Frame $ Prelude.scanr f z (tableRows tt) + +-- | 'groupWith' takes row comparison function and a list and returns a list of lists such that the concatenation of the result is equal to the argument. Moreover, each sublist in the result contains only elements that satisfy the comparison. +groupWith :: (row -> row -> Bool) -> Frame row -> [Frame row] +groupWith f t = Frame <$> groupBy f (tableRows t) + + + + +-- | Produce a 'Vector' of rows +toVector :: Frame row -> V.Vector row +toVector = V.fromList . tableRows + +-- | Produce a Frame from a 'Vector' of rows +fromVector :: V.Vector row -> Frame row +fromVector = frameFromList . V.toList diff --git a/src/Core/Data/Frame/PrettyPrint.hs b/src/Core/Data/Frame/PrettyPrint.hs new file mode 100644 --- /dev/null +++ b/src/Core/Data/Frame/PrettyPrint.hs @@ -0,0 +1,175 @@ +{-# language DeriveFunctor #-} +{-# language DeriveFoldable #-} +{-# language DeriveGeneric #-} +{-# language DeriveTraversable #-} +{-# language LambdaCase #-} +{-# options_ghc -Wno-unused-imports #-} +module Core.Data.Frame.PrettyPrint where + +import GHC.Generics (Generic(..)) +import qualified Data.Foldable as F (foldl', foldlM) +-- import Data. +import Data.Function (on) +import Data.List (filter, sortBy, groupBy) + +-- boxes +import Text.PrettyPrint.Boxes (Box, Alignment, emptyBox, nullBox, vcat, hcat, vsep, hsep, text, para, punctuateH, render, printBox, (<>), (<+>), (//), (/+/), top, left, right) + +-- import qualified Data.Text as T +import qualified Data.Map as M +import qualified Data.GenericTrie as GT + +import qualified Core.Data.Frame as CDF +import qualified Core.Data.Frame.Generic as CDF (encode, gToRowGT) +import qualified Heidi.Data.Row.GenericTrie as GTR + +import Prelude hiding ((<>)) + +{- + +what's the best data structure for representing this kind of table display? + +a trie with strings as keys and lists as values ? + ++-------------+-----------------+ +| Person | House | ++-------+-----+-------+---------+ +| Name | Age | Color | Price | ++-------+-----+-------+---------+ +| David | 63 | Green | $170000 | +| Ava | 34 | Blue | $115000 | +| Sonic | 12 | Green | $150000 | ++-------+-----+-------+---------+ + +(table example from colonnade : https://hackage.haskell.org/package/colonnade-1.2.0.2/docs/src/Colonnade.html#cap ) + +-} + + +{- + +fold over a list of tries to update a PTree + +[Trie [k] v] -> PTree v + +foldl :: Foldable t => (b -> row -> b) -> b -> t row -> b + +foldWithKey :: GT.TrieKey k => (k -> a -> r -> r) -> r -> Row k a -> r + +-} + +arr0, arr1 :: [Box] +arr0 = [text "moo", text "123123123"] +arr1 = [text "asdfasdfasdfasdf", text "z"] + +-- justification is computed per-column by Box +box1 :: Alignment -> Box +box1 aln = hsep 2 top [c0, c1] + where + c0 = vsep 1 aln arr0 + c1 = vsep 1 aln arr1 + + +-- +-------------+-----------------+ +-- | Person | House | +-- +-------+-----+-------+---------+ +-- | Name | Age | Color | Price | + +box2 :: Box +box2 = l <+> r + where + l = text "Person" // (text "Name" <+> text "Age") + r = text "House" // (text "Color" <+> text "Price") + + + + + + + + + +data M k v = Ml v + | Mb (M.Map k (M k v)) deriving (Functor, Foldable) +instance (Show k, Show v) => Show (M k v) where + show = \case + Ml x -> show x + Mb m -> show $ M.toList m + +empty :: M k v +empty = Mb M.empty + +-- | Copy the contents of a list-indexed Row into a tree-shaped structure (for pretty-printing) +-- +-- >>> unfold [("aa", 41), ("ab", 42)] +-- [('a',[('a',[('a',41)]),('b',42)])] -- FIXME why 3 levels and not 2 ?!? +unfold :: (Foldable t, Ord k) => + t ([k], v) -- each GTR.Row is isomorphic to this parameter + -> M k v +unfold kvs = foldl insf empty kvs + where + insf (Mb acc) (ks, v) = insert acc ks v + insf _ _ = undefined -- FIXME + +-- | Copy a single list-indexed value into a tree +-- +-- >>> insert M.empty "abc" 42 +-- [('a',[('b',[('c',42)])])] +insert :: Ord k => M.Map k (M k v) -> [k] -> v -> M k v +insert = go + where + go _ [] v = Ml v + go m (k:ks) v = Mb $ M.insert k (go m ks v) m + + +-- data Tree a = Node { +-- rootLabel :: a, -- ^ label value +-- subForest :: [Tree a] -- ^ zero or more child trees + +-- unfoldTree :: (b -> (a, [b])) -> b -> Tree a +-- unfoldTree f b = let (a, bs) = f b in Node a (unfoldForest f bs) +-- +-- unfoldForest :: (b -> (a, [b])) -> [b] -> Forest a +-- unfoldForest f = map (unfoldTree f) + + +-- boxM (Ml s) = text s +-- boxM (Mb mm) = foldl ins nullBox mm +-- where +-- ins acc x = acc <+> boxM x + + + +-- >>> groupSort ["aa", "ab", "cab", "xa", "cx"] +-- [["aa","ab"],["cab","cx"],["xa"]] +groupSort :: Ord a => [[a]] -> [[[a]]] +groupSort = groupSortBy head + +groupSortBy :: Ord a1 => (a2 -> a1) -> [a2] -> [[a2]] +groupSortBy f = groupBy ((==) `on` f) . sortBy (compare `on` f) + +-- render a column of a frame +columnBox :: (Foldable t, Show a, GT.TrieKey k) => + t (GTR.Row k a) -- ^ dataframe + -> k -- ^ column key + -> Box +columnBox rows k = foldl ins nullBox rows + where + ins acc row = acc // maybe (emptyBox 1 0) (text . show) (GTR.lookup k row) + + + + + + +-- | union of the set of keys across all rows +allKeys :: (GT.TrieKey k, Foldable f) => f (GTR.Row k v) -> [k] +allKeys = GTR.keys . GTR.keysOnly + + + + +-- data Sized a = Sized !Int a + +-- annotateWithDepth :: (GT.TrieKey k) => GTR.Row [k] a -> GTR.Row [k] (Sized a) +-- annotateWithDepth = GTR.mapWithKey (\k v -> Sized (length k) v) diff --git a/src/Core/Data/Row/Internal.hs b/src/Core/Data/Row/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Core/Data/Row/Internal.hs @@ -0,0 +1,28 @@ +{-# language DeriveFunctor, GeneralizedNewtypeDeriving, DeriveTraversable, DeriveDataTypeable #-} +-- {-# language ConstraintKinds #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} +{-# OPTIONS_GHC -Wno-type-defaults #-} +----------------------------------------------------------------------------- +-- | +-- Module : Core.Data.Row.Internal +-- Description : Core.Data.Row internal bits and pieces +-- Copyright : (c) Marco Zocca (2018-2019) +-- License : BSD-style +-- Maintainer : ocramz fripost org +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- +module Core.Data.Row.Internal where + +import Data.Typeable (Typeable) +-- import Data.Hashable (Hashable(..)) +import Control.Monad.Catch(Exception(..)) + + +-- | Key exceptions +data KeyError k = + MissingKeyError k + | AlreadyPresentKeyError k + deriving (Show, Eq, Typeable) +instance (Show k, Typeable k) => Exception (KeyError k) diff --git a/src/Data/Generics/Codec.hs b/src/Data/Generics/Codec.hs new file mode 100644 --- /dev/null +++ b/src/Data/Generics/Codec.hs @@ -0,0 +1,133 @@ +{-# options_ghc -Wno-unused-imports #-} +{-# options_ghc -Wno-unused-top-binds #-} +{-# options_ghc -Wno-type-defaults #-} +module Data.Generics.Codec ( + realM, scientificM, textM, stringM, oneHotM, int, int8, int16, int32, int64, word, word8, word16, word32, word64, + -- * TC (Type and Constructor annotation) + TC(..), tcTyN, tcTyCon, mkTyN, mkTyCon + -- * Exceptions + , TypeError(..)) where + +import Control.Applicative (Alternative(..)) + +import Control.Monad.Catch (MonadThrow(..)) + +import Data.Int (Int8, Int16, Int32, Int64) +import Data.Word (Word, Word8, Word16, Word32, Word64) + +-- scientific +import Data.Scientific (Scientific, toRealFloat, fromFloatDigits) +-- text +import qualified Data.Text as T + + +import Data.Generics.Encode.Internal (VP(..), getIntM, getInt8M, getInt16M, getInt32M, getInt64M, getWordM, getWord8M, getWord16M, getWord32M, getWord64M, getBoolM, getFloatM, getDoubleM, getScientificM, getCharM, getStringM, getTextM, getOneHotM, TypeError(..), TC(..), tcTyN, tcTyCon, mkTyN, mkTyCon) +import Data.Generics.Decode (Decode, mkDecode) +import Data.Generics.Encode.OneHot (OneHot) + + + + + + +-- decInt :: D.Decode Maybe VP Int +-- decInt = D.mkDecode getInt +-- -- decInteger = D.mkDecode getInteger +-- decDouble :: D.Decode Maybe VP Double +-- decDouble = D.mkDecode getDouble +-- -- decChar = D.mkDecode getChar +-- -- decText = D.mkDecode getText + +-- | Decode any real numerical value (integer, double, float or 'Scientific') into a Double +realM :: (Alternative m, MonadThrow m) => Decode m VP Double +realM = + (fromIntegral <$> int) <|> + double <|> + (realToFrac <$> float) <|> + (toRealFloat <$> scientific) + +-- | Decode any real numerical value (integer, double, float or 'Scientific') into a Scientific +scientificM :: (Alternative m, MonadThrow m) => Decode m VP Scientific +scientificM = + scientific <|> + (fromFloatDigits . fromIntegral <$> int) <|> + (fromFloatDigits <$> double) <|> + (fromFloatDigits <$> float) + +-- | Decode a string ('String' or 'Text') into a Text +textM :: (Alternative m, MonadThrow m) => Decode m VP T.Text +textM = + (T.pack <$> string) <|> + text + +-- | Decode a string ('String' or 'Text') into a String +stringM :: (Alternative m, MonadThrow m) => Decode m VP String +stringM = + string <|> + (T.unpack <$> text) + + + + + +-- | Decode a one-hot value +oneHotM :: MonadThrow m => Decode m VP (OneHot Int) +oneHotM = mkDecode getOneHotM + + + + + +int :: MonadThrow m => Decode m VP Int +int = mkDecode getIntM + +int8 :: MonadThrow m => Decode m VP Int8 +int8 = mkDecode getInt8M + +int16 :: MonadThrow m => Decode m VP Int16 +int16 = mkDecode getInt16M + +int32 :: MonadThrow m => Decode m VP Int32 +int32 = mkDecode getInt32M + +int64 :: MonadThrow m => Decode m VP Int64 +int64 = mkDecode getInt64M + +word :: MonadThrow m => Decode m VP Word +word = mkDecode getWordM + +word8 :: MonadThrow m => Decode m VP Word8 +word8 = mkDecode getWord8M + +word16 :: MonadThrow m => Decode m VP Word16 +word16 = mkDecode getWord16M + +word32 :: MonadThrow m => Decode m VP Word32 +word32 = mkDecode getWord32M + +word64 :: MonadThrow m => Decode m VP Word64 +word64 = mkDecode getWord64M + +bool :: MonadThrow m => Decode m VP Bool +bool = mkDecode getBoolM + +float :: MonadThrow m => Decode m VP Float +float = mkDecode getFloatM + +double :: MonadThrow m => Decode m VP Double +double = mkDecode getDoubleM + +scientific :: MonadThrow m => Decode m VP Scientific +scientific = mkDecode getScientificM + +char :: MonadThrow m => Decode m VP Char +char = mkDecode getCharM + +string :: MonadThrow m => Decode m VP String +string = mkDecode getStringM + +text :: MonadThrow m => Decode m VP T.Text +text = mkDecode getTextM + + + diff --git a/src/Data/Generics/Decode.hs b/src/Data/Generics/Decode.hs new file mode 100644 --- /dev/null +++ b/src/Data/Generics/Decode.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE + DeriveFunctor, + GeneralizedNewtypeDeriving +#-} +{-# OPTIONS_GHC -Wall #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Generics.Decode +-- Description : Composable decoding of terms +-- Copyright : (c) Marco Zocca (2019) +-- License : MIT +-- Maintainer : ocramz fripost org +-- Stability : experimental +-- Portability : GHC +-- +-- Composable decoding of terms +----------------------------------------------------------------------------- +module Data.Generics.Decode (Decode, mkDecode, runDecode, (>>>)) where + +import Control.Applicative (Alternative(..)) +import Control.Category (Category(..)) +-- import Data.Foldable (Foldable(..), asum) +import Control.Monad ((>=>)) +-- import Data.Maybe (fromMaybe) +-- import Control.Monad.Log (MonadLog(..), Handler, WithSeverity(..), Severity, logDebug, logInfo, logWarning, logError, runLoggingT, PureLoggingT(..), runPureLoggingT) +-- import Control.Monad.Trans.State.Strict (StateT(..), runStateT) + +import Prelude hiding ((.)) + + +-- | We can decouple lookup and value conversion and have distinct error behaviour. +-- Multiple value decoding functions can be combined via the Applicative and Alternative instance. +-- +-- Note : 'Decode' is called Kleisli in base.Control.Arrow; among other things it has a Profunctor instance. + +newtype Decode m i o = Decode { runDecode_ :: i -> m o } deriving (Functor) + +-- | Run a decoding function +runDecode :: Decode m i o -> i -> m o +runDecode = runDecode_ + +-- | Construct a 'Decode' from a monadic arrow. +mkDecode :: (i -> m o) -> Decode m i o +mkDecode = Decode + +instance Applicative m => Applicative (Decode m i) where + pure x = Decode $ \ _ -> pure x + Decode af <*> Decode aa = Decode $ \ v -> af v <*> aa v + +instance Alternative m => Alternative (Decode m i) where + empty = Decode $ const empty + Decode p <|> Decode q = Decode $ \v -> p v <|> q v + +-- | This instance is copied from @Kleisli@ (defined in Control.Arrow) +instance Monad m => Category (Decode m) where + id = Decode return + (Decode f) . (Decode g) = Decode (g >=> f) + +-- | Left-to-right composition +-- +-- @(>>>) :: Monad m => Decode m a b -> Decode m b c -> Decode m a c@ +(>>>) :: Category cat => cat a b -> cat b c -> cat a c +(>>>) = flip (.) +{-# inline (>>>) #-} + + + + +-- data Spork m a b = Spork (a -> m b) (b -> m a) deriving (Functor) + + + + +-- | [NOTE Key lookup + value conversion, behaviour of row functions ] +-- +-- If the key is not found /or/ the conversion fails, use a default; the first exception thrown by the lookup-and-convert function will be rethrown. +-- We'd like instead to try many different decoders, and only throw if /all/ have failed +-- +-- How should Alternative behave for lookup-and-convert that both might fail? +-- +-- value decoding : try all decoders, return first successful (== Alternative) +-- decoding missing values : should be configurable +-- -- * use default value +-- -- * skip rows that have any missing value +-- +-- row function: decoding behaviour should be defined for all function arguments +-- +-- example : +-- +-- λ> bool (2 :: Int) (VBool False) <|> bool (2 :: Int) (VBool True) +-- False +-- λ> bool (2 :: Int) (VDouble 32) <|> bool (2 :: Int) (VBool True) +-- *** Exception: ValueTypeError 2 VTypeBool (VDouble 32.0) +-- +-- λ> Nothing <|> pure 32.0 +-- Just 32.0 +-- λ> (bool (2 :: Int) (VDouble 32) <|> bool (2 :: Int) (VBool True)) :: Maybe Bool +-- Just True +-- +-- ^ throwM in IO : strict (the first failing decoder throws an exception), Maybe : lazy (keeps trying decoders and returns the first successful one) diff --git a/src/Data/Generics/Encode/Internal.hs b/src/Data/Generics/Encode/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Generics/Encode/Internal.hs @@ -0,0 +1,454 @@ +{-# language + DeriveGeneric + , DeriveDataTypeable + , FlexibleContexts + , GADTs + , OverloadedStrings + , DefaultSignatures + , ScopedTypeVariables + , FlexibleInstances + , LambdaCase + , TemplateHaskell +#-} +{-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_GHC -Wno-type-defaults #-} +-- {-# OPTIONS_GHC -Wno-unused-top-binds #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Generics.Encode.Internal +-- Description : Generic encoding of algebraic datatypes +-- Copyright : (c) Marco Zocca (2019) +-- License : MIT +-- Maintainer : ocramz fripost org +-- Stability : experimental +-- Portability : GHC +-- +-- Generic encoding of algebraic datatypes, using @generics-sop@ +-- +-- Examples, inspiration and code borrowed from : +-- +-- * @basic-sop@ - generic show function : https://hackage.haskell.org/package/basic-sop-0.2.0.2/docs/src/Generics-SOP-Show.html#gshow +-- +-- * @tree-diff@ - single-typed ADT reconstruction : http://hackage.haskell.org/package/tree-diff-0.0.2/docs/src/Data.TreeDiff.Class.html#sopToExpr +----------------------------------------------------------------------------- +module Data.Generics.Encode.Internal (gflattenHM, gflattenGT, + -- * VP (Primitive types) + VP(..), + -- ** Lenses + vpInt, vpDouble, vpFloat, vpString, vpText, vpBool, vpScientific, vpChar, vpOneHot, + -- ** 'MonadThrow' getters + getIntM, getInt8M, getInt16M, getInt32M, getInt64M, getWordM, getWord8M, getWord16M, getWord32M, getWord64M, getBoolM, getFloatM, getDoubleM, getScientificM, getCharM, getStringM, getTextM, getOneHotM, TypeError(..), + -- * TC (Type and Constructor annotation) + TC(..), tcTyN, tcTyCon, mkTyN, mkTyCon, + -- * Heidi (generic ADT encoding) + Heidi) where + +import qualified GHC.Generics as G +import Data.Int (Int8, Int16, Int32, Int64) +import Data.Word (Word, Word8, Word16, Word32, Word64) +import Data.Typeable (Typeable) + +-- exceptions +import Control.Monad.Catch(Exception(..), MonadThrow(..)) +-- generics-sop +import Generics.SOP (All, DatatypeName, datatypeName, DatatypeInfo, FieldInfo(..), FieldName, ConstructorInfo(..), constructorInfo, All, All2, hcliftA2, hcmap, Proxy(..), SOP(..), NP(..), I(..), K(..), mapIK, hcollapse) +-- import Generics.SOP.NP (cpure_NP) +-- import Generics.SOP.Constraint (SListIN) +import Generics.SOP.GGP (GCode, GDatatypeInfo, GFrom, gdatatypeInfo, gfrom) +-- generic-trie +import qualified Data.GenericTrie as GT +-- hashable +import Data.Hashable (Hashable(..)) +-- microlens-th +import Lens.Micro.TH (makeLenses) +-- scientific +import Data.Scientific (Scientific) +-- text +import Data.Text (Text, unpack) + +-- import Data.Time (Day, LocalTime, TimeOfDay) +-- import qualified Data.Vector as V +-- import qualified Data.Map as M +import qualified Data.HashMap.Strict as HM +-- import qualified Data.GenericTrie as GT + +import Data.Generics.Encode.OneHot (OneHot, mkOH) +-- import Data.List (unfoldr) +-- import qualified Data.Foldable as F +-- import qualified Data.Sequence as S (Seq(..), empty) +-- import Data.Sequence ((<|), (|>)) + +import Prelude hiding (getChar) + +-- $setup +-- >>> :set -XDeriveGeneric +-- >>> import qualified GHC.Generics as G + +-- | Primitive types +-- +-- NB : this is just a convenience for unityping the dataframe contents, but it should not be exposed to the library users +data VP = + VPInt { _vpInt :: Int } -- ^ 'Int' + | VPInt8 Int8 -- ^ 'Int8' + | VPInt16 Int16 -- ^ 'Int16' + | VPInt32 Int32 -- ^ 'Int32' + | VPInt64 Int64 -- ^ 'Int64' + | VPWord Word -- ^ 'Word' + | VPWord8 Word8 -- ^ 'Word8' + | VPWord16 Word16 -- ^ 'Word16' + | VPWord32 Word32 -- ^ 'Word32' + | VPWord64 Word64 -- ^ 'Word64' + | VPBool { _vpBool :: Bool } -- ^ 'Bool' + | VPFloat { _vpFloat :: Float } -- ^ 'Float' + | VPDouble { _vpDouble :: Double } -- ^ 'Double' + | VPScientific { _vpScientific :: Scientific } -- ^ 'Scientific' + | VPChar { _vpChar :: Char } -- ^ 'Char' + | VPString { _vpString :: String } -- ^ 'String' + | VPText { _vpText :: Text } -- ^ 'Text' + | VPOH { _vpOneHot :: OneHot Int } -- ^ 1-hot encoding of an enum value + deriving (Eq, Ord, G.Generic) +instance Hashable VP +makeLenses ''VP + +instance Show VP where + show = \case + VPInt x -> show x + VPInt8 x -> show x + VPInt16 x -> show x + VPInt32 x -> show x + VPInt64 x -> show x + VPWord x -> show x + VPWord8 x -> show x + VPWord16 x -> show x + VPWord32 x -> show x + VPWord64 x -> show x + VPBool b -> show b + VPFloat f -> show f + VPDouble d -> show d + VPScientific s -> show s + VPChar d -> pure d + VPString s -> s + VPText t -> unpack t + VPOH oh -> show oh + + +-- | Flatten a value into a 1-layer hashmap, via the value's generic encoding +gflattenHM :: Heidi a => a -> HM.HashMap [TC] VP +gflattenHM = flattenHM . toVal + +-- | Flatten a value into a 'GT.Trie', via the value's generic encoding +gflattenGT :: Heidi a => a -> GT.Trie [TC] VP +gflattenGT = flattenGT . toVal + + +-- -- | Commands for manipulating lists of TC's +-- data TCAlg = TCAnyTyCon String -- ^ Matches any type constructor name +-- | TCFirstTyCon String -- ^ " first type constructor name +-- | TCAnyTyN String -- ^ " any type name +-- | TCFirstTyN String -- ^ first type name + + +-- | A (type, constructor) name pair +data TC = TC String String deriving (Eq, Show, Ord, G.Generic) +instance Hashable TC +instance GT.TrieKey TC + +-- | Type name +tcTyN :: TC -> String +tcTyN (TC n _) = n +-- | Type constructor +tcTyCon :: TC -> String +tcTyCon (TC _ c) = c + +-- | Create a fake TC with the given string as type constructor +mkTyCon :: String -> TC +mkTyCon x = TC "" x + +-- | Create a fake TC with the given string as type name +mkTyN :: String -> TC +mkTyN x = TC x "" + +-- | Fold a 'Val' into a 1-layer hashmap indexed by the input value's (type, constructor) metadata +flattenHM :: Val -> HM.HashMap [TC] VP +flattenHM = flatten HM.empty HM.insert + +-- | Fold a 'Val' into a 1-layer 'GT.Trie' indexed by the input value's (type, constructor) metadata +flattenGT :: Val -> GT.Trie [TC] VP +flattenGT = flatten GT.empty GT.insert + +flatten :: t -> ([TC] -> VP -> t -> t) -> Val -> t +flatten z insf = go ([], z) where + insRev ks = insf (reverse ks) + go (ks, hmacc) = \case + VRec ty hm -> HM.foldlWithKey' (\hm' k t -> go (TC ty k : ks, hm') t) hmacc hm + VEnum ty cn oh -> insRev (TC ty cn : ks) (VPOH oh) hmacc + VPrim vp -> insRev ks vp hmacc + + + +-- flatten' z insf = go ([], z) where +-- insRev ks = insf (reverse ks) +-- go (ks, hmacc) = \case +-- VRec ty hm -> HM.foldlWithKey' (\hm' k t -> go (TC ty k : ks, hm') t) hmacc hm +-- -- VEnum ty cn oh -> insRev (TC ty cn : ks) (VPOH oh) hmacc +-- -- VPrim vp -> insRev ks vp hmacc + + + + + + + + +-- | Internal representation of encoded ADTs values +-- +-- The first String parameter contains the type name at the given level, the second contains the type constructor name +data Val = + VRec String (HM.HashMap String Val) -- ^ recursion + | VEnum String String (OneHot Int) -- ^ 1-hot encoding of an enum + | VPrim VP -- ^ primitive types + deriving (Eq, Show) + + +-- | Typeclass for types which have a generic encoding. +-- +-- NOTE: if your type has a 'G.Generic' instance you just need to declare an empty instance of 'Heidi' for it. +-- +-- example: +-- +-- @ +-- data A = A Int Char deriving ('G.Generic') +-- instance 'Heidi' A +-- @ +class Heidi a where + toVal :: a -> Val + default toVal :: + (G.Generic a, All2 Heidi (GCode a), GFrom a, GDatatypeInfo a) => a -> Val + toVal x = sopHeidi (gdatatypeInfo (Proxy :: Proxy a)) (gfrom x) + + +sopHeidi :: All2 Heidi xss => DatatypeInfo xss -> SOP I xss -> Val +sopHeidi di sop@(SOP xss) = hcollapse $ hcliftA2 + (Proxy :: Proxy (All Heidi)) + (\ci xs -> K (mkVal ci xs tyName oneHot)) + (constructorInfo di) + xss + where + tyName = datatypeName di + oneHot = mkOH di sop + +mkVal :: All Heidi xs => + ConstructorInfo xs -> NP I xs -> DatatypeName -> OneHot Int -> Val +mkVal cinfo xs tyn oh = case cinfo of + Infix cn _ _ -> VRec cn $ mkAnonProd xs + Constructor cn + | null cns -> VEnum tyn cn oh + | otherwise -> VRec cn $ mkAnonProd xs + Record _ fi -> VRec tyn $ mkProd fi xs + where + cns :: [Val] + cns = npHeidis xs + +mkProd :: All Heidi xs => NP FieldInfo xs -> NP I xs -> HM.HashMap String Val +mkProd fi xs = HM.fromList $ hcollapse $ hcliftA2 (Proxy :: Proxy Heidi) mk fi xs where + mk :: Heidi v => FieldInfo v -> I v -> K (FieldName, Val) v + mk (FieldInfo n) (I x) = K (n, toVal x) + +mkAnonProd :: All Heidi xs => NP I xs -> HM.HashMap String Val +mkAnonProd xs = HM.fromList $ zip labels cns where + cns = npHeidis xs + +npHeidis :: All Heidi xs => NP I xs -> [Val] +npHeidis xs = hcollapse $ hcmap (Proxy :: Proxy Heidi) (mapIK toVal) xs + +-- | >>> take 3 labels +-- ["_0","_1","_2"] +labels :: [String] +labels = map (('_' :) . show) [0 ..] + + +-- instance Heidi () where toVal = VPrim VUnit +instance Heidi Bool where toVal = VPrim . VPBool +instance Heidi Int where toVal = VPrim . VPInt +instance Heidi Int8 where toVal = VPrim . VPInt8 +instance Heidi Int16 where toVal = VPrim . VPInt16 +instance Heidi Int32 where toVal = VPrim . VPInt32 +instance Heidi Int64 where toVal = VPrim . VPInt64 +instance Heidi Word8 where toVal = VPrim . VPWord8 +instance Heidi Word16 where toVal = VPrim . VPWord16 +instance Heidi Word32 where toVal = VPrim . VPWord32 +instance Heidi Word64 where toVal = VPrim . VPWord64 +instance Heidi Float where toVal = VPrim . VPFloat +instance Heidi Double where toVal = VPrim . VPDouble +instance Heidi Scientific where toVal = VPrim . VPScientific +instance Heidi Char where toVal = VPrim . VPChar +instance Heidi String where toVal = VPrim . VPString +instance Heidi Text where toVal = VPrim . VPText + +instance Heidi a => Heidi (Maybe a) where + toVal = \case + Nothing -> VRec "Maybe" HM.empty + Just x -> VRec "Maybe" $ HM.singleton "Just" $ toVal x + +instance (Heidi a, Heidi b) => Heidi (Either a b) where + toVal = \case + Left l -> VRec "Either" $ HM.singleton "Left" $ toVal l + Right r -> VRec "Either" $ HM.singleton "Right" $ toVal r + +instance (Heidi a, Heidi b) => Heidi (a, b) where + toVal (x, y) = VRec "(,)" $ HM.fromList $ zip labels [toVal x, toVal y] + +instance (Heidi a, Heidi b, Heidi c) => Heidi (a, b, c) where + toVal (x, y, z) = VRec "(,,)" $ HM.fromList $ zip labels [toVal x, toVal y, toVal z] + + + + + +-- | Extract an Int +getInt :: VP -> Maybe Int +getInt = \case {VPInt i -> Just i; _ -> Nothing} +-- | Extract an Int8 +getInt8 :: VP -> Maybe Int8 +getInt8 = \case {VPInt8 i -> Just i; _ -> Nothing} +-- | Extract an Int16 +getInt16 :: VP -> Maybe Int16 +getInt16 = \case {VPInt16 i -> Just i; _ -> Nothing} +-- | Extract an Int32 +getInt32 :: VP -> Maybe Int32 +getInt32 = \case {VPInt32 i -> Just i; _ -> Nothing} +-- | Extract an Int64 +getInt64 :: VP -> Maybe Int64 +getInt64 = \case {VPInt64 i -> Just i; _ -> Nothing} +-- | Extract a Word +getWord :: VP -> Maybe Word +getWord = \case {VPWord i -> Just i; _ -> Nothing} +-- | Extract a Word8 +getWord8 :: VP -> Maybe Word8 +getWord8 = \case {VPWord8 i -> Just i; _ -> Nothing} +-- | Extract a Word16 +getWord16 :: VP -> Maybe Word16 +getWord16 = \case {VPWord16 i -> Just i; _ -> Nothing} +-- | Extract a Word32 +getWord32 :: VP -> Maybe Word32 +getWord32 = \case {VPWord32 i -> Just i; _ -> Nothing} +-- | Extract a Word64 +getWord64 :: VP -> Maybe Word64 +getWord64 = \case {VPWord64 i -> Just i; _ -> Nothing} +-- | Extract a Bool +getBool :: VP -> Maybe Bool +getBool = \case {VPBool i -> Just i; _ -> Nothing} +-- | Extract a Float +getFloat :: VP -> Maybe Float +getFloat = \case {VPFloat i -> Just i; _ -> Nothing} +-- | Extract a Double +getDouble :: VP -> Maybe Double +getDouble = \case {VPDouble i -> Just i; _ -> Nothing} +-- | Extract a Scientific +getScientific :: VP -> Maybe Scientific +getScientific = \case {VPScientific i -> Just i; _ -> Nothing} +-- | Extract a Char +getChar :: VP -> Maybe Char +getChar = \case {VPChar i -> Just i; _ -> Nothing} +-- | Extract a String +getString :: VP -> Maybe String +getString = \case {VPString i -> Just i; _ -> Nothing} +-- | Extract a Text string +getText :: VP -> Maybe Text +getText = \case {VPText i -> Just i; _ -> Nothing} +-- | Extract a OneHot value +getOneHot :: VP -> Maybe (OneHot Int) +getOneHot = \case {VPOH i -> Just i; _ -> Nothing} + +-- | Helper function for decoding into a 'MonadThrow'. +decodeM :: (MonadThrow m, Exception e) => + e -> (a -> m b) -> Maybe a -> m b +decodeM e = maybe (throwM e) + + +getIntM :: MonadThrow m => VP -> m Int +getIntM x = decodeM IntCastE pure (getInt x) +getInt8M :: MonadThrow m => VP -> m Int8 +getInt8M x = decodeM Int8CastE pure (getInt8 x) +getInt16M :: MonadThrow m => VP -> m Int16 +getInt16M x = decodeM Int16CastE pure (getInt16 x) +getInt32M :: MonadThrow m => VP -> m Int32 +getInt32M x = decodeM Int32CastE pure (getInt32 x) +getInt64M :: MonadThrow m => VP -> m Int64 +getInt64M x = decodeM Int64CastE pure (getInt64 x) +getWordM :: MonadThrow m => VP -> m Word +getWordM x = decodeM WordCastE pure (getWord x) +getWord8M :: MonadThrow m => VP -> m Word8 +getWord8M x = decodeM Word8CastE pure (getWord8 x) +getWord16M :: MonadThrow m => VP -> m Word16 +getWord16M x = decodeM Word16CastE pure (getWord16 x) +getWord32M :: MonadThrow m => VP -> m Word32 +getWord32M x = decodeM Word32CastE pure (getWord32 x) +getWord64M :: MonadThrow m => VP -> m Word64 +getWord64M x = decodeM Word64CastE pure (getWord64 x) +getBoolM :: MonadThrow m => VP -> m Bool +getBoolM x = decodeM BoolCastE pure (getBool x) +getFloatM :: MonadThrow m => VP -> m Float +getFloatM x = decodeM FloatCastE pure (getFloat x) +getDoubleM :: MonadThrow m => VP -> m Double +getDoubleM x = decodeM DoubleCastE pure (getDouble x) +getScientificM :: MonadThrow m => VP -> m Scientific +getScientificM x = decodeM ScientificCastE pure (getScientific x) +getCharM :: MonadThrow m => VP -> m Char +getCharM x = decodeM CharCastE pure (getChar x) +getStringM :: MonadThrow m => VP -> m String +getStringM x = decodeM StringCastE pure (getString x) +getTextM :: MonadThrow m => VP -> m Text +getTextM x = decodeM TextCastE pure (getText x) +getOneHotM :: MonadThrow m => VP -> m (OneHot Int) +getOneHotM x = decodeM OneHotCastE pure (getOneHot x) + +-- | Type errors +data TypeError = + FloatCastE + | DoubleCastE + | ScientificCastE + | IntCastE + | Int8CastE + | Int16CastE + | Int32CastE + | Int64CastE + | WordCastE + | Word8CastE + | Word16CastE + | Word32CastE + | Word64CastE + | BoolCastE + | CharCastE + | StringCastE + | TextCastE + | OneHotCastE + deriving (Show, Eq, Typeable) +instance Exception TypeError + + + + + + +-- -- examples + +-- data A0 = A0 deriving (Eq, Show, G.Generic) +-- instance Heidi A0 +-- newtype A = A Int deriving (Eq, Show, G.Generic) +-- instance Heidi A +-- newtype A2 = A2 { a2 :: Int } deriving (Eq, Show, G.Generic) +-- instance Heidi A2 +-- data B = B Int Char deriving (Eq, Show, G.Generic) +-- instance Heidi B +-- data B2 = B2 { b21 :: Int, b22 :: Char } deriving (Eq, Show, G.Generic) +-- instance Heidi B2 +-- data C = C1 | C2 | C3 deriving (Eq, Show, G.Generic) +-- instance Heidi C +-- data D = D (Maybe Int) (Either Int String) deriving (Eq, Show, G.Generic) +-- instance Heidi D +-- data E = E (Maybe Int) (Maybe Char) deriving (Eq, Show, G.Generic) +-- instance Heidi E +-- newtype F = F (Int, Char) deriving (Eq, Show, G.Generic) +-- instance Heidi F + diff --git a/src/Data/Generics/Encode/OneHot.hs b/src/Data/Generics/Encode/OneHot.hs new file mode 100644 --- /dev/null +++ b/src/Data/Generics/Encode/OneHot.hs @@ -0,0 +1,79 @@ +{-# language DeriveGeneric, FlexibleContexts, ScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Generics.Encode.OneHot +-- Description : Generic 1-hot encoding of enumeration types +-- Copyright : (c) Marco Zocca (2019) +-- License : MIT +-- Maintainer : ocramz fripost org +-- Stability : experimental +-- Portability : GHC +-- +-- Generic 1-hot encoding of enumeration types +-- +----------------------------------------------------------------------------- +module Data.Generics.Encode.OneHot (OneHot, onehotDim, onehotIx, oneHotV + -- ** Internal + , mkOH) where + +import qualified GHC.Generics as G +import Data.Hashable (Hashable(..)) +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as VM +import Generics.SOP (DatatypeInfo, ConstructorInfo(..), constructorInfo, ConstructorName, hindex, hmap, SOP(..), I(..), K(..), hcollapse, SListI) +-- import Generics.SOP.NP (cpure_NP) +-- import Generics.SOP.Constraint (SListIN) +-- import Generics.SOP.GGP (GCode, GDatatypeInfo, GFrom, gdatatypeInfo, gfrom) + +-- $setup +-- >>> :set -XDeriveDataTypeable +-- >>> :set -XDeriveGeneric +-- >>> import Generics.SOP (Generic(..), All, Code, Proxy(..)) +-- >>> import Generics.SOP.NP +-- >>> import qualified GHC.Generics as G +-- >>> import Generics.SOP.GGP (gdatatypeInfo, gfrom) +-- >>> data C = C1 | C2 | C3 deriving (Eq, Show, G.Generic) + +-- | Construct a 'OneHot' encoding from generic datatype and value information +-- +-- >>> mkOH (gdatatypeInfo (Proxy :: Proxy C)) (gfrom C2) +-- OH {ohDim = 3, ohIx = 1} +mkOH :: SListI xs => DatatypeInfo xs -> SOP I xs -> OneHot Int +mkOH di sop = oneHot where + oneHot = OH sdim six + six = hindex sop + sdim = length $ constructorList di + +-- | 1-hot encoded vector. +-- +-- This representation is used to encode categorical variables as points in a vector space. +data OneHot i = OH { + ohDim :: i -- ^ Dimensionality of the ambient space + , ohIx :: i -- ^ index of '1' + } deriving (Eq, Ord, G.Generic) +instance Hashable i => Hashable (OneHot i) +instance Show i => Show (OneHot i) where + show (OH od oi) = concat ["OH_", show od, "_", show oi] + +-- | Embedding dimension of the 1-hot encoded vector +onehotDim :: OneHot i -> i +onehotDim = ohDim +-- | Active ('hot') index of the 1-hot encoded vector +onehotIx :: OneHot i -> i +onehotIx = ohIx + +constructorList :: SListI xs => DatatypeInfo xs -> [ConstructorName] +constructorList di = hcollapse $ hmap (\(Constructor x) -> K x) $ constructorInfo di + + +-- | Create a one-hot vector +oneHotV :: Num a => + OneHot Int + -> V.Vector a +oneHotV (OH n i) = V.create $ do + vm <- VM.replicate n 0 + VM.write vm i 1 + return vm + + +-- data C = C1 | C2 | C3 deriving (Eq, Show, G.Generic) diff --git a/src/Heidi.hs b/src/Heidi.hs new file mode 100644 --- /dev/null +++ b/src/Heidi.hs @@ -0,0 +1,100 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Heidi +-- Description : tidy data in Haskell +-- Copyright : (c) Marco Zocca (2018-2020) +-- License : BSD-style +-- Maintainer : ocramz fripost org +-- Stability : experimental +-- Portability : GHC +-- +-- Heidi : tidy data in Haskell +-- +-- In Heidi, a data 'Frame' is not meant to be constructed directly, but 'encode'd from a +-- collection of values. The encoding produces a simple representation which can be easily manipulated for common data analysis tasks. +-- +-- +-- +----------------------------------------------------------------------------- +{-# options_ghc -Wno-unused-imports #-} +module Heidi ( + -- * Frame + Frame + -- ** Construction + -- *** Encoding + , encode, Heidi, TC, VP + -- *** Direct + , frameFromList + -- ** Access + , head, take, drop, numRows + -- ** Filtering + , filter, filterA + -- ** Grouping + , groupWith + -- ** Zipping + , zipWith + -- ** Scans + , scanl, scanr + -- * Data tidying + , spreadWith, gatherWith + -- * Relational operations + , groupBy, innerJoin, leftOuterJoin + -- ** Vector-related + , toVector, fromVector + + -- * Row + , Row + -- * Construction + , rowFromList + -- ** Access + , toList, keys + -- * Filtering + , delete, filterWithKey, filterWithKeyPrefix, filterWithKeyAny + , deleteMany + -- * Partitioning + , partitionWithKey, partitionWithKeyPrefix + -- -- ** Decoders + -- , real, scientific, text, string, oneHot + -- * Lookup + , lookup + -- , lookupThrowM + , (!:), elemSatisfies + -- ** Lookup utilities + , maybeEmpty + -- ** Comparison by lookup + , eqByLookup, eqByLookups + , compareByLookup + -- * Set operations + , union, unionWith + , intersection, intersectionWith + -- * Maps + , mapWithKey + -- * Folds + , foldWithKey, keysOnly + -- * Traversals + , traverseWithKey + -- * Lenses + , int, bool, float, double, char, string, text, scientific, oneHot + -- ** Lens combinators + , at, keep + -- *** Combinators for list-indexed rows + , atPrefix, eachPrefixed, foldPrefixed + -- ** Encode internals + , tcTyN, tcTyCon, mkTyN, mkTyCon + -- , DataException(..) + ) + where + +import Control.Monad.Catch (MonadThrow(..)) + +import Core.Data.Frame.List (Frame, frameFromList, head, take, drop, zipWith, numRows, filter, filterA, groupWith, scanl, scanr, toVector, fromVector) +import Core.Data.Frame.Generic (encode) +import Data.Generics.Encode.Internal (Heidi, VP(..)) +-- import qualified Data.Generics.Decode as D (Decode, runDecode) +import Data.Generics.Codec (TC(..), tcTyN, tcTyCon, mkTyN, mkTyCon, TypeError(..)) +import Heidi.Data.Row.GenericTrie +import Heidi.Data.Frame.Algorithms.GenericTrie (innerJoin, leftOuterJoin, gatherWith, spreadWith, groupBy) + +-- import Control.Monad.Catch (MonadThrow(..)) +import Prelude hiding (filter, zipWith, lookup, foldl, foldr, scanl, scanr, head, take, drop) + diff --git a/src/Heidi/Data/Frame/Algorithms/GenericTrie.hs b/src/Heidi/Data/Frame/Algorithms/GenericTrie.hs new file mode 100644 --- /dev/null +++ b/src/Heidi/Data/Frame/Algorithms/GenericTrie.hs @@ -0,0 +1,273 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Heidi.Data.Frame.Algorithms.GenericTrie +-- Description : GenericTrie-based dataframe algorithms +-- Copyright : (c) Marco Zocca (2018-2019) +-- License : BSD-style +-- Maintainer : ocramz fripost org +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- +module Heidi.Data.Frame.Algorithms.GenericTrie ( + -- ** Row-wise operations + unionColsWith + -- ** Filtering + -- , filterByKey + -- ** Data tidying + , spreadWith, gatherWith + -- ** Relational operations + , groupBy, innerJoin, leftOuterJoin + ) where + +import Data.Maybe (fromMaybe) +-- import Control.Applicative (Alternative(..)) +import qualified Data.Foldable as F (foldMap, foldl', foldlM) +-- import Data.Foldable (foldl, foldr, foldlM, foldrM) +-- import Data.Typeable (Typeable) + +-- containers +import qualified Data.Map as M +import qualified Data.Set as S (Set, fromList) +-- exception +-- import Control.Monad.Catch(Exception(..), MonadThrow(..)) + +-- primitive +-- import Control.Monad.Primitive (PrimMonad(..), PrimState(..)) +-- scientific +-- import Data.Scientific (Scientific, toRealFloat) +-- vector +-- import qualified Data.Vector as V +-- import qualified Data.Vector.Generic.Mutable as VGM +-- vector-algorithms +-- import qualified Data.Vector.Algorithms.Merge as V (sort, sortBy, Comparison) +-- generic-trie +import qualified Data.GenericTrie as GT +-- text +-- import qualified Data.Text as T (pack) +-- import Data.Text (Text) + + +-- import qualified Data.Generics.Decode as D (Decode, runDecode) +-- import Data.Generics.Decode ((>>>)) +import Core.Data.Frame.List (Frame, frameFromList, zipWith) +import qualified Heidi.Data.Row.GenericTrie as GTR +-- import Core.Data.Row.Internal +-- import Data.Generics.Encode.Val (VP, getIntM, getFloatM, getDoubleM, getScientificM, getStringM, getTextM, getOneHotM) +-- import Data.Generics.Encode.OneHot (OneHot) + +import Prelude hiding (filter, zipWith, lookup, foldl, foldr, scanl, scanr, head, take, drop) + + + +-- -- insertDecode :: (Functor f, GT.TrieKey k) => +-- -- D.Decode f (GTR.Row k v) v -- !!! this constrains start, end value types to be identical +-- -- -> k +-- -- -> GTR.Row k v +-- -- -> f (GTR.Row k v) +-- insertDecode dec g k row = f <$> D.runDecode dec row where +-- f x = GTR.insert k (g x) row + +-- -- sumCols k1 k2 = insertDecode fk where +-- -- fk = (+) <$> GTR.scientific k1 <*> GTR.scientific k2 + + + +-- | Merge two frames by taking the set union of the columns +unionColsWith :: (Eq k, GT.TrieKey k) => + (v -> v -> v) -- ^ Element combination function + -> Frame (GTR.Row k v) + -> Frame (GTR.Row k v) + -> Frame (GTR.Row k v) +unionColsWith f = zipWith (GTR.unionWith f) + + +-- | Filter a 'Frame' according to predicate applied to an element pointed to by a given key. +-- +-- >>> numRows <$> filterByKey "item" (/= "book") t0 +-- Just 2 +-- filterByKey :: (Eq k, GT.TrieKey k) => +-- k -- ^ Key +-- -> (v -> Bool) -- ^ Predicate to be applied to the element +-- -> Frame (GTR.Row k v) +-- -> Frame (GTR.Row k v) +-- filterByKey k ff = filter (k GTR.!: ff) + + + +-- * Data tidying + +-- | 'gatherWith' moves column names into a "key" column, gathering the column values into a single "value" column +gatherWith :: (Foldable t, Ord k, GT.TrieKey k) => + (k -> v) + -> S.Set k -- ^ set of keys to gather + -> k -- ^ "key" key + -> k -- ^ "value" key + -> t (GTR.Row k v) -- ^ input dataframe + -> Frame (GTR.Row k v) +gatherWith fk ks kKey kValue = frameFromList . F.foldMap f where + f row = gather1 fk ks row kKey kValue + +-- | gather one row into a list of rows +gather1 :: (Ord k, GT.TrieKey k) => + (k -> v) + -> S.Set k + -> GTR.Row k v -- ^ row to look into + -> k -- ^ "key" key + -> k -- ^ "value" key + -> [GTR.Row k v] +gather1 fk ks row kKey kValue = fromMaybe [] $ F.foldlM insf [] ks where + rowBase = GTR.deleteMany ks row + lookupInsert k = do + x <- GTR.lookup k row + let + r' = GTR.insert kKey (fk k) rowBase + r'' = GTR.insert kValue x r' + pure r'' + insf acc k = do + r' <- lookupInsert k + pure $ r' : acc +{-# inline gather1 #-} + + + + +-- | 'spreadWith' moves the unique values of a key column into the column names, spreading the values of a value column across the new columns. +spreadWith :: (GT.TrieKey k, Foldable t, Ord k, Ord v) => + (v -> k) + -> k -- ^ "key" key + -> k -- ^ "value" key + -> t (GTR.Row k v) -- ^ input dataframe + -> Frame (GTR.Row k v) +spreadWith fk k1 k2 = frameFromList . map funion . M.toList . F.foldl' (spread1 fk k1 k2) M.empty + where + funion (km, vm) = GTR.union km vm + +-- | spread1 creates a single row from multiple ones that share a subset of key-value pairs. +spread1 :: (Ord k, Ord v, GT.TrieKey k, Eq k) => + (v -> k) + -> k + -> k + -> M.Map (GTR.Row k v) (GTR.Row k v) + -> GTR.Row k v + -> M.Map (GTR.Row k v) (GTR.Row k v) +spread1 fk k1 k2 hmacc row = M.insert rowBase kvNew hmacc where + ks = S.fromList [k1, k2] + rowBase = GTR.deleteMany ks row + hmv = GTR.maybeEmpty $ M.lookup rowBase hmacc + kvNew = GTR.maybeEmpty $ do + k <- GTR.lookup k1 row + v <- GTR.lookup k2 row + pure $ GTR.insert (fk k) v hmv +{-# inline spread1 #-} + + + + +-- r0, r1, r2, r3 :: GTR.Row String String +-- r0 = GTR.fromKVs [ +-- ("country", "A"), ("type", "cases"), ("count", "0.7")] +-- r1 = GTR.fromKVs [ +-- ("country", "A"), ("type", "pop"), ("count", "19")] +-- r2 = GTR.fromKVs [ +-- ("country", "B"), ("type", "cases"), ("count", "37")] +-- r3 = GTR.fromKVs [ +-- ("country", "B"), ("type", "pop"), ("count", "172")] + +-- -- frame0 :: [GTR.Row String String] +-- frame0 = fromList [r0, r1, r2, r3] + +-- fr1 = spread id "type" "count" frame0 + +-- fr2 = gather id (S.fromList ["cases", "pop"]) "type" "count" fr1 + + + + + +-- * Relational operations + +-- | GROUP BY : given a key and a table that uses it, split the table in multiple tables, one per value taken by the key. +-- +-- >>> numRows <$> (HM.lookup "129" $ groupBy "id.0" t0) +-- Just 2 +groupBy :: (Foldable t, GT.TrieKey k, Eq k, Ord v) => + k -- ^ Key to group by + -> t (GTR.Row k v) -- ^ A 'Frame (GTR.Row k v) can be used here + -> M.Map v (Frame (GTR.Row k v)) +groupBy k tbl = frameFromList <$> groupL k tbl + +groupL :: (Foldable t, Eq k, GT.TrieKey k, Eq v, Ord v) => + k -> t (GTR.Row k v) -> M.Map v [GTR.Row k v] +groupL k tbl = F.foldl' insf M.empty tbl where + insf acc row = maybe acc (\v -> M.insertWith (++) v [row] acc) (GTR.lookup k row) +{-# inline groupL #-} + + + + + +joinWith :: (Foldable t, Ord v, GT.TrieKey k, Eq v, Eq k) => + (GTR.Row k v -> [GTR.Row k v] -> [GTR.Row k v]) + -> k + -> k + -> t (GTR.Row k v) + -> t (GTR.Row k v) + -> Frame (GTR.Row k v) +joinWith f k1 k2 table1 table2 = frameFromList $ F.foldl' insf [] table1 where + insf acc row1 = maybe (f row1 acc) appendMatchRows (GTR.lookup k1 row1) where + appendMatchRows v = map (GTR.union row1) mr2 ++ acc where + mr2 = matchingRows k2 v table2 + + + +-- | LEFT (OUTER) JOIN : given two dataframes and one key from each, compute the left outer join using the keys as relations. +leftOuterJoin :: (Foldable t, Ord v, GT.TrieKey k, Eq v, Eq k) => + k + -> k + -> t (GTR.Row k v) + -> t (GTR.Row k v) + -> Frame (GTR.Row k v) +leftOuterJoin = joinWith (:) + + +-- | INNER JOIN : given two dataframes and one key from each, compute the inner join using the keys as relations. +-- +-- >>> head t0 +-- [("id.0","129"),("qty","1"),("item","book")] +-- +-- >>> head t1 +-- [("id.1","129"),("price","100")] +-- +-- >>> head $ innerJoin "id.0" "id.1" t0 t1 +-- [("id.1","129"),("id.0","129"),("qty","5"),("item","book"),("price","100")] +innerJoin :: (Foldable t, Ord v, GT.TrieKey k, Eq v, Eq k) => + k -- ^ Key into the first table + -> k -- ^ Key into the second table + -> t (GTR.Row k v) -- ^ First dataframe + -> t (GTR.Row k v) -- ^ Second dataframe + -> Frame (GTR.Row k v) +innerJoin = joinWith seq + + + + + + +matchingRows :: (Foldable t, GT.TrieKey k, Eq k, Ord v) => + k -> v -> t (GTR.Row k v) -> [GTR.Row k v] +matchingRows k v rows = fromMaybe [] (M.lookup v rowMap) where + rowMap = hjBuild k rows +{-# INLINE matchingRows #-} + +-- | "build" phase of the hash-join algorithm +-- +-- For a given key 'k' and a set of frame rows, populates a hashmap from the _values_ corresponding to 'k' to the corresponding rows. +hjBuild :: (Foldable t, Eq k, GT.TrieKey k, Eq v, Ord v) => + k -> t (GTR.Row k v) -> M.Map v [GTR.Row k v] +hjBuild k = F.foldl' insf M.empty where + insf hmAcc row = maybe hmAcc (\v -> M.insertWith (++) v [row] hmAcc) $ GTR.lookup k row +{-# INLINE hjBuild #-} + + + diff --git a/src/Heidi/Data/Frame/Algorithms/GenericTrie/Generic.hs b/src/Heidi/Data/Frame/Algorithms/GenericTrie/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Heidi/Data/Frame/Algorithms/GenericTrie/Generic.hs @@ -0,0 +1,40 @@ +{-# language LambdaCase #-} +{-# options_ghc -Wno-unused-imports #-} +module Heidi.Data.Frame.Algorithms.GenericTrie.Generic where + +-- containers +import qualified Data.Set as S +-- generic-trie +import qualified Data.GenericTrie as GT +-- text +import qualified Data.Text as T (Text, pack, unpack) + +import Heidi.Data.Row.GenericTrie (Row) +import Heidi.Data.Frame.Algorithms.GenericTrie (spreadWith, gatherWith) +import Core.Data.Frame.List (Frame) +-- import Data.Generics.Codec () + +import Data.Generics.Encode.Internal (VP(..), TC(..), tcTyCon, tcTyN, mkTyCon, mkTyN) + + + +-- -- a user shouldn\t have to manipulate TCs + +-- spread :: Foldable t => [TC] -> [TC] -> t (Row [TC] VP) -> Frame (Row [TC] VP) +-- spread = spreadWith valueToKey + +-- gather :: Foldable t => +-- S.Set [TC] +-- -> [TC] +-- -> [TC] +-- -> t (Row [TC] VP) +-- -> Frame (Row [TC] VP) +-- gather = gatherWith keyToValue + + +keyToValue :: [TC] -> VP +keyToValue = VPString . concatMap tcTyN + +valueToKey :: VP -> [TC] +valueToKey = pure . mkTyN . show + diff --git a/src/Heidi/Data/Row/GenericTrie.hs b/src/Heidi/Data/Row/GenericTrie.hs new file mode 100644 --- /dev/null +++ b/src/Heidi/Data/Row/GenericTrie.hs @@ -0,0 +1,466 @@ +{-# language DeriveFunctor #-} +{-# language DeriveFoldable #-} +{-# language DeriveGeneric #-} +{-# language DeriveTraversable #-} +{-# language TemplateHaskell #-} +{-# language LambdaCase #-} +{-# language RankNTypes #-} +{-# options_ghc -Wno-unused-imports #-} +----------------------------------------------------------------------------- +-- | +-- Module : Heidi.Data.Row.GenericTrie +-- Description : A sparse dataframe row, based on GenericTrie +-- Copyright : (c) Marco Zocca (2018-2019) +-- License : BSD-style +-- Maintainer : ocramz fripost org +-- Stability : experimental +-- Portability : GHC +-- +-- Rows are internally represented with prefix trees ("tries"), as provided by the +-- @generic-trie@ library; in addition to supporting the possibility of missing features in the dataset, tries provide fast insertion and lookup functionality when keyed with structured datatypes (such as lists or trees). +-- +----------------------------------------------------------------------------- +module Heidi.Data.Row.GenericTrie ( + Row + -- * Construction + , rowFromList, empty + -- ** (unsafe) + , mkRow + -- * Update + , insert, insertMany, insertWith + -- * Access + , toList, keys + -- * Filtering + , delete, filterWithKey, filterWithKeyPrefix, filterWithKeyAny + , deleteMany + -- * Partitioning + , partitionWithKey, partitionWithKeyPrefix + -- -- ** Decoders + -- , real, scientific, text, string, oneHot + -- * Lookup + , lookup + -- , lookupThrowM + , (!:), elemSatisfies + -- ** Lookup utilities + , maybeEmpty + -- ** Comparison by lookup + , eqByLookup, eqByLookups + , compareByLookup + -- * Set operations + , union, unionWith + , intersection, intersectionWith + -- * Maps + , mapWithKey + -- * Folds + , foldWithKey, keysOnly + -- * Traversals + , traverseWithKey + -- * Lenses + , int, bool, float, double, char, string, text, scientific, oneHot + -- ** Lens combinators + , at, keep + -- *** Combinators for list-indexed rows + , atPrefix, eachPrefixed, foldPrefixed + ) where + +-- import Control.Monad (foldM +import Data.Functor.Const (Const(..)) +import Data.Functor.Identity (Identity(..)) +import Data.List (isPrefixOf) +import Data.Maybe (fromMaybe) +import Data.Monoid (Any(..), All(..)) +-- import Data.Semigroup (Endo) +-- import Data.Typeable (Typeable) +-- import Control.Applicative (Alternative(..)) +import qualified Data.Foldable as F +-- import Control.Monad (filterM) +-- generic-trie +import qualified Data.GenericTrie as GT +-- exceptions +-- import Control.Monad.Catch (MonadThrow(..)) +-- microlens +import Lens.Micro (Lens', Traversal', Getting, (^.), (<&>), _Just, Getting, traversed, folded, to, has) +-- -- microlens-th +-- import Lens.Micro.TH (makeLenses) +-- scientific +import Data.Scientific (Scientific) +-- text +import Data.Text (Text) + + +-- import qualified Data.Generics.Decode as D (Decode, mkDecode) +-- import Data.Generics.Decode ((>>>)) +import Data.Generics.Encode.Internal (VP, vpInt, vpFloat, vpDouble, vpString, vpChar, vpText, vpBool, vpScientific, vpOneHot) +import Data.Generics.Encode.OneHot (OneHot) +-- import Data.Generics.Codec +-- import Core.Data.Row.Internal (KeyError(..)) + +import Prelude hiding (any, lookup) + + +-- $setup +-- >>> import Data.Generics.Encode.Internal (VP) +-- >>> let row0 = fromList [(0, 'a'), (3, 'b')] :: Row Int Char +-- >>> let row1 = fromList [(0, 'x'), (1, 'b'), (666, 'z')] :: Row Int Char + + +-- | A 'Row' type is internally a Trie: +-- +-- * Fast random access +-- * Fast set operations +-- * Supports missing elements +newtype Row k v = Row { _unRow :: GT.Trie k v } deriving (Functor, Foldable, Traversable) +-- makeLenses ''Row +instance (GT.TrieKey k, Show k, Show v) => Show (Row k v) where + show = show . GT.toList . _unRow + +instance (GT.TrieKey k, Eq k, Eq v) => Eq (Row k v) where + r1 == r2 = F.toList r1 == F.toList r2 + +instance (GT.TrieKey k, Eq k, Eq v, Ord k, Ord v) => Ord (Row k v) where + r1 <= r2 = F.toList r1 <= F.toList r2 + +-- | Focus on a given column +at :: GT.TrieKey k => k -> Lens' (Row k a) (Maybe a) +at k f m = f mv <&> \case + Nothing -> maybe m (const (delete k m)) mv + Just v' -> insert k v' m + where mv = lookup k m +{-# INLINABLE at #-} + +-- | 'atPrefix' : a Lens' that takes a key prefix and relates a row having lists as keys and the subset of columns corresponding to keys having that prefix +atPrefix :: (GT.TrieKey k, Eq k) => + [k] -- ^ key prefix of the columns of interest + -> Lens' (Row [k] v) [v] +atPrefix k f m = f vs <&> \case + [] -> if null kvs then m else deleteMany ks m + vs' -> insertMany (zip ks vs') m + where + kvs = toList $ filterWithKeyPrefix k m + (ks, vs) = unzip kvs + +{- | Focus on all elements that share a common key prefix + +e.g. + +@ +>>> :t \k -> 'Lens.Micro.toListOf' (eachPrefixed k . 'vpBool') +(GT.TrieKey k, Eq k) => [k] -> Row [k] VP -> [Bool] +@ +-} +eachPrefixed :: (GT.TrieKey k, Eq k) => + [k] -- ^ key prefix of the columns of interest + -> Traversal' (Row [k] v) v +eachPrefixed k = atPrefix k . traversed + +-- | Extract all elements that share a common key prefix into a monoidal value (e.g. a list) +foldPrefixed :: (GT.TrieKey k, Eq k, Monoid r) => + [k] -- ^ key prefix of the columns of interest + -> Getting r (Row [k] v) v +foldPrefixed k = atPrefix k . folded + +-- foldingPrefixed f k = atPrefix k . folding f + +-- any :: Eq a => a -> a -> Any +-- any v = Any . (== v) + +-- | Helper for filtering 'Frame's +-- +-- e.g. +-- +-- >>> :t \k -> keep (text k) (== "hello") +-- :: GT.TrieKey k => k -> Row k VP -> Bool +keep :: Getting Any row a + -> (a -> b) -- ^ e.g. a predicate + -> row + -> Bool +keep l f = has (l . to f) + + +-- keep :: (Eq a) => Getting Any row a -> a -> row -> Bool +-- keep l v = has (l . to (== v)) + +-- ** Lenses + +-- | Decode a 'Bool' from the given column index +bool :: GT.TrieKey k => k -> Traversal' (Row k VP) Bool +bool k = at k . _Just . vpBool +-- | Decode a 'Int' from the given column index +int :: GT.TrieKey k => k -> Traversal' (Row k VP) Int +int k = at k . _Just . vpInt +-- | Decode a 'Float' from the given column index +float :: GT.TrieKey k => k -> Traversal' (Row k VP) Float +float k = at k . _Just . vpFloat +-- | Decode a 'Double' from the given column index +double :: GT.TrieKey k => k -> Traversal' (Row k VP) Double +double k = at k . _Just . vpDouble +-- | Decode a 'Char' from the given column index +char :: GT.TrieKey k => k -> Traversal' (Row k VP) Char +char k = at k . _Just . vpChar +-- | Decode a 'String' from the given column index +string :: GT.TrieKey k => k -> Traversal' (Row k VP) String +string k = at k . _Just . vpString +-- | Decode a 'Text' from the given column index +text :: GT.TrieKey k => k -> Traversal' (Row k VP) Text +text k = at k . _Just . vpText +-- | Decode a 'Scientific' from the given column index +scientific :: GT.TrieKey k => k -> Traversal' (Row k VP) Scientific +scientific k = at k . _Just . vpScientific +-- | Decode a 'OneHot' from the given column index +oneHot :: GT.TrieKey k => k -> Traversal' (Row k VP) (OneHot Int) +oneHot k = at k . _Just . vpOneHot + + + + + + + +-- | Construct a 'Row' from a list of key-element pairs. +-- +-- >>> lookup 3 (rowFromList [(3,'a'),(4,'b')]) +-- Just 'a' +-- >>> lookup 6 (rowFromList [(3,'a'),(4,'b')]) +-- Nothing +rowFromList :: GT.TrieKey k => [(k, v)] -> Row k v +rowFromList = Row . GT.fromList + +-- | Construct a 'Row' from a trie (unsafe). +mkRow :: GT.Trie k v -> Row k v +mkRow = Row + +-- | An empty row +empty :: GT.TrieKey k => Row k v +empty = Row GT.empty + +-- | Access the key-value pairs contained in the 'Row' +toList :: GT.TrieKey k => Row k v -> [(k ,v)] +toList = GT.toList . _unRow + +-- | Lookup the value stored at a given key in a row +-- +-- >>> lookup 0 row0 +-- Just 'a' +-- >>> lookup 1 row0 +-- Nothing +lookup :: (GT.TrieKey k) => k -> Row k v -> Maybe v +lookup k = GT.lookup k . _unRow + +liftLookup :: GT.TrieKey k => + (a -> b -> c) -> k -> Row k a -> Row k b -> Maybe c +liftLookup f k r1 r2 = f <$> lookup k r1 <*> lookup k r2 + + +-- | Compares for ordering two rows by the values indexed at a specific key. +-- +-- Returns Nothing if the key is not present in either row. +compareByLookup :: (GT.TrieKey k, Eq k, Ord a) => + k -> Row k a -> Row k a -> Maybe Ordering +compareByLookup = liftLookup compare + +-- | Compares two rows by the values indexed at a specific key. +-- +-- Returns Nothing if the key is not present in either row. +eqByLookup :: (GT.TrieKey k, Eq k, Eq a) => + k -> Row k a -> Row k a -> Maybe Bool +eqByLookup = liftLookup (==) + +-- | Compares two rows by the values indexed at a set of keys. +-- +-- Returns Nothing if a key in either row is not present. +eqByLookups :: (Foldable t, GT.TrieKey k, Eq k, Eq a) => + t k -> Row k a -> Row k a -> Maybe Bool +eqByLookups ks r1 r2 = F.foldlM insf True ks where + insf b k = (&&) <$> pure b <*> eqByLookup k r1 r2 + +-- -- | Like 'lookup', but throws a 'KeyError' if the lookup is unsuccessful +-- lookupThrowM :: (MonadThrow m, Show k, Typeable k, GT.TrieKey k) => +-- k -> Row k v -> m v +-- lookupThrowM k r = maybe (throwM $ MissingKeyError k) pure (lookup k r) + +-- | Returns an empty row if the argument is Nothing. +maybeEmpty :: GT.TrieKey k => Maybe (Row k v) -> Row k v +maybeEmpty = fromMaybe empty + +-- | List the keys of a given row +-- +-- >>> keys row0 +-- [0,3] +keys :: GT.TrieKey k => Row k v -> [k] +keys = map fst . toList + +-- | Takes the union of a Foldable container of 'Row's and discards the values +keysOnly :: (GT.TrieKey k, Foldable f) => f (Row k v) -> Row k () +keysOnly ks = () <$ F.foldl' union empty ks + +-- | Returns a new 'Row' that doesn't have a given key-value pair +delete :: GT.TrieKey k => + k -- ^ Key to remove + -> Row k v + -> Row k v +delete k (Row gt) = Row $ GT.delete k gt + +-- | Produce a new 'Row' such that its keys do _not_ belong to a certain set. +deleteMany :: (GT.TrieKey k, Foldable t) => t k -> Row k v -> Row k v +deleteMany ks r = foldl (flip delete) r ks + +-- | Map over all elements with a function of both the key and the value +mapWithKey :: GT.TrieKey k => (k -> a -> b) -> Row k a -> Row k b +mapWithKey ff (Row gt) = + runIdentity $ Row <$> GT.traverseWithKey (\k v -> pure (ff k v)) gt + + +-- | Filter a row by applying a predicate to its keys and corresponding elements. +-- +-- NB : filtering _retains_ the elements that satisfy the predicate. +filterWithKey :: GT.TrieKey k => (k -> v -> Bool) -> Row k v -> Row k v +filterWithKey ff (Row gt) = Row $ GT.filterWithKey ff gt + +-- | Retains the entries for which the given list is a prefix of the indexing key +filterWithKeyPrefix :: (GT.TrieKey a, Eq a) => + [a] -- ^ key prefix + -> Row [a] v + -> Row [a] v +filterWithKeyPrefix kpre = filterWithKey (\k _ -> kpre `isPrefixOf` k) + +-- | Partition a 'Row' into two new ones, such as the elements that satisfy the predicate will end up in the _left_ row. +partitionWithKey :: GT.TrieKey k => + (k -> v -> Bool) -- ^ predicate + -> Row k v + -> (Row k v, Row k v) +partitionWithKey qf = foldWithKey insf (empty, empty) + where + insf k v (lacc, racc) | qf k v = (insert k v lacc, racc) + | otherwise = (lacc, insert k v racc) + +-- | Uses 'partitionWithKey' internally +partitionWithKeyPrefix :: (GT.TrieKey a, Eq a) => + [a] -- ^ key prefix + -> Row [a] v + -> (Row [a] v, Row [a] v) +partitionWithKeyPrefix kpre = partitionWithKey (\k _ -> kpre `isPrefixOf` k) + +-- | Retains the entries for which the given item appears at any position in the indexing key +filterWithKeyAny :: (GT.TrieKey a, Eq a) => a -> Row [a] v -> Row [a] v +filterWithKeyAny kany = filterWithKey (\k _ -> kany `elem` k) + + + + +-- alter k m = fromMaybe m $ do +-- v <- lookup k m +-- delete k m + +-- alter k f t = +-- case f (lookup k t) of +-- Just v' -> insert k v' t +-- Nothing -> delete k t + +-- modify k v = + + +-- | Insert a key-value pair into a row and return the updated one +-- +-- >>> keys $ insert 2 'y' row0 +-- [0,2,3] +insert :: (GT.TrieKey k) => k -> v -> Row k v -> Row k v +insert k v = Row . GT.insert k v . _unRow + +insertMany :: (GT.TrieKey k, Foldable t) => t (k, v) -> Row k v -> Row k v +insertMany kvs r = foldl (\acc (k, v) -> insert k v acc) r kvs + +-- | Insert a key-value pair into a row and return the updated one, or updates the value by using the combination function. +insertWith :: (GT.TrieKey k) => (v -> v -> v) -> k -> v -> Row k v -> Row k v +insertWith f k v = Row . GT.insertWith f k v . _unRow + +-- | Fold over a row with a function of both key and value +foldWithKey :: GT.TrieKey k => (k -> a -> r -> r) -> r -> Row k a -> r +foldWithKey fk z (Row gt) = GT.foldWithKey fk z gt + +-- | Traverse a 'Row' using a function of both the key and the element. +traverseWithKey :: (Applicative f, GT.TrieKey k) => (k -> a -> f b) -> Row k a -> f (Row k b) +traverseWithKey f r = Row <$> GT.traverseWithKey f (_unRow r) + + +-- | Set union of two rows +-- +-- >>> keys $ union row0 row1 +-- [0,1,3,666] +union :: (GT.TrieKey k) => Row k v -> Row k v -> Row k v +union r1 r2 = Row $ GT.union (_unRow r1) (_unRow r2) + +-- | Set union of two rows, using a combining function for equal keys +unionWith :: (GT.TrieKey k) => + (v -> v -> v) -> Row k v -> Row k v -> Row k v +unionWith f r1 r2 = Row $ GT.unionWith f (_unRow r1) (_unRow r2) + +-- | Set intersection of two rows +intersection :: GT.TrieKey k => Row k v -> Row k b -> Row k v +intersection r1 r2 = Row $ GT.intersection (_unRow r1) (_unRow r2) + +-- | Set intersections of two rows, using a combining function for equal keys +intersectionWith :: GT.TrieKey k => (a -> b -> v) -> Row k a -> Row k b -> Row k v +intersectionWith f r1 r2 = Row $ GT.intersectionWith f (_unRow r1) (_unRow r2) + + +-- | Looks up a key from a row and applies a predicate to its value (if this is found). If no value is found at that key the function returns False. +-- +-- This function is meant to be used as first argument to 'filter'. +-- +-- >>> elemSatisfies (== 'a') 0 row0 +-- True +-- >>> elemSatisfies (== 'a') 42 row0 +-- False +elemSatisfies :: (GT.TrieKey k) => (a -> Bool) -> k -> Row k a -> Bool +elemSatisfies f k row = maybe False f (lookup k row) + +-- | Inline synonym for 'elemSatisfies' +(!:) :: (GT.TrieKey k) => k -> (a -> Bool) -> Row k a -> Bool +k !: f = elemSatisfies f k + +-- -- | Lookup a value from a Row indexed at the given key (returns in a MonadThrow type) +-- lookupColM :: (MonadThrow m, Show k, Typeable k, GT.TrieKey k) => +-- k -> D.Decode m (Row k o) o +-- lookupColM k = D.mkDecode (lookupThrowM k) + +-- -- -- | Lookup a value from a Row indexed at the given key (returns in the Maybe monad) +-- -- lookupCol :: GT.TrieKey k => k -> D.Decode Maybe (Row k o) o +-- -- lookupCol k = D.mkDecode (lookup k) + + + + + +-- -- * Decoders + +-- -- | Lookup and decode a real number +-- real :: (MonadThrow m, Show k, Typeable k, GT.TrieKey k, Alternative m) => +-- k -> D.Decode m (Row k VP) Double +-- real k = lookupColM k >>> realM + +-- -- | Lookup and decode a real 'Scientific' value +-- scientific :: (MonadThrow m, Show k, Typeable k, GT.TrieKey k, Alternative m) => +-- k -> D.Decode m (Row k VP) Scientific +-- scientific k = lookupColM k >>> scientificM + +-- -- | Lookup and decode a text string (defaults to Text) +-- text :: (MonadThrow m, Show k, Typeable k, GT.TrieKey k, Alternative m) => +-- k -> D.Decode m (Row k VP) Text +-- text k = lookupColM k >>> textM + +-- -- | Lookup and decode a text string (defaults to 'String') +-- string :: (MonadThrow m, Show k, Typeable k, GT.TrieKey k, Alternative m) => +-- k -> D.Decode m (Row k VP) String +-- string k = lookupColM k >>> stringM + +-- -- | Lookup and decode a one-hot encoded enum +-- oneHot :: (MonadThrow m, Show k, Typeable k, GT.TrieKey k) => +-- k -> D.Decode m (Row k VP) (OneHot Int) +-- oneHot k = lookupColM k >>> oneHotM + + + + +-- -- spork k1 k2 = (>) <$> real k1 <*> real k2 + + diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,37 @@ +# resolver: lts-9.0 # GHC 8.0.2 +# resolver: lts-11.0 +# resolver: lts-12.0 +# resolver: lts-13.6 +# resolver: lts-13.17 # GHC 8.6.4 +# resolver: lts-13.21 # GHC 8.6.5 +resolver: lts-14.19 # 8.6.5 + +packages: +- . + +extra-deps: +- generic-trie-0.3.1@sha256:203cfc0086372abaf99ffb4b4b565eba8a28e6020f1104ec479cd96d0c3baeb7 + +# Override default flag values for local packages and extra-deps +# flags: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=1.9" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor diff --git a/test/DocTest.hs b/test/DocTest.hs new file mode 100644 --- /dev/null +++ b/test/DocTest.hs @@ -0,0 +1,12 @@ +module Main where + +import Test.DocTest (doctest) + +main :: IO () +main = doctest [ + -- "src/Data/Generics/Encode/OneHot.hs", + -- "src/Heidi.hs" + -- "src/Data/Generics/Encode/Internal.hs", + -- "src/Core/Data/Frame/Generic.hs", + "src/Core/Data/Frame/List.hs" + ] diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,23 @@ +module Main where + +import Test.Tasty (defaultMain, testGroup) +import Test.Tasty.Hspec (Spec, testSpec, parallel) + +import qualified Unit.GenericTrie as UGTR + +main :: IO () +main = do + test_gtr <- testSpec "GenericTrie-based rows" spec_Frame_GTR + defaultMain $ do + testGroup "Heidi.Data.Frame.Algorithms" [test_gtr] + +spec_Frame_GTR :: Spec +spec_Frame_GTR = parallel $ do + UGTR.test_innerJoin + UGTR.test_leftOuterJoin + UGTR.test_groupBy + +-- spec :: Spec +-- spec = parallel $ do +-- it "is trivially true" $ do +-- True `shouldBe` True diff --git a/test/Unit/GenericTrie.hs b/test/Unit/GenericTrie.hs new file mode 100644 --- /dev/null +++ b/test/Unit/GenericTrie.hs @@ -0,0 +1,62 @@ +module Unit.GenericTrie where + +import Test.Tasty.Hspec (Spec, it, shouldBe) + +import Heidi.Data.Frame.Algorithms.GenericTrie (innerJoin, leftOuterJoin, groupBy) +import Heidi (Frame, frameFromList, Row, rowFromList) + +test_innerJoin :: Spec +test_innerJoin = it "innerJoin" $ do + let jt = innerJoin "id.dep" "id.dep" employee department + length jt `shouldBe` 5 + +test_leftOuterJoin :: Spec +test_leftOuterJoin = it "leftOuterJoin" $ do + let jt = leftOuterJoin "id.dep" "id.dep" employee department + length jt `shouldBe` 6 + +test_groupBy :: Spec +test_groupBy = it "groupBy" $ do + let gt = groupBy "id.dep" employee + length gt `shouldBe` 3 + + + +-- example data from https://en.wikipedia.org/wiki/Join_(SQL) + +employee :: Frame (Row String String) +employee = frameFromList [e1, e2, e3, e4, e5, e6] where + e1 = rowFromList [("name", "Rafferty"), ("id.dep", "31")] + e2 = rowFromList [("name", "Jones"), ("id.dep", "33")] + e3 = rowFromList [("name", "Heisenberg"), ("id.dep", "33")] + e4 = rowFromList [("name", "Robinson"), ("id.dep", "34")] + e5 = rowFromList [("name", "Smith"), ("id.dep", "34")] + e6 = rowFromList [("name", "Williams")] + +department :: Frame (Row String String) +department = frameFromList [d1, d2, d3, d4] where + d1 = rowFromList [("id.dep", "31"), ("dept", "Sales")] + d2 = rowFromList [("id.dep", "33"), ("dept", "Engineering")] + d3 = rowFromList [("id.dep", "34"), ("dept", "Clerical")] + d4 = rowFromList [("id.dep", "35"), ("dept", "Marketing")] + + + + + + +t0 :: Frame (Row String String) +t0 = frameFromList [ book1, ball, bike, book2 ] + where + book1 = rowFromList [("item", "book"), ("id.0", "129"), ("qty", "1")] + book2 = rowFromList [("item", "book"), ("id.0", "129"), ("qty", "5")] + ball = rowFromList [("item", "ball"), ("id.0", "234"), ("qty", "1")] + bike = rowFromList [("item", "bike"), ("id.0", "410"), ("qty", "1")] + +t1 :: Frame (Row String String) +t1 = frameFromList [ r1, r2, r3, r4 ] + where + r1 = rowFromList [("id.1", "129"), ("price", "100")] + r2 = rowFromList [("id.1", "234"), ("price", "50")] + r3 = rowFromList [("id.1", "3"), ("price", "150")] + r4 = rowFromList [("id.1", "99"), ("price", "30")]