Palisade.hs

module Spreadsheet.Palisade (
   FiveNumberSummary(..),
   summary5Names,
   summary5Number,

   T(..),
   summarySum5,
   summary5String,
   colNoSum,
   colSum5,
   colSum,
   right,
   pair,
   triple,
   maybe,
   mapHeaders,
   ) where

import qualified Spreadsheet.Formula as CalcForm
import Spreadsheet.Formula (CellTracked, trackedNumber)
import Spreadsheet.Row
         (Fraction, Precision, FieldTracked,
          emptyField, fractionField, fracFieldFromTracked)

import qualified Quantile

import Control.Applicative (Applicative, pure, liftA2, (<*>))

import qualified Data.Foldable as Fold
import qualified Data.NonEmpty as NonEmpty
import Data.Tuple.HT (mapPair, mapTriple, mapFst)
import Data.Maybe (catMaybes)
import Data.Monoid ((<>))

import qualified Algebra.RealRing as Real
import qualified Algebra.Field as Field
import NumericPrelude.Numeric
import NumericPrelude.Base hiding (maybe)

import qualified Prelude as P



data FiveNumberSummary a =
   FiveNumberSummary {
      summaryMinimum, summaryQuartile1, summaryMedian,
      summaryQuartile3, summaryMaximum :: a
   }

percentages :: (Field.C a) => FiveNumberSummary a
percentages =
   fmap (\k -> fromInteger k / fromInteger 4) $
   FiveNumberSummary {
      summaryMinimum = 0,
      summaryQuartile1 = 1,
      summaryMedian = 2,
      summaryQuartile3 = 3,
      summaryMaximum = 4
   }

quartileAggs :: FiveNumberSummary CalcForm.Agg
quartileAggs =
   FiveNumberSummary {
      summaryMinimum = CalcForm.Minimum,
      summaryQuartile1 = CalcForm.Quartile 1,
      summaryMedian = CalcForm.Median,
      summaryQuartile3 = CalcForm.Quartile 3,
      summaryMaximum = CalcForm.Maximum
   }

summary5 ::
   (Field.C a, Real.C a) =>
   NonEmpty.T [] (CellTracked a) ->
   FiveNumberSummary (CalcForm.FormulaTracked a)
summary5 xs =
   liftA2
      (\op k -> CalcForm.aggregate op (flip Quantile.discrete k) xs)
      quartileAggs percentages

summary5Number ::
   (Field.C a, Real.C a) => NonEmpty.T [] a -> FiveNumberSummary a
summary5Number xs =
   fmap (Quantile.discrete xs) percentages

summary5Names :: FiveNumberSummary String
summary5Names =
   FiveNumberSummary {
      summaryMinimum = "Minimum",
      summaryQuartile1 = "Quartile 1",
      summaryMedian = "Median",
      summaryQuartile3 = "Quartile 3",
      summaryMaximum = "Maximum"
   }


instance Functor FiveNumberSummary where
   fmap f (FiveNumberSummary q0 q1 q2 q3 q4) =
      FiveNumberSummary (f q0) (f q1) (f q2) (f q3) (f q4)

instance Applicative FiveNumberSummary where
   pure q = FiveNumberSummary q q q q q
   FiveNumberSummary p0 p1 p2 p3 p4 <*> FiveNumberSummary q0 q1 q2 q3 q4 =
      FiveNumberSummary (p0 q0) (p1 q1) (p2 q2) (p3 q3) (p4 q4)

instance Fold.Foldable FiveNumberSummary where
   foldMap f (FiveNumberSummary q0 q1 q2 q3 q4) =
      f q0 <> f q1 <> f q2 <> f q3 <> f q4



{- |
The 'T' type ensures that aggregations match the column headers.
Unfortunately, they do not assert that the aggregation values
are positioned below the aggregated data.
So far I have not found a way to achieve that.
It would certainly mean to give up the M monad.

For more clarity we could replace
the list types by two type constructor variables,
one for vertical and one for horizontal lists.
-}
data T a b =
   Cons {
      header :: [(String,Bool)],
      aggregator :: Aggregator a,
      selector :: a -> b,
      selectedSummary5 :: [b] -> [FiveNumberSummary FieldTracked]
   }

