Frames (empty) → 0.1.0.0
raw patch · 26 files changed
+2237/−0 lines, 26 filesdep +Chartdep +Chart-diagramsdep +Framessetup-changed
Dependencies added: Chart, Chart-diagrams, Frames, base, bytestring, containers, criterion, diagrams-lib, diagrams-rasterific, foldl, ghc-prim, http-client, lens-family-core, list-t, pipes, primitive, readable, statistics, template-haskell, text, transformers, vector, vinyl, zip-archive
Files
- Frames.cabal +166/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- benchmarks/BenchDemo.hs +21/−0
- benchmarks/InsuranceBench.hs +78/−0
- benchmarks/panda.py +11/−0
- data/GetData.hs +40/−0
- demo/Main.hs +77/−0
- demo/MissingData.hs +47/−0
- demo/Plot.hs +54/−0
- demo/Plot2.hs +56/−0
- demo/TutorialMain.hs +3/−0
- src/Frames.hs +38/−0
- src/Frames/CSV.hs +407/−0
- src/Frames/CoRec.hs +198/−0
- src/Frames/Col.hs +28/−0
- src/Frames/ColumnTypeable.hs +48/−0
- src/Frames/ColumnUniverse.hs +152/−0
- src/Frames/Exploration.hs +95/−0
- src/Frames/Frame.hs +63/−0
- src/Frames/InCore.hs +217/−0
- src/Frames/Melt.hs +117/−0
- src/Frames/Rec.hs +51/−0
- src/Frames/RecF.hs +142/−0
- src/Frames/RecLens.hs +62/−0
- src/Frames/TypeLevel.hs +34/−0
+ Frames.cabal view
@@ -0,0 +1,166 @@+name: Frames+version: 0.1.0.0+synopsis: Data frames For working with tabular data files+description: User-friendly, type safe, runtime efficient tooling for+ working with tabular data deserialized from+ comma-separated values (CSV) files. The type of+ each row of data is inferred from data, which can+ then be streamed from disk, or worked with in+ memory.+license: BSD3+license-file: LICENSE+author: Anthony Cowley+maintainer: acowley@gmail.com+copyright: Copyright (C) 2014-2015 Anthony Cowley+category: Data+build-type: Simple+extra-source-files: benchmarks/*.hs benchmarks/*.py+ demo/Main.hs+ data/GetData.hs+cabal-version: >=1.10++source-repository head+ type: git+ location: http://github.com/acowley/Frames.git++flag demos+ description: Build demonstration programs+ default: False+ manual: True++library+ exposed-modules: Frames+ Frames.Col+ Frames.ColumnTypeable+ Frames.ColumnUniverse+ Frames.CoRec+ Frames.CSV+ Frames.Exploration+ Frames.Frame+ Frames.InCore+ Frames.Melt+ Frames.Rec+ Frames.RecF+ Frames.RecLens+ Frames.TypeLevel+ other-extensions: DataKinds, GADTs, KindSignatures, TypeFamilies,+ TypeOperators, ConstraintKinds, StandaloneDeriving,+ UndecidableInstances, ScopedTypeVariables,+ OverloadedStrings+ build-depends: base >=4.7 && <4.9,+ ghc-prim >=0.3 && <0.5,+ primitive >= 0.6 && < 0.7,+ text >= 1.1.1.0,+ template-haskell,+ transformers,+ vector,+ readable >= 0.3.1,+ pipes >= 4.1 && < 5,+ vinyl >= 0.5 && < 0.6+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall++-- Get the large-ish data files used in the demo and benchmark+executable getdata+ if !flag(demos)+ buildable: False+ main-is: GetData.hs+ if flag(demos)+ build-depends: base, bytestring, http-client, zip-archive+ hs-source-dirs: data+ default-language: Haskell2010+ ghc-options: -Wall++-- Demonstrate using the Chart library to produce figures+executable plot+ if !flag(demos)+ buildable: False+ main-is: Plot.hs+ if flag(demos)+ build-depends: base, Frames,+ lens-family-core, vector, text,+ template-haskell,+ pipes >= 4.1.5 && < 4.2, + Chart >= 1.5 && < 1.6,+ Chart-diagrams >= 1.5 && < 1.6,+ diagrams-rasterific >= 1.3 && < 1.4,+ diagrams-lib >= 1.3 && < 1.4,+ readable, containers, statistics+ hs-source-dirs: demo+ default-language: Haskell2010++executable plot2+ if !flag(demos)+ buildable: False+ main-is: Plot2.hs+ if flag(demos)+ build-depends: base, Frames,+ lens-family-core, vector, text, template-haskell,+ pipes >= 4.1.5 && < 4.2,+ Chart >= 1.5 && < 1.6,+ Chart-diagrams >= 1.5 && < 1.6,+ diagrams-rasterific >= 1.3 && < 1.4,+ diagrams-lib >= 1.3 && < 1.4, + readable, containers, statistics+ hs-source-dirs: demo+ default-language: Haskell2010++-- Miscellaneous tooling around a data file+executable demo+ if !flag(demos)+ buildable: False+ main-is: Main.hs+ if flag(demos)+ build-depends: base, list-t, lens-family-core, transformers, Frames,+ vector, text, template-haskell, ghc-prim, readable,+ pipes >= 4.1.5 && < 4.2+ hs-source-dirs: demo+ default-language: Haskell2010+ ghc-options: -O2 -fllvm++executable tutorial+ if !flag(demos)+ buildable: False+ main-is: TutorialMain.hs+ if flag(demos)+ build-depends: base, Frames,+ lens-family-core, vector, text, template-haskell, readable,+ foldl >= 1.1.0 && < 1.2,+ pipes >= 4.1.5 && < 4.2+ hs-source-dirs: demo+ default-language: Haskell2010++-- A short demo to compare with Pandas+executable benchdemo+ if !flag(demos)+ buildable: False+ main-is: BenchDemo.hs+ if flag(demos)+ build-depends: base, Frames, lens-family-core,+ foldl >= 1.1.0 && < 1.2,+ pipes >= 4.1.5 && < 4.2+ hs-source-dirs: benchmarks+ default-language: Haskell2010+ ghc-options: -O2 -fllvm++-- A demonstration of dealing with missing data. Provided for source+-- code and experimentation rather than a useful executable.+executable missing+ if !flag(demos)+ buildable: False+ main-is: MissingData.hs+ if flag(demos)+ build-depends: base, Frames, vinyl+ hs-source-dirs: demo+ default-language: Haskell2010++-- Benchmark showing tradeoffs of differing processing needs+benchmark insurance+ type: exitcode-stdio-1.0+ hs-source-dirs: benchmarks+ main-is: InsuranceBench.hs+ build-depends: base, criterion, Frames, lens-family-core, transformers,+ pipes >= 4.1.5 && < 4.2+ ghc-options: -O2 -fllvm+ default-language: Haskell2010
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Anthony Cowley++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Anthony Cowley nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ benchmarks/BenchDemo.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE DataKinds, FlexibleContexts, TemplateHaskell #-}+-- | Demonstration of streaming data processing. Try building with+-- cabal (@cabal build benchdemo@), then running in bash with+-- something like,+-- +-- @$ /usr/bin/time -l dist/build/benchdemo/benchdemo 2>&1 | head -n 4@+import Control.Applicative+import qualified Control.Foldl as F+import Frames+import Pipes.Prelude (fold)++tableTypes "Ins" "data/FL2.csv"++main :: IO ()+main = do (lat,lng,n) <- F.purely fold f (readTable "data/FL2.csv")+ print $ lat / n+ print $ lng / n+ where f :: F.Fold Ins (Double,Double,Double)+ f = (,,) <$> F.handles pointLatitude F.sum+ <*> F.handles pointLongitude F.sum+ <*> F.genericLength
+ benchmarks/InsuranceBench.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE BangPatterns,+ DataKinds,+ FlexibleContexts,+ TemplateHaskell #-}+import Criterion.Main+import qualified Data.Foldable as F+import Data.Functor.Identity+import Frames+import qualified Pipes as P+import qualified Pipes.Prelude as P++tableTypes "Ins" "data/FL2.csv"++type TinyIns = Record [PolicyID, PointLatitude, PointLongitude]++tblP :: P.Producer Ins IO ()+tblP = readTable "data/FL2.csv"++-- Strict pair+data P a = P !a !a++-- | Perform two consecutive folds of streamed-in data.+pipeBench :: IO (P Double)+pipeBench = do (n,sumLat) <-+ P.fold (\ !(!i, !s) r -> (i+1, s+rget pointLatitude r))+ (0::Int,0)+ id+ tbl+ sumLong <- P.fold (\s r -> (s + rget pointLongitude r)) 0 id tbl+ return $! P (sumLat / fromIntegral n) (sumLong / fromIntegral n)+ where tbl = P.for tblP (P.yield . rcast) :: P.Producer TinyIns IO ()++-- | Perform two consecutive folds after first streaming all data into+-- an in-memory representation.+pipeBenchInCore :: IO (P Double)+pipeBenchInCore =+ do tbl <- inCore tblP :: IO (P.Producer Ins Identity ())+ let Identity (n,sumLat) =+ P.fold (\ !(!i, !s) r -> (i+1, s+rget pointLatitude r))+ (0::Int,0)+ id+ tbl+ Identity sumLong =+ P.fold (\s r -> (s + rget pointLongitude r)) 0 id tbl+ return $! P (sumLat / fromIntegral n) (sumLong / fromIntegral n)++-- | Perform two consecutive folds after first projecting a subset of+-- fields while streaming data into an in-memory representation.+pipeBenchInCore' :: IO (P Double)+pipeBenchInCore' =+ do tbl <- inCore $ P.for tblP (P.yield . rcast)+ :: IO (P.Producer TinyIns Identity ())+ let Identity (n,sumLat) =+ P.fold (\ !(!i, !s) r -> (i+1, s+rget pointLatitude r))+ (0::Int,0)+ id+ tbl+ Identity sumLong =+ P.fold (\s r -> (s + rget pointLongitude r)) 0 id tbl+ return $! P (sumLat / fromIntegral n) (sumLong / fromIntegral n)++-- | Perform two consecutive folds after projecting a subset of an+-- in-memory reprsentation.+pipeBenchAoS :: IO (P Double)+pipeBenchAoS = do tbl <- inCoreAoS' rcast tblP :: IO (Frame TinyIns)+ let (n,sumLat) =+ F.foldl' (\ !(!i,!s) r -> (i+1, s+rget pointLatitude r))+ (0::Int,0)+ tbl+ sumLong =+ F.foldl' (\ !s r -> (s + rget pointLongitude r)) 0 tbl+ return $! P (sumLat / fromIntegral n) (sumLong / fromIntegral n)++main :: IO ()+main = defaultMain [ bench "pipes" $ whnfIO pipeBench+ , bench "pipes in-core" $ whnfIO pipeBenchInCore+ , bench "pipes in-core subset" $ whnfIO pipeBenchInCore'+ , bench "pipes AoS" $ whnfIO pipeBenchAoS ]
+ benchmarks/panda.py view
@@ -0,0 +1,11 @@+# Demonstration of streaming data processing. Try building with+# cabal, then running with in bash with something like,+# +# $ /usr/bin/time -l python benchmarks/panda.py 2>&1 | head -n 4++from pandas import DataFrame, read_csv+import pandas as pd++df = pd.read_csv('data/FL2.csv')+print(df['point_latitude'].mean())+print(df['point_longitude'].mean())
+ data/GetData.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE OverloadedStrings #-}+import Codec.Archive.Zip+import qualified Data.ByteString.Lazy.Char8 as B+import Data.Maybe (fromJust)+import Network.HTTP.Client++getPrestige :: IO ()+getPrestige = withManager defaultManagerSettings $ \m ->+ httpLbs req m >>=+ B.writeFile "data/prestige.csv" . responseBody+ where Just req = parseUrl "http://vincentarelbundock.github.io/Rdatasets/csv/car/Prestige.csv"++getFLinsurance :: IO ()+getFLinsurance = withManager defaultManagerSettings $ \m -> + httpLbs req m >>=+ B.writeFile "data/FL2.csv"+ . B.map fixup . fromEntry . fromJust+ . findEntryByPath "FL_insurance_sample.csv"+ . toArchive+ . responseBody+ where fixup '\r' = '\n'+ fixup c = c+ Just req = parseUrl "http://spatialkeydocs.s3.amazonaws.com/FL_insurance_sample.csv.zip"++getAdultIncome :: IO ()+getAdultIncome = withManager defaultManagerSettings $ \m ->+ httpLbs req m >>=+ B.writeFile "data/adult.csv"+ . B.append colNames+ . responseBody+ where Just req = parseUrl "http://archive.ics.uci.edu/ml/machine-learning-databases/adult/adult.data"+ colNames = "age, workclass, fnlwgt, education, education-num, \+ \marital-status, occupation, relationship, race, sex, \+ \capital-gain, capital-loss, hours-per-week, \+ \native-country\n"++main :: IO ()+main = do getPrestige+ getFLinsurance+ getAdultIncome
+ demo/Main.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE BangPatterns, DataKinds, TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts, TypeOperators #-}+module Main where+import Data.Functor.Identity+import Frames+import Lens.Family+import qualified ListT as L+import qualified Pipes as P+import qualified Pipes.Prelude as P++tableTypes "Row" "data/data1.csv"++listTlist :: Monad m => L.ListT m a -> m [a]+listTlist = L.toList++tbl :: IO [Row]+tbl = listTlist $ readTable' "data/data1.csv"++ageDoubler :: (Age ∈ rs) => Record rs -> Record rs+ageDoubler = age *~ 2++tbl2 :: IO [Row]+tbl2 = listTlist $ readTable' "data/data2.csv"++tbl2a :: IO [ColFun Maybe Row]+tbl2a = P.toListM $ readTableMaybe "data/data2.csv"++{-++REPL examples:++λ> tbl >>= mapM_ print+{name :-> "joe", age :-> 21}+{name :-> "sue", age :-> 23}+{name :-> "bob", age :-> 44}+{name :-> "laura", age :-> 18}++λ> tbl2 >>= mapM_ print+{name :-> "joe", age :-> 21}+{name :-> "sue", age :-> 23}+{name :-> "laura", age :-> 18}++λ> tbl2a >>= mapM_ (putStrLn . showRecF)+{Just (name :-> "joe"), Just (age :-> 21)}+{Just (name :-> "sue"), Just (age :-> 23)}+{Just (name :-> "bob"), Nothing}+{Just (name :-> "laura"), Just (age :-> 18)}++-}++-- Sample data from http://support.spatialkey.com/spatialkey-sample-csv-data/+-- Note: We have to replace carriage returns (\r) with line feed+-- characters (\n) for the text library's line parsing to work.+tableTypes "Ins" "data/FL2.csv"++insuranceTbl :: P.Producer Ins IO ()+insuranceTbl = readTable "data/FL2.csv"++insMaybe :: P.Producer (ColFun Maybe Ins) IO ()+insMaybe = readTableMaybe "data/FL2.csv"++type TinyIns = Record [PolicyID, PointLatitude, PointLongitude]++main :: IO ()+main = do itbl <- inCore $ P.for insuranceTbl (P.yield . rcast)+ :: IO (P.Producer TinyIns Identity ())+ putStrLn "In-core representation prepared"+ let Identity (n,sumLat) =+ P.fold (\ !(!i,!s) r -> (i+1, s+rget pointLatitude r))+ (0::Int,0)+ id+ itbl+ putStrLn $ "Considering " ++ show n ++ " records..."+ putStrLn $ "Average latitude: " ++ show (sumLat / fromIntegral n)+ let Identity sumLong =+ P.fold (\ !s r -> (s + rget pointLongitude r)) 0 id itbl+ putStrLn $ "Average longitude: " ++ show (sumLong / fromIntegral n)
+ demo/MissingData.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE DataKinds, FlexibleInstances, QuasiQuotes, TypeOperators,+ UndecidableInstances #-}+-- | An example of dealing with rows that contain missing data. We may+-- want to fill in the gaps with default values.+import Data.Monoid ((<>), First(..))+import Data.Vinyl (Rec(..), rmap, RecApplicative, rapply)+import Data.Vinyl.Functor (Lift(..))+import Frames hiding ((:&))++-- An en passant Default class+class Default a where+ def :: a++type MyInt = "int" :-> Int+type MyString = "string" :-> String+type MyBool = "bool" :-> Bool++-- Note that we define instances for column types. This lets us have+-- different defaults for different column names.+instance Default MyInt where def = Col 0+instance Default MyString where def = Col ""+instance Default MyBool where def = Col False++-- We can write instances for /all/ 'Rec' values.+instance (Applicative f, LAll Default ts, RecApplicative ts)+ => Default (Rec f ts) where+ def = reifyDict [pr|Default|] (pure def)++-- Just to try it out at the 'Identity' functor.+defRec :: Record '[MyString, MyInt, MyBool]+defRec = def++-- A default record at a more interesting 'Functor'.+defFirst :: Rec First '[MyString, MyInt, MyBool]+defFirst = def++-- Real data often has holes. Here we have the 'MyString' column, but+-- not the others.+holyRow :: Rec First '[MyString, MyInt, MyBool]+holyRow = rmap First $ pure (Col "joe") :& Nothing :& Nothing :& RNil++-- We can fill in the holes with our default record.+unholy :: Maybe (Record '[MyString, MyInt, MyBool])+unholy = recMaybe . rmap getFirst $ rapply (rmap (Lift . flip (<>)) def) holyRow++main :: IO ()+main = return ()
+ demo/Plot.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE DataKinds, FlexibleContexts, TemplateHaskell #-}+import qualified Data.Vector.Unboxed as V+import Diagrams.Backend.Rasterific+import Diagrams (dims2D, width, height)+import Frames+import Graphics.Rendering.Chart.Backend.Diagrams (defaultEnv, runBackendR)+import Graphics.Rendering.Chart.Easy+import qualified Pipes as P+import qualified Pipes.Prelude as P+import Statistics.Sample.KernelDensity (kde)++-- Data from http://wwwn.cdc.gov/nchs/nhanes/2005-2006/TRIGLY_D.htm+tableTypes "Trigly" "data/trigly_d.csv"++-- Load the data. Invalid records use zeros as a placeholder.+triglyData :: P.Producer Trigly IO ()+triglyData = readTable "data/trigly_d.csv" P.>-> P.filter ((> 0) . view lBDLDL)++-- Adapted from a Chart example+fillBetween :: String -> [(a, (b, b))] -> EC l (PlotFillBetween a b)+fillBetween title vs = liftEC $ do+ plot_fillbetween_title .= title+ color <- dissolve 0.5 `fmap` takeColor+ plot_fillbetween_style .= solidFillStyle color+ plot_fillbetween_values .= vs++-- | Plot a semi-transparent KDE with a thick black outline.+mkPlot :: String -> [Int] -> EC (Layout Double Double) ()+mkPlot title xs = do plot (fillBetween title pts)+ plot . liftEC $ do+ zoom plot_lines_style $ do+ line_color .= opaque black+ line_width *= 2+ plot_lines_values .= [map (_2 %~ snd) pts]+ where pts = V.toList . uncurry (V.zipWith (\x y -> (x, (0, y)))) . kde 128+ $ V.fromList (map fromIntegral xs)++-- | Plot LDL cholesterol and Triglyceride levels.+mkPlots :: [Record [LBXTR, LBDLDL]] -> EC (Layout Double Double) ()+mkPlots xs = do layout_title .= "Distributions"+ layout_x_axis . laxis_title .= "mg/dL"+ layout_all_font_styles . font_size *= 2+ mkPlot "LDL" ldls+ mkPlot "Triglycerides" tris+ where ldls = map (view lBDLDL) xs+ tris = map (view lBXTR) xs++main :: IO ()+main = do env <- defaultEnv bitmapAlignmentFns 640 480+ let chart2diagram = fst . runBackendR env . toRenderable . execEC+ ldlData <- P.toListM $ triglyData P.>-> P.map rcast+ let d = chart2diagram $ mkPlots ldlData+ sz = dims2D (width d) (height d)+ renderRasterific "plot.png" sz d
+ demo/Plot2.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE BangPatterns, DataKinds, FlexibleContexts, OverloadedStrings,+ TemplateHaskell #-}+import Diagrams.Backend.Rasterific+import Diagrams (dims2D, width, height)+import Frames+import Graphics.Rendering.Chart.Backend.Diagrams (defaultEnv, runBackendR)+import Graphics.Rendering.Chart.Easy+import Pipes+import qualified Pipes.Prelude as P+import qualified Data.Text as T+import Control.Arrow ((&&&))+import qualified Data.Foldable as F++-- Data from http://archive.ics.uci.edu/ml/datasets/Adult+tableTypes "Income" "data/adult.csv"++adultData :: Producer Income IO ()+adultData = readTable "data/adult.csv"++fishers :: Producer Income IO ()+fishers = adultData >-> P.filter isFisher >-> P.filter makesMoney+ where isFisher = ((>0) . T.count "fishing" . T.toCaseFold . view occupation)+ makesMoney = (> 0) . view capitalGain++fisherIncomeData :: Producer (Record [Age, CapitalGain]) IO ()+fisherIncomeData = fishers >-> P.map rcast++mkPlot :: IO ()+mkPlot = do env <- defaultEnv bitmapAlignmentFns 640 480+ let chart2diagram = fst . runBackendR env . toRenderable . execEC+ xs <- P.toListM fisherIncomeData+ let d = chart2diagram $ do+ layout_title .= "Farmer/fisher Income vs Age"+ layout_x_axis . laxis_title .= "Age (Years)"+ layout_y_axis . laxis_title .= "Capital Gain ($)"+ plot (points "" (map (view age &&& view capitalGain) xs))+ sz = dims2D (width d) (height d)+ renderRasterific "plot2.png" sz d++-- Manually fused folds+main :: IO ()+main = do ((age_,inc,n), _) <- P.fold' aux (0,0,0::Double) id fisherIncomeData+ putStrLn $ "The average farmer/fisher is "+++ show (fromIntegral age_ / n) +++ " and made " ++ show (fromIntegral inc / n)+ where aux !(!sumAge, !sumIncome, n) f = (sumAge + f^.age, sumIncome + f^.capitalGain, n+1)++-- Independent folds+maiN :: IO ()+maiN = do frames <- inCoreAoS fisherIncomeData+ let age_ = F.foldl' ((. view age) . (+)) 0 frames+ inc = F.foldl' ((. view capitalGain) . (+)) 0 frames+ n = fromIntegral $ frameLength frames :: Double+ putStrLn $ "The average farmer/fisher is "+++ show (fromIntegral age_ / n) +++ " and made " ++ show (fromIntegral inc / n)
+ demo/TutorialMain.hs view
@@ -0,0 +1,3 @@+main :: IO ()+main = return ()+
+ src/Frames.hs view
@@ -0,0 +1,38 @@+-- | User-friendly, type safe, runtime efficient tooling for working+-- with tabular data deserialized from comma-separated values (CSV)+-- files. The type of each row of data is inferred from data, which+-- can then be streamed from disk, or worked with in memory.+module Frames+ ( module Data.Vinyl+ , module Data.Vinyl.Lens+ , module Frames.Col+ , module Frames.ColumnUniverse+ , module Frames.CoRec+ , module Frames.CSV+ , module Frames.Exploration+ , module Frames.Frame+ , module Frames.InCore+ , module Frames.Melt+ , module Frames.Rec+ , module Frames.RecF+ , module Frames.RecLens+ , module Frames.TypeLevel+ , Text+ ) where+import Data.Text (Text)+import Data.Vinyl ((<+>))+import Data.Vinyl.Lens hiding (rlens, rget, rput)+import Frames.Col ((:->)(..))+import Frames.ColumnUniverse+import Frames.CoRec (Field, onField, onCoRec)+import Frames.CSV (readTable, readTableMaybe, readTable', + tableType, tableTypes, tableType', tableTypes')+import Frames.Exploration+import Frames.Frame+import Frames.InCore (toFrame, inCore, inCoreSoA,+ inCoreAoS, inCoreAoS', toAoS, filterFrame)+import Frames.Melt (melt, meltRow)+import Frames.Rec (Record, (&:), recUncons, recMaybe, showFields)+import Frames.RecF+import Frames.RecLens+import Frames.TypeLevel
+ src/Frames/CSV.hs view
@@ -0,0 +1,407 @@+{-# LANGUAGE BangPatterns,+ DataKinds,+ FlexibleInstances,+ KindSignatures,+ LambdaCase,+ MultiParamTypeClasses,+ OverloadedStrings,+ QuasiQuotes,+ RecordWildCards,+ ScopedTypeVariables,+ TemplateHaskell,+ TypeOperators #-}+-- | Infer row types from comma-separated values (CSV) data and read+-- that data from files. Template Haskell is used to generate the+-- necessary types so that you can write type safe programs referring+-- to those types.+module Frames.CSV where+import Control.Applicative ((<$>), pure, (<*>))+import Control.Arrow (first)+import Control.Monad (MonadPlus(..))+import Control.Monad.IO.Class+import Data.Char (isAlpha, isAlphaNum, toLower, toUpper)+import Data.Foldable (foldMap)+import Data.Maybe (fromMaybe)+import Data.Monoid ((<>), Monoid(..))+import Data.Proxy+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Data.Traversable (sequenceA)+import Data.Vinyl (RElem, Rec)+import Data.Vinyl.TypeLevel (RIndex)+import Frames.Col+import Frames.ColumnTypeable+import Frames.ColumnUniverse+import Frames.Rec+import Frames.RecF+import Frames.RecLens+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import qualified Pipes as P+import System.IO (Handle, hIsEOF, openFile, IOMode(..), withFile)+import Control.Monad (when)+import Data.Maybe (isNothing)+import Control.Monad (void)++type Separator = T.Text++type QuoteChar = Char++data QuotingMode+ -- | No quoting enabled. The separator may not appear in values+ = NoQuoting+ -- | Quoted values with the given quoting character. Quotes are escaped by doubling them.+ -- Mostly RFC4180 compliant, except doesn't support newlines in values+ | RFC4180Quoting QuoteChar+ deriving (Eq, Show)++data ParserOptions = ParserOptions { headerOverride :: Maybe [T.Text]+ , columnSeparator :: Separator+ , quotingMode :: QuotingMode }+ deriving (Eq, Show)++instance Lift QuotingMode where+ lift NoQuoting = [|NoQuoting|]+ lift (RFC4180Quoting char) = [|RFC4180Quoting $(litE . charL $ char)|]++instance Lift ParserOptions where+ lift (ParserOptions Nothing sep quoting) = [|ParserOptions Nothing $sep' $quoting'|]+ where sep' = [|T.pack $(stringE $ T.unpack sep)|]+ quoting' = lift quoting+ lift (ParserOptions (Just hs) sep quoting) = [|ParserOptions (Just $hs') $sep' $quoting'|]+ where sep' = [|T.pack $(stringE $ T.unpack sep)|]+ hs' = [|map T.pack $(listE $ map (stringE . T.unpack) hs)|]+ quoting' = lift quoting++-- | Default 'ParseOptions' get column names from a header line, and+-- use commas to separate columns.+defaultParser :: ParserOptions+defaultParser = ParserOptions Nothing defaultSep (RFC4180Quoting '\"')++-- | Default separator string.+defaultSep :: Separator+defaultSep = T.pack ","++-- * Parsing++-- | Helper to split a 'T.Text' on commas and strip leading and+-- trailing whitespace from each resulting chunk.+tokenizeRow :: ParserOptions -> T.Text -> [T.Text]+tokenizeRow options =+ handleQuoting . T.splitOn sep+ where sep = columnSeparator options+ quoting = quotingMode options+ handleQuoting = case quoting of+ NoQuoting -> id+ RFC4180Quoting quote -> reassembleRFC4180QuotedParts sep quote++-- | Post processing applied to a list of tokens split by the+-- separator which should have quoted sections reassembeld+reassembleRFC4180QuotedParts :: Separator -> QuoteChar -> [T.Text] -> [T.Text]+reassembleRFC4180QuotedParts sep quoteChar = finish . foldr f ([], Nothing)+ where f :: T.Text -> ([T.Text], Maybe T.Text) -> ([T.Text], Maybe T.Text)+ f part (rest, Just accum)+ | prefixQuoted part = let token = unescape (T.drop 1 part) <> sep <> accum+ in (token : rest, Nothing)+ | otherwise = (rest, Just (unescape part <> sep <> accum))+ f part (rest, Nothing)+ | prefixQuoted part &&+ suffixQuoted part = ((unescape . T.drop 1 . T.dropEnd 1 $ part) : rest, Nothing)+ | suffixQuoted part = (rest, Just (unescape . T.dropEnd 1 $ part))+ | otherwise = (T.strip part : rest, Nothing)++ prefixQuoted t =+ quoteText `T.isPrefixOf` t &&+ (T.length t - (T.length . T.dropWhile (== quoteChar) $ t)) `mod` 2 == 1+ suffixQuoted t =+ quoteText `T.isSuffixOf` t &&+ (T.length t - (T.length . T.dropWhileEnd (== quoteChar) $ t)) `mod` 2 == 1++ quoteText = T.singleton quoteChar++ unescape :: T.Text -> T.Text+ unescape = T.replace (quoteText <> quoteText) quoteText++ finish :: ([T.Text], Maybe T.Text) -> [T.Text]+ finish (rest, Just dangling) = dangling : rest -- FIXME? just assumes the close quote if it's missing+ finish (rest, Nothing ) = rest++--tokenizeRow :: Separator -> T.Text -> [T.Text]+--tokenizeRow sep = map (unquote . T.strip) . T.splitOn sep+-- where unquote txt+-- | quoted txt = case T.dropEnd 1 (T.drop 1 txt) of+-- txt' | T.null txt' -> "Col"+-- | numish txt' -> txt+-- | otherwise -> txt'+-- | otherwise = txt+-- numish = T.all (`elem` ("-+.0123456789"::String))+-- quoted txt = case T.uncons txt of+-- Just ('"', rst)+-- | not (T.null rst) -> T.last rst == '"'+-- _ -> False++-- | Infer column types from a prefix (up to 1000 lines) of a CSV+-- file.+prefixInference :: (ColumnTypeable a, Monoid a)+ => ParserOptions -> Handle -> IO [a]+prefixInference opts h = T.hGetLine h >>= go prefixSize . inferCols+ where prefixSize = 1000 :: Int+ inferCols = map inferType . tokenizeRow opts+ go 0 ts = return ts+ go !n ts =+ hIsEOF h >>= \case+ True -> return ts+ False -> T.hGetLine h >>= go (n - 1) . zipWith (<>) ts . inferCols++-- | Extract column names and inferred types from a CSV file.+readColHeaders :: (ColumnTypeable a, Monoid a)+ => ParserOptions -> FilePath -> IO [(T.Text, a)]+readColHeaders opts f = withFile f ReadMode $ \h ->+ zip <$> maybe (tokenizeRow opts <$> T.hGetLine h)+ pure+ (headerOverride opts)+ <*> prefixInference opts h++-- * Loading Data++-- | Parsing each component of a 'RecF' from a list of text chunks,+-- one chunk per record component.+class ReadRec (rs :: [*]) where+ readRec :: [T.Text] -> Rec Maybe rs++instance ReadRec '[] where+ readRec _ = Nil++instance (Parseable t, ReadRec ts) => ReadRec (s :-> t ': ts) where+ readRec [] = frameCons Nothing (readRec [])+ readRec (h:t) = frameCons (parse' h) (readRec t)++-- | Read a 'RecF' from one line of CSV.+readRow :: ReadRec rs => ParserOptions -> T.Text -> Rec Maybe rs+readRow = (readRec .) . tokenizeRow++-- | Produce rows where any given entry can fail to parse.+readTableMaybeOpt :: (MonadIO m, ReadRec rs)+ => ParserOptions -> FilePath -> P.Producer (Rec Maybe rs) m ()+readTableMaybeOpt opts csvFile =+ do h <- liftIO $ do+ h <- openFile csvFile ReadMode+ when (isNothing $ headerOverride opts) (void $ T.hGetLine h)+ return h+ let go = liftIO (hIsEOF h) >>= \case+ True -> return ()+ False -> liftIO (readRow opts <$> T.hGetLine h) >>= P.yield >> go+ go+{-# INLINE readTableMaybeOpt #-}++-- | Produce rows where any given entry can fail to parse.+readTableMaybe :: (MonadIO m, ReadRec rs)+ => FilePath -> P.Producer (Rec Maybe rs) m ()+readTableMaybe = readTableMaybeOpt defaultParser+{-# INLINE readTableMaybe #-}++-- | Returns a `MonadPlus` producer of rows for which each column was+-- successfully parsed. This is typically slower than 'readTableOpt'.+readTableOpt' :: forall m rs.+ (MonadPlus m, MonadIO m, ReadRec rs)+ => ParserOptions -> FilePath -> m (Record rs)+readTableOpt' opts csvFile =+ do h <- liftIO $ do+ h <- openFile csvFile ReadMode+ when (isNothing $ headerOverride opts) (void $ T.hGetLine h)+ return h+ let go = liftIO (hIsEOF h) >>= \case+ True -> mzero+ False -> let r = recMaybe . readRow opts <$> T.hGetLine h+ in liftIO r >>= maybe go (flip mplus go . return)+ go+{-# INLINE readTableOpt' #-}++-- | Returns a `MonadPlus` producer of rows for which each column was+-- successfully parsed. This is typically slower than 'readTable'.+readTable' :: forall m rs. (MonadPlus m, MonadIO m, ReadRec rs)+ => FilePath -> m (Record rs)+readTable' = readTableOpt' defaultParser+{-# INLINE readTable' #-}++-- | Returns a producer of rows for which each column was successfully+-- parsed.+readTableOpt :: forall m rs.+ (MonadIO m, ReadRec rs)+ => ParserOptions -> FilePath -> P.Producer (Record rs) m ()+readTableOpt opts csvFile = readTableMaybeOpt opts csvFile P.>-> go+ where go = P.await >>= maybe go (\x -> P.yield x >> go) . recMaybe+{-# INLINE readTableOpt #-}++-- | Returns a producer of rows for which each column was successfully+-- parsed.+readTable :: forall m rs. (MonadIO m, ReadRec rs)+ => FilePath -> P.Producer (Record rs) m ()+readTable = readTableOpt defaultParser+{-# INLINE readTable #-}++-- * Template Haskell++-- | Generate a column type.+recDec :: ColumnTypeable a => [(T.Text, a)] -> Q Type+recDec = appT [t|Record|] . go+ where go [] = return PromotedNilT+ go ((n,t):cs) =+ [t|($(litT $ strTyLit (T.unpack n)) :-> $(colType t)) ': $(go cs) |]++-- | Massage a column name from a CSV file into a valid Haskell type+-- identifier.+sanitizeTypeName :: T.Text -> T.Text+sanitizeTypeName = unreserved . fixupStart+ . T.concat . T.split (not . valid) . toTitle'+ where valid c = isAlphaNum c || c == '\'' || c == '_'+ toTitle' = foldMap (onHead toUpper) . T.split (not . isAlphaNum)+ onHead f = maybe mempty (uncurry T.cons) . fmap (first f) . T.uncons + unreserved t+ | t `elem` ["Type"] = "Col" <> t+ | otherwise = t+ fixupStart t = case T.uncons t of+ Nothing -> "Col"+ Just (c,_) | isAlpha c -> t+ | otherwise -> "Col" <> t++-- | Declare a type synonym for a column.+mkColTDec :: TypeQ -> Name -> DecQ+mkColTDec colTypeQ colTName = tySynD colTName [] colTypeQ++-- | Declare a singleton value of the given column type.+mkColPDec :: Name -> TypeQ -> T.Text -> DecsQ+mkColPDec colTName colTy colPName = sequenceA [tySig, val, tySig', val']+ where nm = mkName $ T.unpack colPName+ nm' = mkName $ T.unpack colPName <> "'"+ -- tySig = sigD nm [t|Proxy $(conT colTName)|]+ tySig = sigD nm [t|forall f rs. (Functor f,+ RElem $(conT colTName) rs (RIndex $(conT colTName) rs))+ => ($colTy -> f $colTy)+ -> Record rs+ -> f (Record rs)+ |]+ tySig' = sigD nm' [t|forall f g rs. (Functor f, Functor g,+ RElem $(conT colTName) rs (RIndex $(conT colTName) rs))+ => (g $(conT colTName) -> f (g $(conT colTName)))+ -> Rec g rs+ -> f (Rec g rs)+ |]+ val = valD (varP nm)+ (normalB [e|rlens (Proxy :: Proxy $(conT colTName))|])+ []+ val' = valD (varP nm')+ (normalB [e|rlens' (Proxy :: Proxy $(conT colTName))|])+ []++-- | For each column, we declare a type synonym for its type, and a+-- Proxy value of that type.+colDec :: ColumnTypeable a => T.Text -> T.Text -> a -> DecsQ+colDec prefix colName colTy = (:) <$> mkColTDec colTypeQ colTName'+ <*> mkColPDec colTName' colTyQ colPName+ where colTName = sanitizeTypeName (prefix <> colName)+ colPName = fromMaybe "colDec impossible" $+ fmap (\(c,t) -> T.cons (toLower c) t) (T.uncons colTName)+ colTName' = mkName $ T.unpack colTName+ colTyQ = colType colTy+ colTypeQ = [t|$(litT . strTyLit $ T.unpack colName) :-> $colTyQ|]++-- | Splice for manually declaring a column of a given type. For+-- example, @declareColumn "x2" ''Double@ will declare a type synonym+-- @type X2 = "x2" :-> Double@ and a lens @x2@.+declareColumn :: T.Text -> Name -> DecsQ+declareColumn colName colTy = (:) <$> mkColTDec colTypeQ colTName'+ <*> mkColPDec colTName' colTyQ colPName+ where colTName = sanitizeTypeName colName+ colPName = fromMaybe "colDec impossible" $+ fmap (\(c,t) -> T.cons (toLower c) t) (T.uncons colTName)+ colTName' = mkName $ T.unpack colTName+ colTyQ = return (ConT colTy)+ colTypeQ = [t|$(litT . strTyLit $ T.unpack colName) :-> $colTyQ|]++-- * Default CSV Parsing++-- | Control how row and named column types are generated.+data RowGen a = RowGen { columnNames :: [String]+ -- ^ Use these column names. If empty, expect a+ -- header row in the data file to provide+ -- column names.+ , tablePrefix :: String+ -- ^ A common prefix to use for every generated+ -- declaration.+ , separator :: Separator+ -- ^ The string that separates the columns on a+ -- row.+ , rowTypeName :: String+ -- ^ The row type that enumerates all+ -- columns.+ , columnUniverse :: Proxy a+ -- ^ A type that identifies all the types that+ -- can be used to classify a column. This is+ -- essentially a type-level list of types. See+ -- 'colQ'.+ }++-- | Shorthand for a 'Proxy' value of 'ColumnUniverse' applied to the+-- given type list.+colQ :: Name -> Q Exp+colQ n = [e| (Proxy :: Proxy (ColumnUniverse $(conT n))) |]++-- | A default 'RowGen'. This instructs the type inference engine to+-- get column names from the data file, use the default column+-- separator (a comma), infer column types from the default 'Columns'+-- set of types, and produce a row type with name @Row@.+rowGen :: RowGen Columns+rowGen = RowGen [] "" defaultSep "Row" Proxy++-- | Generate a type for each row of a table. This will be something+-- like @Record ["x" :-> a, "y" :-> b, "z" :-> c]@.+tableType :: String -> FilePath -> DecsQ+tableType n = tableType' rowGen { rowTypeName = n }++-- | Like 'tableType', but additionally generates a type synonym for+-- each column, and a proxy value of that type. If the CSV file has+-- column names \"foo\", \"bar\", and \"baz\", then this will declare+-- @type Foo = "foo" :-> Int@, for example, @foo = rlens (Proxy :: Proxy+-- Foo)@, and @foo' = rlens' (Proxy :: Proxy Foo)@.+tableTypes :: String -> FilePath -> DecsQ+tableTypes n = tableTypes' rowGen { rowTypeName = n }++-- * Customized Data Set Parsing++-- | Generate a type for a row a table. This will be something like+-- @Record ["x" :-> a, "y" :-> b, "z" :-> c]@. Column type synonyms are+-- /not/ generated (see 'tableTypes'').+tableType' :: forall a. (ColumnTypeable a, Monoid a)+ => RowGen a -> FilePath -> DecsQ+tableType' (RowGen {..}) csvFile =+ pure . TySynD (mkName rowTypeName) [] <$>+ (runIO (readColHeaders opts csvFile) >>= recDec')+ where recDec' = recDec :: [(T.Text, a)] -> Q Type+ colNames' | null columnNames = Nothing+ | otherwise = Just (map T.pack columnNames)+ opts = ParserOptions colNames' separator (RFC4180Quoting '\"')++-- | Like 'tableType'', but additionally generates a type synonym for+-- each column, and a proxy value of that type. If the CSV file has+-- column names \"foo\", \"bar\", and \"baz\", then this will declare+-- @type Foo = "foo" :-> Int@, for example, @foo = rlens (Proxy ::+-- Proxy Foo)@, and @foo' = rlens' (Proxy :: Proxy Foo)@.+tableTypes' :: forall a. (ColumnTypeable a, Monoid a)+ => RowGen a -> FilePath -> DecsQ+tableTypes' (RowGen {..}) csvFile =+ do headers <- runIO $ readColHeaders opts csvFile+ recTy <- tySynD (mkName rowTypeName) [] (recDec' headers)+ let optsName = case rowTypeName of+ [] -> error "Row type name shouldn't be empty"+ h:t -> mkName $ toLower h : t ++ "Parser"+ optsTy <- sigD optsName [t|ParserOptions|]+ optsDec <- valD (varP optsName) (normalB $ lift opts) []+ colDecs <- concat <$> mapM (uncurry $ colDec (T.pack tablePrefix)) headers+ return (recTy : optsTy : optsDec : colDecs)+ -- (:) <$> (tySynD (mkName n) [] (recDec' headers))+ -- <*> (concat <$> mapM (uncurry $ colDec (T.pack prefix)) headers)+ where recDec' = recDec :: [(T.Text, a)] -> Q Type+ colNames' | null columnNames = Nothing+ | otherwise = Just (map T.pack columnNames)+ opts = ParserOptions colNames' separator (RFC4180Quoting '\"')
+ src/Frames/CoRec.hs view
@@ -0,0 +1,198 @@+{-# LANGUAGE BangPatterns,+ ConstraintKinds,+ DataKinds,+ FlexibleContexts,+ FlexibleInstances,+ GADTs,+ KindSignatures,+ MultiParamTypeClasses,+ RankNTypes,+ ScopedTypeVariables,+ TypeOperators,+ UndecidableInstances #-}+-- | Co-records: a flexible approach to sum types.+module Frames.CoRec where+import Data.Maybe(fromJust)+import Data.Proxy+import Data.Vinyl+import Data.Vinyl.Functor (Compose(..), (:.), Identity(..))+import Data.Vinyl.TypeLevel (RIndex)+import Frames.RecF (reifyDict)+import Frames.TypeLevel (LAll, HasInstances, AllHave)+import GHC.Prim (Constraint)++-- | Generalize algebraic sum types.+data CoRec :: (* -> *) -> [*] -> * where+ Col :: RElem a ts (RIndex a ts) => !(f a) -> CoRec f ts++-- | A Field of a 'Record' is a 'CoRec Identity'.+type Field = CoRec Identity++-- | Helper to build a 'Show'-able 'CoRec'+col :: (Show a, a ∈ ts) => a -> CoRec (Dict Show) ts+col = Col . Dict++instance Show (CoRec (Dict Show) ts) where+ show (Col (Dict x)) = "Col "++show x++-- | A function type constructor that takes its arguments in the+-- reverse order.+newtype Op b a = Op { runOp :: a -> b }++instance forall ts. (LAll Show ts, RecApplicative ts)+ => Show (CoRec Identity ts) where+ show (Col (Identity x)) = "(Col "++show' x++")"+ where shower :: Rec (Op String) ts+ shower = reifyDict (Proxy::Proxy Show) (Op show)+ show' = runOp (rget Proxy shower)++-- | Remove a 'Dict' wrapper from a value.+dictId :: Dict c a -> Identity a+dictId (Dict x) = Identity x++-- | Helper to build a @Dict Show@+showDict :: Show a => a -> Dict Show a+showDict = Dict+ +-- | We can inject a a 'CoRec' into a 'Rec' where every field of the+-- 'Rec' is 'Nothing' except for the one whose type corresponds to the+-- type of the given 'CoRec' variant.+corecToRec :: RecApplicative ts => CoRec f ts -> Rec (Maybe :. f) ts+corecToRec (Col x) = rput (Compose $ Just x) (rpure (Compose Nothing))++-- | Shorthand for applying 'corecToRec' with common functors.+corecToRec' :: RecApplicative ts => CoRec Identity ts -> Rec Maybe ts+corecToRec' = rmap (fmap getIdentity . getCompose) . corecToRec++-- | Fold a field selection function over a 'Rec'.+class FoldRec ss ts where+ foldRec :: (CoRec f ss -> CoRec f ss -> CoRec f ss)+ -> CoRec f ss+ -> Rec f ts+ -> CoRec f ss++instance FoldRec ss '[] where foldRec _ z _ = z++instance (t ∈ ss, FoldRec ss ts) => FoldRec ss (t ': ts) where+ foldRec f z (x :& xs) = foldRec f (f z (Col x)) xs++-- | Apply a natural transformation to a variant.+corecMap :: (forall x. f x -> g x) -> CoRec f ts -> CoRec g ts+corecMap nt (Col x) = Col (nt x)++-- | This can be used to pull effects out of a 'CoRec'.+corecTraverse :: Functor h+ => (forall x. f x -> h (g x)) -> CoRec f ts -> h (CoRec g ts)+corecTraverse f (Col x) = fmap Col (f x)++-- | Fold a field selection function over a non-empty 'Rec'.+foldRec1 :: FoldRec (t ': ts) ts+ => (CoRec f (t ': ts) -> CoRec f (t ': ts) -> CoRec f (t ': ts))+ -> Rec f (t ': ts)+ -> CoRec f (t ': ts)+foldRec1 f (x :& xs) = foldRec f (Col x) xs++-- | Similar to 'Data.Monoid.First': find the first field that is not+-- 'Nothing'.+firstField :: FoldRec ts ts+ => Rec (Maybe :. f) ts -> Maybe (CoRec f ts)+firstField RNil = Nothing+firstField v@(x :& _) = corecTraverse getCompose $ foldRec aux (Col x) v+ where aux :: CoRec (Maybe :. f) (t ': ts)+ -> CoRec (Maybe :. f) (t ': ts)+ -> CoRec (Maybe :. f) (t ': ts)+ aux c@(Col (Compose (Just _))) _ = c+ aux _ c = c++-- | Similar to 'Data.Monoid.Last': find the last field that is not+-- 'Nothing'.+lastField :: FoldRec ts ts+ => Rec (Maybe :. f) ts -> Maybe (CoRec f ts)+lastField RNil = Nothing+lastField v@(x :& _) = corecTraverse getCompose $ foldRec aux (Col x) v+ where aux :: CoRec (Maybe :. f) (t ': ts)+ -> CoRec (Maybe :. f) (t ': ts)+ -> CoRec (Maybe :. f) (t ': ts)+ aux _ c@(Col (Compose (Just _))) = c+ aux c _ = c++-- | Apply a type class method on a 'CoRec'. The first argument is a+-- 'Proxy' value for a /list/ of 'Constraint' constructors. For+-- example, @onCoRec [pr|Num,Ord|] (> 20) r@. If only one constraint+-- is needed, use the @pr1@ quasiquoter.+onCoRec :: forall (cs :: [* -> Constraint]) f ts b.+ (AllHave cs ts, Functor f, RecApplicative ts)+ => Proxy cs+ -> (forall a. HasInstances a cs => a -> b)+ -> CoRec f ts -> f b+onCoRec p f (Col x) = fmap meth x+ where meth = runOp $+ rget Proxy (reifyDicts p (Op f) :: Rec (Op b) ts)++-- | Apply a type class method on a 'Field'. The first argument is a+-- 'Proxy' value for a /list/ of 'Constraint' constructors. For+-- example, @onCoRec [pr|Num,Ord|] (> 20) r@. If only one constraint+-- is needed, use the @pr1@ quasiquoter.+onField :: forall cs ts b.+ (AllHave cs ts, RecApplicative ts)+ => Proxy cs+ -> (forall a. HasInstances a cs => a -> b)+ -> Field ts -> b+onField p f x = getIdentity (onCoRec p f x)++-- | Build a record whose elements are derived solely from a+-- list of constraint constructors satisfied by each.+reifyDicts :: forall cs f proxy ts. (AllHave cs ts, RecApplicative ts)+ => proxy cs -> (forall a. HasInstances a cs => f a) -> Rec f ts+reifyDicts _ f = go (rpure Nothing)+ where go :: AllHave cs ts' => Rec Maybe ts' -> Rec f ts'+ go RNil = RNil+ go (_ :& xs) = f :& go xs++++-- * Extracting values from a CoRec/Pattern matching on a CoRec++-- | Given a proxy of type t and a 'CoRec Identity' that might be a t, try to+-- convert the CoRec to a t.+asA :: (t ∈ ts, RecApplicative ts) => proxy t -> CoRec Identity ts -> Maybe t+asA p c@(Col _) = rget p $ corecToRec' c+++-- | Pattern match on a CoRec by specifying handlers for each case. If the+-- CoRec is non-empty this function is total. Note that the order of the+-- Handlers has to match the type level list (t:ts).+--+-- >>> :{+-- let testCoRec = Col (Identity False) :: CoRec Identity [Int, String, Bool] in+-- match testCoRec $+-- (H $ \i -> "my Int is the successor of " ++ show (i - 1))+-- :& (H $ \s -> "my String is: " ++ s)+-- :& (H $ \b -> "my Bool is not: " ++ show (not b) ++ " thus it is " ++ show b)+-- :& RNil+-- :}+-- "my Bool is not: True thus it is False"+match :: RecApplicative (t ': ts)+ => CoRec Identity (t ': ts) -> Handlers (t ': ts) b -> b+match c hs = fromJust $ match' c hs+ -- Since we require 'ts' both for the Handlers and the CoRec, Handlers+ -- effectively defines a total function. Hence, we can safely use fromJust++-- | Pattern match on a CoRec by specifying handlers for each case. The only case+-- in which this can produce a Nothing is if the list ts is empty.+match' :: RecApplicative ts => CoRec Identity ts -> Handlers ts b -> Maybe b+match' c hs = match'' hs $ corecToRec' c+ where+ match'' :: Handlers ts b -> Rec Maybe ts -> Maybe b+ match'' RNil RNil = Nothing+ match'' (H f :& _) (Just x :& _) = Just $ f x+ match'' (H _ :& fs) (Nothing :& c) = match'' fs c+++-- | Newtype around functions for a to b+newtype Handler b a = H (a -> b)++-- | 'Handlers ts b', is essentially a list of functions, one for each type in+-- ts. All functions produce a value of type 'b'. Hence, 'Handlers ts b' would+-- represent something like the type-level list: [t -> b | t \in ts ]+type Handlers ts b = Rec (Handler b) ts
+ src/Frames/Col.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE DataKinds,+ GeneralizedNewtypeDeriving,+ KindSignatures,+ ScopedTypeVariables,+ TypeOperators #-}+-- | Column types+module Frames.Col where+import Data.Monoid+import Data.Proxy+import GHC.TypeLits++-- | A column's type includes a textual name and the data type of each+-- element.+newtype (:->) (s::Symbol) a = Col { getCol :: a }+ deriving (Eq,Ord,Num,Monoid,Real,RealFloat,RealFrac,Fractional,Floating)++instance forall s a. (KnownSymbol s, Show a) => Show (s :-> a) where+ show (Col x) = symbolVal (Proxy::Proxy s)++" :-> "++show x++-- | Used only for a show instance that parenthesizes the value.+newtype Col' s a = Col' (s :-> a)++-- | Helper for making a 'Col''+col' :: a -> Col' s a+col' = Col' . Col++instance (KnownSymbol s, Show a) => Show (Col' s a) where+ show (Col' c) = "(" ++ show c ++ ")"
+ src/Frames/ColumnTypeable.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE BangPatterns, DefaultSignatures, LambdaCase #-}+module Frames.ColumnTypeable where+import Control.Monad (MonadPlus)+import Data.Readable (Readable(fromText))+import qualified Data.Text as T+import Language.Haskell.TH++data Parsed a = Possibly a | Definitely a deriving (Eq, Ord, Show)++instance Functor Parsed where+ fmap f (Possibly x) = Possibly (f x)+ fmap f (Definitely x) = Definitely (f x)++-- | Values that can be read from a 'T.Text' with more or less+-- discrimination.+class Parseable a where+ -- | Returns 'Nothing' if a value of the given type can not be read;+ -- returns 'Just Possibly' if a value can be read, but is likely+ -- ambiguous (e.g. an empty string); returns 'Just Definitely' if a+ -- value can be read and is unlikely to be ambiguous."+ parse :: (Functor m, MonadPlus m) => T.Text -> m (Parsed a)+ default parse :: (Readable a, Functor m, MonadPlus m)+ => T.Text -> m (Parsed a)+ parse = fmap Definitely . fromText+ {-# INLINE parse #-}++-- | Discard any estimate of a parse's ambiguity.+discardConfidence :: Parsed a -> a+discardConfidence (Possibly x) = x+discardConfidence (Definitely x) = x++-- | Acts just like 'fromText': tries to parse a value from a 'T.Text'+-- and discards any estimate of the parse's ambiguity.+parse' :: (Functor m, MonadPlus m, Parseable a) => T.Text -> m a+parse' = fmap discardConfidence . parse++instance Parseable Bool where+instance Parseable Int where+instance Parseable Float where+instance Parseable Double where+instance Parseable T.Text where++-- | This class relates a universe of possible column types to Haskell+-- types, and provides a mechanism to infer which type best represents+-- some textual data.+class ColumnTypeable a where+ colType :: a -> Q Type+ inferType :: T.Text -> a
+ src/Frames/ColumnUniverse.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE BangPatterns,+ ConstraintKinds,+ DataKinds,+ FlexibleContexts,+ FlexibleInstances,+ GADTs,+ InstanceSigs,+ KindSignatures,+ LambdaCase,+ MultiParamTypeClasses,+ OverloadedStrings,+ QuasiQuotes,+ RankNTypes,+ ScopedTypeVariables,+ TemplateHaskell,+ TypeFamilies,+ TypeOperators,+ UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Frames.ColumnUniverse (CoRec, Columns, ColumnUniverse, CommonColumns) where+import Language.Haskell.TH+import Data.Monoid+import Data.Proxy+import qualified Data.Text as T+import Data.Typeable (Typeable, showsTypeRep, typeRep)+import Data.Vinyl+import Data.Vinyl.Functor+import Frames.CoRec+import Frames.ColumnTypeable+import Frames.RecF (reifyDict)+import Frames.TypeLevel (LAll)+import Data.Typeable (TypeRep)+import Data.Maybe (fromMaybe)++-- * TypeRep Helpers++-- | A 'TypeRep' tagged with the type it is associated with.+type Typed = Const TypeRep++mkTyped :: forall a. Typeable a => Typed a+mkTyped = Const (typeRep (Proxy::Proxy a))++quoteType :: TypeRep -> Q Type+quoteType x = do n <- lookupTypeName s+ case n of+ Just n' -> conT n'+ Nothing -> error $ "Type "++s++" isn't in scope"+ where s = showsTypeRep x ""++-- * Parseable Proxy++-- | Extract a function to test whether some value of a given type+-- could be read from some 'T.Text'.+inferParseable :: forall a. Parseable a+ => T.Text -> (Maybe :. (Parsed :. Proxy)) a+inferParseable = Compose+ . fmap (Compose . fmap (const Proxy))+ . (parse :: T.Text -> Maybe (Parsed a))++-- | Helper to call 'inferParseable' on variants of a 'CoRec'.+inferParseable' :: Parseable a+ => (((->) T.Text) :. (Maybe :. (Parsed :. Proxy))) a+inferParseable' = Compose inferParseable++-- * Record Helpers++tryParseAll :: forall ts. (RecApplicative ts, LAll Parseable ts)+ => T.Text -> Rec (Maybe :. (Parsed :. Proxy)) ts+tryParseAll = rtraverse getCompose funs+ where funs :: Rec (((->) T.Text) :. (Maybe :. (Parsed :. Proxy))) ts+ funs = reifyDict (Proxy::Proxy Parseable) inferParseable'++-- | Preserving the outermost two functor layers, replace each element with+-- its TypeRep.+elementTypes :: (Functor f, Functor g, LAll Typeable ts)+ => Rec (f :. (g :. h)) ts -> Rec (f :. (g :. Typed)) ts+elementTypes RNil = RNil+elementTypes (Compose x :& xs) =+ Compose (fmap (Compose . fmap (const mkTyped) . getCompose) x)+ :& elementTypes xs++-- * Column Type Inference++-- | Information necessary for synthesizing row types and comparing+-- types.+newtype ColInfo a = ColInfo (Q Type, Parsed (Typed a))++-- | We use a join semi-lattice on types for representations. The+-- bottom of the lattice is effectively an error (we have nothing to+-- represent), @Bool < Int@, @Int < Double@, and @forall n. n <= Text@.+lubTypeReps :: Parsed TypeRep -> Parsed TypeRep -> Maybe Ordering+lubTypeReps (Possibly _) (Definitely _) = Just LT+lubTypeReps (Definitely _) (Possibly _) = Just GT+lubTypeReps (Possibly trX) (Possibly trY)+ | trX == trY = Just EQ+ | otherwise = Nothing+lubTypeReps (Definitely trX) (Definitely trY)+ | trX == trY = Just EQ+ | trX == trInt && trY == trDbl = Just LT+ | trX == trDbl && trY == trInt = Just GT+ | trX == trBool && trY == trInt = Just LT+ | trX == trInt && trY == trBool = Just GT+ | otherwise = Nothing+ where trInt = typeRep (Proxy :: Proxy Int)+ trDbl = typeRep (Proxy :: Proxy Double)+ trBool = typeRep (Proxy :: Proxy Bool)++instance (T.Text ∈ ts) => Monoid (CoRec ColInfo ts) where+ mempty = Col (ColInfo ([t|T.Text|], Possibly mkTyped) :: ColInfo T.Text)+ mappend x@(Col (ColInfo (_, trX))) y@(Col (ColInfo (_, trY))) =+ case lubTypeReps (fmap getConst trX) (fmap getConst trY) of+ Just GT -> x+ Just LT -> y+ Just EQ -> x+ Nothing -> mempty++-- | Find the best (i.e. smallest) 'CoRec' variant to represent a+-- parsed value.+bestRep :: forall ts.+ (LAll Parseable ts, LAll Typeable ts, FoldRec ts ts,+ RecApplicative ts, T.Text ∈ ts)+ => T.Text -> CoRec ColInfo ts+bestRep = aux+ . fromMaybe (Col (Compose $ Possibly (mkTyped :: Typed T.Text)))+ . firstField+ . elementTypes+ . (tryParseAll :: T.Text -> Rec (Maybe :. (Parsed :. Proxy)) ts)+ where aux :: CoRec (Parsed :. Typed) ts -> CoRec ColInfo ts+ aux (Col (Compose d@(Possibly (Const tr)))) =+ Col (ColInfo (quoteType tr, d))+ aux (Col (Compose d@(Definitely (Const tr)))) =+ Col (ColInfo (quoteType tr, d))+{-# INLINABLE bestRep #-}++instance (LAll Parseable ts, LAll Typeable ts, FoldRec ts ts,+ RecApplicative ts, T.Text ∈ ts) =>+ ColumnTypeable (CoRec ColInfo ts) where+ colType (Col (ColInfo (t, _))) = t+ {-# INLINE colType #-}+ inferType = bestRep+ {-# INLINABLE inferType #-}++-- * Common Columns++-- | Common column types+type CommonColumns = [Bool, Int, Double, T.Text]++-- | Define a set of variants that captures all possible column types.+type ColumnUniverse = CoRec ColInfo++-- | A universe of common column variants.+type Columns = ColumnUniverse CommonColumns
+ src/Frames/Exploration.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE ConstraintKinds, FlexibleContexts, GADTs, TemplateHaskell,+ TypeOperators #-}++-- | Functions useful for interactively exploring and experimenting+-- with a data set.+module Frames.Exploration (pipePreview, select, lenses, recToList,+ pr, pr1) where+import Data.Char (isSpace, isUpper)+import Data.Proxy+import qualified Data.Vinyl as V+import Data.Vinyl.Functor (Identity(..))+import Frames.Rec+import Frames.RecF (AsVinyl(toVinyl), UnColumn)+import Frames.TypeLevel (AllAre)+import Language.Haskell.TH+import Language.Haskell.TH.Quote+import Pipes hiding (Proxy)+import qualified Pipes.Prelude as P++-- * Preview Results++-- | @preview src n f@ prints out the first @n@ results of piping+-- @src@ through @f@.+pipePreview :: (MonadIO m, Show b)+ => Producer a m () -> Int -> Pipe a b m () -> m ()+pipePreview src n f = runEffect $ src >-> f >-> P.take n >-> P.print++-- * Column Selection++-- | @select (Proxy::Proxy [A,B,C])@ extracts columns @A@, @B@, and+-- @C@, from a larger record. Note, this is just a way of pinning down+-- the type of a usage of 'V.rcast'.+select :: (fs V.⊆ rs) => proxy fs -> Record rs -> Record fs+select _ = V.rcast++-- | @lenses (Proxy::Proxy [A,B,C])@ provides a lens onto columns @A@,+-- @B@, and @C@. This is just a way of pinning down the type of+-- 'V.rsubset'.+lenses :: (fs V.⊆ rs, Functor f)+ => proxy fs -> (Record fs -> f (Record fs)) -> Record rs -> f (Record rs)+lenses _ = V.rsubset++-- * Proxy Syntax++-- | A proxy value quasiquoter. @[pr|T|]@ will splice an expression+-- @Proxy::Proxy T@, while @[pr|A,B,C|]@ will splice in a value of+-- @Proxy :: Proxy [A,B,C]@.+pr :: QuasiQuoter+pr = QuasiQuoter mkProxy undefined undefined undefined+ where mkProxy s = let ts = map strip $ splitOn ',' s+ cons = mapM (conT . mkName) ts+ mkList = foldr (AppT . AppT PromotedConsT) PromotedNilT+ in case ts of+ [h@(t:_)]+ | isUpper t -> [|Proxy::Proxy $(fmap head cons)|]+ | otherwise -> [|Proxy::Proxy $(varT $ mkName h)|]+ _ -> [|Proxy::Proxy $(fmap mkList cons)|]++-- | Like 'pr', but takes a single type, which is used to produce a+-- 'Proxy' for a single-element list containing only that type. This+-- is useful for passing a single type to a function that wants a list+-- of types.+pr1 :: QuasiQuoter+pr1 = QuasiQuoter mkProxy undefined undefined undefined+ where mkProxy s = let sing x = AppT (AppT PromotedConsT x) PromotedNilT+ in case s of+ t:_+ | isUpper t ->+ [|Proxy::Proxy $(fmap sing (conT (mkName s)))|]+ | otherwise ->+ [|Proxy::Proxy $(fmap sing (varT $ mkName s))|]+ _ -> error "Empty string passed to pr1"++-- * ToList++recToList :: (AsVinyl rs, AllAre a (UnColumn rs)) => Record rs -> [a]+recToList = go . toVinyl+ where go :: AllAre a rs => V.Rec Identity rs -> [a]+ go V.RNil = []+ go (Identity x V.:& xs) = x : go xs++-- * Helpers++-- | Split on a delimiter.+splitOn :: Eq a => a -> [a] -> [[a]]+splitOn d = go+ where go [] = []+ go xs = let (h,t) = break (== d) xs+ in case t of+ [] -> [h]+ (_:t') -> h : go t'++-- | Remove white space from both ends of a 'String'.+strip :: String -> String+strip = takeWhile (not . isSpace) . dropWhile isSpace
+ src/Frames/Frame.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE TypeOperators #-}+-- | A 'Frame' is a finite 'Int'-indexed collection of rows.+module Frames.Frame where+import Control.Applicative+import Data.Foldable+import Data.Monoid+import qualified Data.Vector as V+import Data.Vinyl.TypeLevel+import Frames.Rec (Record)+import Frames.RecF (rappend)++-- | A 'Frame' is a finite collection of rows indexed by 'Int'.+data Frame r = Frame { frameLength :: !Int+ , frameRow :: Int -> r }++-- | A 'Frame' whose rows are 'Record' values.+type FrameRec rs = Frame (Record rs)++instance Functor Frame where+ fmap f (Frame len g) = Frame len (f . g)++-- | Build a 'Frame' from any 'Foldable'. This simply uses a boxed+-- 'V.Vector' to hold each row. If you have a collection of 'Record's,+-- consider using 'Frames.InCore.toFrame'.+boxedFrame :: Foldable f => f r -> Frame r+boxedFrame xs = Frame (V.length v) (v V.!)+ where v = V.fromList (toList xs)++-- | The 'Monoid' instance for 'Frame' provides a mechanism for+-- vertical concatenation of 'Frame's. That is, @f1 <> f2@ will return+-- a new 'Frame' with the rows of @f1@ followed by the rows of @f2@.+instance Monoid (Frame r) where+ mempty = Frame 0 (const $ error "index out of bounds (empty frame)")+ Frame l1 f1 `mappend` Frame l2 f2 = Frame (l1+l2) $ \i ->+ if i < l1 then f1 i else f2 i++instance Foldable Frame where+ foldMap f (Frame n row) = foldMap (f . row) [0..n-1]+ {-# INLINE foldMap #-}+ foldl' f z (Frame n row) = foldl' ((. row) . f) z [0..n-1]+ {-# INLINE foldl' #-}++instance Applicative Frame where+ -- | A frame of 'maxBound' rows, each of which is the given value.+ pure x = Frame maxBound (const x)+ -- | Zips two 'Frame's together, applying the rows of the first to+ -- those of the second. The result has as many rows as the smaller+ -- of the two argument 'Frame's.+ Frame l1 f1 <*> Frame l2 f2 = Frame (min l1 l2) $ ($) <$> f1 <*> f2++instance Monad Frame where+ -- | A frame of 'maxBound' rows, each of which is the given value.+ return = pure+ -- | Like 'concatMap' for lists.+ Frame l f >>= fb = foldMap (fb . f) [0 .. l - 1]++-- | Horizontal 'Frame' concatenation. That is, @zipFrames f1 f2@ will+-- return a 'Frame' with as many rows as the smaller of @f1@ and @f2@+-- whose rows are the result of appending the columns of @f2@ to those+-- of @f1@.+zipFrames :: FrameRec rs -> FrameRec rs' -> FrameRec (rs ++ rs')+zipFrames (Frame l1 f1) (Frame l2 f2) =+ Frame (min l1 l2) $ rappend <$> f1 <*> f2
+ src/Frames/InCore.hs view
@@ -0,0 +1,217 @@+{-# LANGUAGE BangPatterns,+ DataKinds,+ EmptyCase,+ FlexibleInstances,+ ScopedTypeVariables,+ TupleSections,+ TypeFamilies,+ TypeOperators,+ UndecidableInstances #-}+-- | Efficient in-memory (in-core) storage of tabular data.+module Frames.InCore where+import Control.Applicative+import Control.Monad.Primitive+import Control.Monad.ST (runST)+import Data.Proxy+import Data.Text (Text)+import qualified Data.Vector as VB+import qualified Data.Vector.Generic as VG+import qualified Data.Vector.Generic.Mutable as VGM+import qualified Data.Vector.Unboxed as VU+import qualified Data.Vinyl as V+import Data.Vinyl.Functor (Identity(..))+import Frames.Col+import Frames.Frame+import Frames.Rec+import Frames.RecF+import GHC.Prim (RealWorld)+import qualified Pipes as P+import qualified Pipes.Prelude as P++-- | The most efficient vector type for each column data type.+type family VectorFor t :: * -> *+type instance VectorFor Bool = VU.Vector+type instance VectorFor Int = VU.Vector+type instance VectorFor Float = VU.Vector+type instance VectorFor Double = VU.Vector+type instance VectorFor String = VB.Vector+type instance VectorFor Text = VB.Vector++-- | The mutable version of 'VectorFor' a particular type.+type VectorMFor a = VG.Mutable (VectorFor a)++-- | Since we stream into the in-memory representation, we use an+-- exponential growth strategy to resize arrays as more data is read+-- in. This is the initial capacity of each column.+initialCapacity :: Int+initialCapacity = 128++-- | Mutable vector types for each column in a row.+type family VectorMs m rs where+ VectorMs m '[] = '[]+ VectorMs m (s :-> a ': rs) =+ s :-> VectorMFor a (PrimState m) a ': VectorMs m rs++-- | Immutable vector types for each column in a row.+type family Vectors rs where+ Vectors '[] = '[]+ Vectors (s :-> a ': rs) = s :-> VectorFor a a ': Vectors rs++-- | Tooling to allocate, grow, write to, freeze, and index into+-- records of vectors.+class RecVec rs where+ allocRec :: (Applicative m, PrimMonad m)+ => proxy rs -> m (Record (VectorMs m rs))+ freezeRec :: (Applicative m, PrimMonad m)+ => proxy rs -> Int -> Record (VectorMs m rs)+ -> m (Record (Vectors rs))+ growRec :: (Applicative m, PrimMonad m)+ => proxy rs -> Record (VectorMs m rs) -> m (Record (VectorMs m rs))+ writeRec :: PrimMonad m+ => proxy rs -> Int -> Record (VectorMs m rs) -> Record rs -> m ()+ indexRec :: proxy rs -> Int -> Record (Vectors rs) -> Record rs+ produceRec :: proxy rs -> Record (Vectors rs) -> V.Rec ((->) Int) rs++-- The use of the type families Vectors and VectorMs interferes with+-- GHC's pattern match exhaustiveness checker, so we write down dummy+-- cases to avoid warnings. This is probably a GHC bug as writing the+-- apparently missing pattern match causes a type checker error!++instance RecVec '[] where+ allocRec _ = return Nil+ {-# INLINE allocRec #-}++ freezeRec _ _ V.RNil = return V.RNil+ freezeRec _ _ x = case x of+ {-# INLINE freezeRec #-}++ growRec _ V.RNil = return V.RNil+ growRec _ x = case x of+ {-# INLINE growRec #-}++ indexRec _ _ _ = V.RNil+ {-# INLINE indexRec #-}++ writeRec _ _ V.RNil V.RNil = return ()+ writeRec _ _ x _ = case x of+ {-# INLINE writeRec #-}++ produceRec _ V.RNil = V.RNil+ produceRec _ x = case x of+ {-# INLINE produceRec #-}++instance forall s a rs.+ (VGM.MVector (VectorMFor a) a,+ VG.Mutable (VectorFor a) ~ VectorMFor a,+ VG.Vector (VectorFor a) a,+ RecVec rs)+ => RecVec (s :-> a ': rs) where+ allocRec _ = (&:) <$> VGM.new initialCapacity <*> allocRec (Proxy::Proxy rs)+ {-# INLINE allocRec #-}++ freezeRec _ n (Identity (Col x) V.:& xs) =+ (&:) <$> (VG.unsafeFreeze $ VGM.unsafeSlice 0 n x)+ <*> freezeRec (Proxy::Proxy rs) n xs+ freezeRec _ _ x = case x of+ {-# INLINE freezeRec #-}++ growRec _ (Identity (Col x) V.:& xs) = (&:) <$> VGM.grow x (VGM.length x)+ <*> growRec (Proxy :: Proxy rs) xs+ growRec _ x = case x of+ {-# INLINE growRec #-}++ writeRec _ !i !(Identity (Col v) V.:& vs) (Identity (Col x) V.:& xs) =+ VGM.unsafeWrite v i x >> writeRec (Proxy::Proxy rs) i vs xs+ writeRec _ _ _ x = case x of+ {-# INLINE writeRec #-}++ indexRec _ !i !(Identity (Col x) V.:& xs) =+ x VG.! i &: indexRec (Proxy :: Proxy rs) i xs+ indexRec _ _ x = case x of+ {-# INLINE indexRec #-}++ produceRec _ (Identity (Col v) V.:& vs) = frameCons (v VG.!) $+ produceRec (Proxy::Proxy rs) vs+ produceRec _ x = case x of+ {-# INLINE produceRec #-}++-- | Stream a finite sequence of rows into an efficient in-memory+-- representation for further manipulation. Each column of the input+-- table will be stored optimally based on its type, making use of the+-- resulting generators a matter of indexing into a densely packed+-- representation. Returns the number of rows and a record of column+-- indexing functions. See 'toAoS' to convert the result to a 'Frame'+-- which provides an easier-to-use function that indexes into the+-- table in a row-major fashion.+inCoreSoA :: forall m rs. (Applicative m, PrimMonad m, RecVec rs)+ => P.Producer (Record rs) m () -> m (Int, V.Rec ((->) Int) rs)+inCoreSoA xs =+ do mvs <- allocRec (Proxy :: Proxy rs)+ let feed (!i, !sz, !mvs') row+ | i == sz = growRec (Proxy::Proxy rs) mvs'+ >>= flip feed row . (i, sz*2,)+ | otherwise = do writeRec (Proxy::Proxy rs) i mvs' row+ return (i+1, sz, mvs')+ fin (n,_,mvs') =+ do vs <- freezeRec (Proxy::Proxy rs) n mvs'+ return . (n,) $ produceRec (Proxy::Proxy rs) vs+ P.foldM feed (return (0,initialCapacity,mvs)) fin xs+{-# INLINE inCoreSoA #-}++-- | Stream a finite sequence of rows into an efficient in-memory+-- representation for further manipulation. Each column of the input+-- table will be stored optimally based on its type, making use of the+-- resulting generators a matter of indexing into a densely packed+-- representation. Returns a 'Frame' that provides a function to index+-- into the table.+inCoreAoS :: (Applicative m, PrimMonad m, RecVec rs)+ => P.Producer (Record rs) m () -> m (FrameRec rs)+inCoreAoS = fmap (uncurry toAoS) . inCoreSoA++-- | Like 'inCoreAoS', but applies the provided function to the record+-- of columns before building the 'Frame'.+inCoreAoS' :: (Applicative m, PrimMonad m, RecVec rs)+ => (V.Rec ((->) Int) rs -> V.Rec ((->) Int) ss)+ -> P.Producer (Record rs) m () -> m (FrameRec ss)+inCoreAoS' f = fmap (uncurry toAoS . aux) . inCoreSoA+ where aux (x,y) = (x, f y)++-- | Convert a structure-of-arrays to an array-of-structures. This can+-- simplify usage of an in-memory representation.+toAoS :: Int -> V.Rec ((->) Int) rs -> FrameRec rs+toAoS n = Frame n . rtraverse (fmap Identity)+{-# INLINE toAoS #-}++-- | Stream a finite sequence of rows into an efficient in-memory+-- representation for further manipulation. Each column of the input+-- table will be stored optimally based on its type, making use of the+-- resulting generator a matter of indexing into a densely packed+-- representation.+inCore :: forall m n rs. (Applicative m, PrimMonad m, RecVec rs, Monad n)+ => P.Producer (Record rs) m () -> m (P.Producer (Record rs) n ())+inCore xs =+ do mvs <- allocRec (Proxy :: Proxy rs)+ let feed (!i,!sz,!mvs') row+ | i == sz = growRec (Proxy::Proxy rs) mvs'+ >>= flip feed row . (i, sz*2,)+ | otherwise = do writeRec (Proxy::Proxy rs) i mvs' row+ return (i+1, sz, mvs')+ fin (n,_,mvs') =+ do vs <- freezeRec (Proxy::Proxy rs) n mvs'+ let spool !i+ | i == n = pure ()+ | otherwise = P.yield (indexRec Proxy i vs) >> spool (i+1)+ return $ spool 0+ P.foldM feed (return (0,initialCapacity,mvs)) fin xs+{-# INLINE inCore #-}++-- | Build a 'Frame' from a collection of 'Record's using efficient+-- column-based storage.+toFrame :: (P.Foldable f, RecVec rs) => f (Record rs) -> Frame (Record rs)+toFrame xs = runST $ inCoreAoS (P.each xs)+{-# INLINE toFrame #-}++-- | Keep only those rows of a 'FrameRec' that satisfy a predicate.+filterFrame :: RecVec rs => (Record rs -> Bool) -> FrameRec rs -> FrameRec rs+filterFrame p f = runST $ inCoreAoS $ P.each f P.>-> P.filter p+{-# INLINE filterFrame #-}
+ src/Frames/Melt.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, FlexibleInstances,+ KindSignatures, MultiParamTypeClasses, PolyKinds,+ ScopedTypeVariables, TypeFamilies, TypeOperators,+ UndecidableInstances #-}+module Frames.Melt where+import Data.Proxy+import Data.Vinyl+import Data.Vinyl.Functor (Identity(..))+import Data.Vinyl.TypeLevel+import Frames.Col+import Frames.CoRec (CoRec)+import qualified Frames.CoRec as C+import Frames.Frame (Frame(..), FrameRec)+import Frames.Rec+import Frames.RecF (ColumnHeaders(..), frameCons)+import Frames.TypeLevel++type family Elem t ts :: Bool where+ Elem t '[] = 'False+ Elem t (t ': ts) = 'True+ Elem t (s ': ts) = Elem t ts++type family Or (a :: Bool) (b :: Bool) :: Bool where+ Or 'True b = 'True+ Or a b = b++type family Not a :: Bool where+ Not 'True = 'False+ Not 'False = 'True++type family Disjoint ss ts :: Bool where+ Disjoint '[] ts = 'True+ Disjoint (s ': ss) ts = Or (Not (Elem s ts)) (Disjoint ss ts)++type ElemOf ts r = RElem r ts (RIndex r ts)++class RowToColumn ts rs where+ rowToColumnAux :: Proxy ts -> Rec f rs -> [CoRec f ts]++instance RowToColumn ts '[] where+ rowToColumnAux _ _ = []++instance (r ∈ ts, RowToColumn ts rs) => RowToColumn ts (r ': rs) where+ rowToColumnAux p (x :& xs) = C.Col x : rowToColumnAux p xs++-- | Transform a record into a list of its fields, retaining proof+-- that each field is part of the whole.+rowToColumn :: RowToColumn ts ts => Rec f ts -> [CoRec f ts]+rowToColumn = rowToColumnAux Proxy++meltAux :: forall vs ss ts.+ (vs ⊆ ts, ss ⊆ ts, Disjoint ss ts ~ 'True, ts ≅ (vs ++ ss),+ ColumnHeaders vs, RowToColumn vs vs)+ => Record ts+ -> [Record ("value" :-> CoRec Identity vs ': ss)]+meltAux r = map (\val -> frameCons (Identity val) ids) (rowToColumn vals)+ where ids = rcast r :: Record ss+ vals = rcast r :: Record vs++type family RDeleteAll ss ts where+ RDeleteAll '[] ts = ts+ RDeleteAll (s ': ss) ts = RDeleteAll ss (RDelete s ts)++-- | This is 'melt', but the variables are at the front of the record,+-- which reads a bit odd.+meltRow' :: forall proxy vs ts ss. (vs ⊆ ts, ss ⊆ ts, vs ~ RDeleteAll ss ts,+ Disjoint ss ts ~ 'True, ts ≅ (vs ++ ss),+ ColumnHeaders vs, RowToColumn vs vs)+ => proxy ss+ -> Record ts+ -> [Record ("value" :-> CoRec Identity vs ': ss)]+meltRow' _ = meltAux++-- | Turn a cons into a snoc after the fact.+retroSnoc :: forall t ts. Record (t ': ts) -> Record (ts ++ '[t])+retroSnoc (x :& xs) = go xs+ where go :: Record ss -> Record (ss ++ '[t])+ go RNil = x :& RNil+ go (y :& ys) = y :& go ys++-- | Like @melt@ in the @reshape2@ package for the @R@ language. It+-- stacks multiple columns into a single column over multiple+-- rows. Takes a specification of the id columns that remain+-- unchanged. The remaining columns will be stacked.+--+-- Suppose we have a record, @r :: Record [Name,Age,Weight]@. If we+-- apply @melt [pr1|Name|] r@, we get two values with type @Record+-- [Name, "value" :-> CoRec Identity [Age,Weight]]@. The first will+-- contain @Age@ in the @value@ column, and the second will contain+-- @Weight@ in the @value@ column.+meltRow :: (vs ⊆ ts, ss ⊆ ts, vs ~ RDeleteAll ss ts,+ Disjoint ss ts ~ 'True, ts ≅ (vs ++ ss),+ ColumnHeaders vs, RowToColumn vs vs)+ => proxy ss+ -> Record ts+ -> [Record (ss ++ '["value" :-> CoRec Identity vs])]+meltRow = (map retroSnoc .) . meltRow'++class HasLength (ts :: [k]) where+ hasLength :: proxy ts -> Int++instance HasLength '[] where hasLength _ = 0+instance forall t ts. HasLength ts => HasLength (t ': ts) where+ hasLength _ = 1 + hasLength (Proxy :: Proxy ts)++-- | Applies 'meltRow' to each row of a 'FrameRec'.+melt :: forall vs ts ss proxy.+ (vs ⊆ ts, ss ⊆ ts, vs ~ RDeleteAll ss ts, HasLength vs,+ Disjoint ss ts ~ 'True, ts ≅ (vs ++ ss), + ColumnHeaders vs, RowToColumn vs vs)+ => proxy ss+ -> FrameRec ts+ -> FrameRec (ss ++ '["value" :-> CoRec Identity vs])+melt p (Frame n v) = Frame (n*numVs) go+ where numVs = hasLength (Proxy :: Proxy vs)+ go i = let (j,k) = i `quotRem` numVs+ in meltRow p (v j) !! k
+ src/Frames/Rec.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE ConstraintKinds,+ DataKinds,+ EmptyCase,+ FlexibleContexts,+ FlexibleInstances,+ FunctionalDependencies,+ KindSignatures,+ GADTs,+ MultiParamTypeClasses,+ PatternSynonyms,+ PolyKinds,+ ScopedTypeVariables,+ TypeFamilies,+ TypeOperators,+ UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Frames.Rec where+import Data.Proxy+import Data.Vinyl (recordToList, rmap, reifyConstraint, Dict(..), Rec)+import Data.Vinyl.TypeLevel (RecAll)+import Data.Vinyl.Functor (Identity(..), Const(..), Compose(..), (:.))+import Frames.Col+import Frames.RecF++-- | A record with unadorned values.+type Record = Rec Identity++-- | A @cons@ function for building 'Record' values.+(&:) :: a -> Record rs -> Record (s :-> a ': rs)+x &: xs = frameCons (Identity x) xs+infixr 5 &:++-- | Separate the first element of a 'Record' from the rest of the row.+recUncons :: Record (s :-> a ': rs) -> (a, Record rs)+recUncons (Identity x :& xs) = (x, xs)+recUncons x = case x of++-- | Undistribute 'Maybe' from a 'Rec' 'Maybe'. This is just a+-- specific usage of 'rtraverse', but it is quite common.+recMaybe :: Rec Maybe cs -> Maybe (Record cs)+recMaybe = rtraverse (fmap Identity)+{-# INLINE recMaybe #-}++-- | Show each field of a 'Record' /without/ its column name.+showFields :: (RecAll Identity (UnColumn ts) Show, AsVinyl ts)+ => Record ts -> [String]+showFields = recordToList . rmap aux . reifyConstraint p . toVinyl+ where p = Proxy :: Proxy Show+ aux :: (Dict Show :. Identity) a -> Const String a+ aux (Compose (Dict x)) = Const (show x)+{-# INLINABLE showFields #-}
+ src/Frames/RecF.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE ConstraintKinds,+ DataKinds,+ FlexibleContexts,+ FlexibleInstances,+ GADTs,+ KindSignatures,+ MultiParamTypeClasses,+ PatternSynonyms,+ RankNTypes,+ ScopedTypeVariables,+ TypeFamilies,+ TypeOperators,+ ViewPatterns #-}+module Frames.RecF (V.rappend, V.rtraverse, rdel, CanDelete,+ frameCons, pattern (:&), pattern Nil, AllCols,+ UnColumn, AsVinyl(..), mapMono, mapMethod,+ ShowRec, showRec, ColFun, ColumnHeaders, + columnHeaders, reifyDict) where+import Control.Applicative ((<$>))+import Data.List (intercalate)+import Data.Proxy+import qualified Data.Vinyl as V+import Data.Vinyl (Rec(RNil), RecApplicative(rpure))+import Data.Vinyl.Functor (Identity)+import Data.Vinyl.TypeLevel+import Frames.Col+import Frames.TypeLevel+import GHC.TypeLits (KnownSymbol, symbolVal)++-- | Add a column to the head of a row.+frameCons :: Functor f => f a -> V.Rec f rs -> V.Rec f (s :-> a ': rs)+frameCons = (V.:&) . fmap Col+{-# INLINE frameCons #-}++-- | Separate the first element of a row from the rest of the row.+frameUncons :: Functor f => V.Rec f (s :-> r ': rs) -> (f r, V.Rec f rs)+frameUncons (x V.:& xs) = (fmap getCol x, xs)+{-# INLINE frameUncons #-}++pattern Nil = V.RNil+pattern x :& xs <- (frameUncons -> (x, xs))++-- NOTE: A bidirectional pattern synonym would be great, but we'll+-- have to wait for GHC 7.10 to gain wide acceptance before depending+-- upon its availability.++class ColumnHeaders (cs::[*]) where+ -- | Return the column names for a record.+ columnHeaders :: proxy (Rec f cs) -> [String]++instance ColumnHeaders '[] where+ columnHeaders _ = []++instance forall cs s c. (ColumnHeaders cs, KnownSymbol s)+ => ColumnHeaders (s :-> c ': cs) where+ columnHeaders _ = symbolVal (Proxy::Proxy s) : columnHeaders (Proxy::Proxy (Rec f cs))++-- | A type function to convert a 'Record' to a 'Rec'. @ColFun f (Rec+-- rs) = Rec f rs@.+type family ColFun f x where+ ColFun f (Rec Identity rs) = Rec f rs++-- | Strip the column information from each element of a list of+-- types.+type family UnColumn ts where+ UnColumn '[] = '[]+ UnColumn ((s :-> t) ': ts) = t ': UnColumn ts++-- | Enforce a constraint on the payload type of each column.+type AllCols c ts = LAll c (UnColumn ts)++-- | Remove the column name phantom types from a record, leaving you+-- with an unadorned Vinyl 'V.Rec'.+class AsVinyl ts where+ toVinyl :: Functor f => Rec f ts -> V.Rec f (UnColumn ts)+ fromVinyl :: Functor f => V.Rec f (UnColumn ts) -> Rec f ts++instance AsVinyl '[] where+ toVinyl _ = V.RNil+ fromVinyl _ = V.RNil++instance AsVinyl ts => AsVinyl (s :-> t ': ts) where+ toVinyl (x V.:& xs) = fmap getCol x V.:& toVinyl xs+ fromVinyl (x V.:& xs) = fmap Col x V.:& fromVinyl xs+ fromVinyl _ = error "GHC coverage checker isn't great"++-- | Map a function across a homogeneous, monomorphic 'V.Rec'.+mapMonoV :: (Functor f, AllAre a ts) => (a -> a) -> V.Rec f ts -> V.Rec f ts+mapMonoV _ V.RNil = V.RNil+mapMonoV f (x V.:& xs) = fmap f x V.:& mapMonoV f xs++-- | Map a function across a homogeneous, monomorphic 'Rec'.+mapMono :: (AllAre a (UnColumn ts), Functor f, AsVinyl ts)+ => (a -> a) -> Rec f ts -> Rec f ts+mapMono f = fromVinyl . mapMonoV f . toVinyl++-- | Map a typeclass method across a 'V.Rec' each of whose fields+-- have instances of the typeclass.+mapMethodV :: forall c f ts. (Functor f, LAll c ts)+ => Proxy c -> (forall a. c a => a -> a) -> V.Rec f ts -> V.Rec f ts+mapMethodV _ f = go+ where go :: LAll c ts' => V.Rec f ts' -> V.Rec f ts'+ go V.RNil = V.RNil+ go (x V.:& xs) = fmap f x V.:& go xs++-- | Map a typeclass method across a 'Rec' each of whose fields+-- has an instance of the typeclass.+mapMethod :: forall f c ts. (Functor f, LAll c (UnColumn ts), AsVinyl ts)+ => Proxy c -> (forall a. c a => a -> a) -> Rec f ts -> Rec f ts+mapMethod p f = fromVinyl . mapMethodV p f . toVinyl++-- | A constraint that a field can be deleted from a record.+type CanDelete r rs = (V.RElem r rs (RIndex r rs), RDelete r rs V.⊆ rs)++-- | Delete a field from a record+rdel :: CanDelete r rs => proxy r -> Rec f rs -> Rec f (RDelete r rs)+rdel _ = V.rcast++-- | The ability to pretty print a 'Rec''s fields.+class Functor f => ShowRec f rs where+ showRec' :: Rec f rs -> [String]++instance Functor f => ShowRec f '[] where+ showRec' _ = []++instance forall s f a rs. (KnownSymbol s, Show (f (Col' s a)), ShowRec f rs)+ => ShowRec f (s :-> a ': rs) where+ showRec' (x :& xs) = show (col' <$> x :: f (Col' s a)) : showRec' xs+ showRec' _ = error "GHC coverage error"++-- | Pretty printing of 'Rec' values.+showRec :: ShowRec f rs => Rec f rs -> String+showRec r = "{" ++ intercalate ", " (showRec' r) ++ "}"++-- | Build a record whose elements are derived solely from a+-- constraint satisfied by each.+reifyDict :: forall c f proxy ts. (LAll c ts, RecApplicative ts)+ => proxy c -> (forall a. c a => f a) -> Rec f ts+reifyDict _ f = go (rpure Nothing)+ where go :: LAll c ts' => Rec Maybe ts' -> Rec f ts'+ go RNil = RNil+ go (_ V.:& xs) = f V.:& go xs
+ src/Frames/RecLens.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE ConstraintKinds,+ DataKinds,+ FlexibleContexts,+ FlexibleInstances,+ MultiParamTypeClasses,+ RankNTypes,+ ScopedTypeVariables,+ TypeFamilies,+ TypeOperators #-}+-- | Lens utilities for working with 'Record's.+module Frames.RecLens where+import Control.Applicative+import qualified Data.Vinyl as V+import Data.Vinyl.Functor (Identity(..))+import Data.Vinyl.TypeLevel+import Frames.Col ((:->)(..))+import Frames.Rec (Record)++rlens' :: (i ~ RIndex r rs, V.RElem r rs i, Functor f, Functor g)+ => sing r+ -> (g r -> f (g r))+ -> V.Rec g rs+ -> f (V.Rec g rs)+rlens' = V.rlens+{-# INLINE rlens' #-}++-- | Getter for a 'V.Rec' field+rget' :: Functor g+ => (forall f. Functor f+ => (g (s :-> a) -> f (g (s :-> a))) -> V.Rec g rs -> f (V.Rec g rs))+ -> V.Rec g rs -> g a+rget' l = fmap getCol . getConst . l Const+{-# INLINE rget' #-}++-- | Setter for a 'V.Rec' field.+rput' :: Functor g+ => (forall f. Functor f+ => (g (s :-> a) -> f (g (s :-> a))) -> V.Rec g rs -> f (V.Rec g rs))+ -> g a -> V.Rec g rs -> V.Rec g rs+rput' l y = getIdentity . l (\_ -> Identity (fmap Col y))+{-# INLINE rput' #-}++-- * Plain records++-- | Create a lens for accessing a field of a 'Record'.+rlens :: (Functor f, V.RElem (s :-> a) rs (RIndex (s :-> a) rs))+ => proxy (s :-> a) -> (a -> f a) -> Record rs -> f (Record rs)+rlens k f = rlens' k (fmap Identity . getIdentity . fmap f')+ where f' (Col x) = fmap Col (f x)+{-# INLINE rlens #-}++-- | Getter for a 'Record' field.+rget :: (forall f. Functor f => (a -> f a) -> Record rs -> f (Record rs))+ -> Record rs -> a+rget l = getConst . l Const+{-# INLINE rget #-}++-- | Setter for a 'Record' field.+rput :: (forall f. Functor f => (a -> f a) -> Record rs -> f (Record rs))+ -> a -> Record rs -> Record rs+rput l y = getIdentity . l (\_ -> Identity y)+{-# INLINE rput #-}
+ src/Frames/TypeLevel.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE DataKinds, TypeFamilies, TypeOperators #-}+-- | Helpers for working with type-level lists.+module Frames.TypeLevel where+import GHC.Prim (Constraint)++-- | Remove the first occurence of a type from a type-level list.+type family RDelete r rs where+ RDelete r (r ': rs) = rs+ RDelete r (s ': rs) = s ': RDelete r rs++-- | A constraint on each element of a type-level list.+type family LAll c ts :: Constraint where+ LAll c '[] = ()+ LAll c (t ': ts) = (c t, LAll c ts)++-- | Constraint that every element of a promoted list is equal to a+-- particular type. That is, the list of types is a single type+-- repeated some number of times.+type family AllAre a ts :: Constraint where+ AllAre a '[] = ()+ AllAre a (t ': ts) = (t ~ a, AllAre a ts)++-- | Compound constraint that a type has an instance for each of a+-- list of type classes.+type family HasInstances a cs :: Constraint where+ HasInstances a '[] = ()+ HasInstances a (c ': cs) = (c a, HasInstances a cs)++-- | Compound constraint that all types have instances for each of a+-- list of type clasesses. @AllHave classes types@.+type family AllHave cs as :: Constraint where+ AllHave cs '[] = ()+ AllHave cs (a ': as) = (HasInstances a cs, AllHave cs as)+