mapHeaders :: (String -> String) -> T a b -> T a b
mapHeaders f pal =
   pal{header = map (mapFst f) $ header pal}

type Aggregator a = [a] -> [(FiveNumberSummary FieldTracked, FieldTracked)]

aggSummary5 ::
   (Fraction a, Real.C a) =>
   Precision -> [CellTracked a] -> FiveNumberSummary FieldTracked
aggSummary5 prec =
   P.maybe (pure emptyField) (fmap (fracFieldFromTracked prec) . summary5) .
   NonEmpty.fetch

summarySum :: (Fraction a, Real.C a) => Precision -> Aggregator (CellTracked a)
summarySum prec cells =
   [(aggSummary5 prec cells, fracFieldFromTracked prec $ CalcForm.sum cells)]

summarySum5 :: (Fraction a, Real.C a) => Precision -> Aggregator (CellTracked a)
summarySum5 prec cells = [(aggSummary5 prec cells, emptyField)]


colNoSum :: String -> T () ()
colNoSum name =
   Cons [(name,False)] (const [(pure emptyField, emptyField)]) id (const [])


summary5String ::
   (Fraction a, Real.C a) =>
   Precision -> [a] -> [FiveNumberSummary FieldTracked]
summary5String prec =
   (:[]) .
   P.maybe (pure emptyField) (fmap (fractionField prec) . summary5Number) .
   NonEmpty.fetch

{-
The Precision given here should be the same as the one
given to the corresponding Row.putFraction,
but currently we cannot check that statically.
-}
colSum :: (Fraction a, Real.C a) => Precision -> String -> T (CellTracked a) a
colSum prec name =
   Cons [(name,True)] (summarySum prec) trackedNumber (summary5String prec)

colSum5 :: (Fraction a, Real.C a) => Precision -> String -> T (CellTracked a) a
colSum5 prec name =
   Cons [(name,True)] (summarySum5 prec) trackedNumber (summary5String prec)


summRight :: ([r0] -> [a]) -> ([r1] -> [a]) -> [r1] -> [a]
summRight f0 f1 cells = f0 [] ++ f1 cells

infixr 5 `right`

right :: T () () -> T a b -> T a b
right (Cons name0 agg0 _sel0 med0) (Cons name1 agg1 sel1 med1) =
   Cons (name0++name1) (summRight agg0 agg1) sel1 (summRight med0 med1)

summPair :: ([r0] -> [a]) -> ([r1] -> [a]) -> [(r0,r1)] -> [a]
summPair f0 f1 cells =
   let (cells0,cells1) = unzip cells
   in  f0 cells0 ++ f1 cells1

pair :: T a0 b0 -> T a1 b1 -> T (a0,a1) (b0,b1)
pair (Cons name0 agg0 sel0 med0) (Cons name1 agg1 sel1 med1) =
   Cons (name0++name1)
      (summPair agg0 agg1)
      (mapPair (sel0, sel1))
      (summPair med0 med1)

summTriple ::
   ([r0] -> [a]) -> ([r1] -> [a]) -> ([r2] -> [a]) -> [(r0,r1,r2)] -> [a]
summTriple f0 f1 f2 cells =
   let (cells0,cells1,cells2) = unzip3 cells
   in  f0 cells0 ++ f1 cells1 ++ f2 cells2

triple :: T a0 b0 -> T a1 b1 -> T a2 b2 -> T (a0,a1,a2) (b0,b1,b2)
triple
      (Cons name0 agg0 sel0 med0)
      (Cons name1 agg1 sel1 med1)
      (Cons name2 agg2 sel2 med2) =
   Cons (name0++name1++name2)
      (summTriple agg0 agg1 agg2)
      (mapTriple (sel0, sel1, sel2))
      (summTriple med0 med1 med2)

maybe :: T a b -> T (Maybe a) (Maybe b)
maybe (Cons name agg sel med) =
   Cons name (agg . catMaybes) (fmap sel) (med . catMaybes)