Pivot.hs

module Controller.Menu.Statistics.Pivot (eventHandler)
    where

import Control.Monad (when,forM_)
import Data.List (nub)
import Data.Maybe (mapMaybe)
import Controller (Controller,onView,onGridView,onGridModel)
import Controller.Canonical (addColumnExpr,addRowExpr)
import qualified Controller.Grid as Grid
import Controller.Dialog (warning)
import View.Component.Grid (getColumnLabels)
import View.Dialog.Complex (Layout (..),Widget (..),Modifier (..)
                           ,showSimpleDialog,okButton,cancelButton)
import Model.Grid (getColumnValues)
import Model.CellContent (CellValue (NumberValue),valueToExpr)
import qualified Model.CellExpression.Evaluator.Math as Math
import Model.CellExpression.Evaluator.Common (fLength,getNumList)
import Util (justWhen)
import I18n (__)

data Aggregator = Count
                | Numeric ([Double] -> Double)

data Parameters = Parameters { abscissaColumn :: Maybe Int
                             , ordinateColumn :: Maybe Int
                             , dataColumn :: Maybe Int
                             , aggregatorIndex :: Int
                             , makeTotals :: Bool
                             }

defaultParams :: Parameters
defaultParams = Parameters Nothing Nothing Nothing 0 True

aggregatorList :: [String]
aggregatorList = [ __ "Sum",__ "Mean",__ "Median",__ "Maximum"
                 , __ "Minimum",__ "Standard Deviation",__ "Count"]

aggregatorFromInt :: Int -> Aggregator
aggregatorFromInt i = 
    case i of 0 -> Numeric sum; 1 -> Numeric Math.mean
              2 -> Numeric Math.median; 3 -> Numeric maximum
              4 -> Numeric minimum; 5 -> Numeric Math.stdDeviation
              6 -> Count

typecheck :: Aggregator -> [CellValue] -> Bool
typecheck aggregator values = 
    case aggregator of
      Numeric _ -> either (\_ -> False) (\_ -> True) $ getNumList values
      _ -> True

apply :: Aggregator -> [CellValue] -> CellValue
apply aggregator values =
    case aggregator of
      Count -> NumberValue $ fLength values
      Numeric f -> let Right vs = getNumList values
                   in NumberValue $ f vs

eventHandler :: Controller ()
eventHandler = eventHandlerWith defaultParams

eventHandlerWith :: Parameters -> Controller ()
eventHandlerWith params = do
  labels <- onGridView getColumnLabels
  result <- onView $ showSimpleDialog (__ "Pivot table") 
               (dialog labels) params
  justWhen result $ \params' -> do success <- processParams params'
                                   when (not success) 
                                            $ eventHandlerWith params'

dialog :: [String] -> Layout Parameters ()
dialog labels =
    let setAbscissa p a = p {abscissaColumn = a}
        setOrdinate p a = p {ordinateColumn = a}
        setData p a = p {dataColumn = a}
        setAggregator p a = p {aggregatorIndex = a}
        setTotals p b = p {makeTotals = b}
    in
      Modifier Margin $ Column 
        [ Row [ Modifiers [Boxed $ __ "Abscissa column",HFill]
                  $ Widget $ SingleListBox labels abscissaColumn setAbscissa
              , Modifiers [Boxed $ __ "Ordinate column",HFill]
                  $ Widget $ SingleListBox labels ordinateColumn setOrdinate
              , Modifiers [Boxed $ __ "Data column",HFill]
                  $ Widget $ SingleListBox labels dataColumn setData]
        , Grid [[ Label $ __ "Aggregator"
                , Widget $ Choice aggregatorList aggregatorIndex setAggregator]
               ,[ Label $ __ "Make totals"
                , Widget $ CheckBox "" makeTotals setTotals]]
        , Modifier Center $ Row [okButton (),cancelButton]]

processParams :: Parameters -> Controller Bool
processParams params = 
    case (abscissaColumn params,ordinateColumn params,dataColumn params) of
      (Nothing,_,_) -> warning (__ "No abscissa column selected") >> return False
      (_,Nothing,_) -> warning (__ "No ordinate column selected") >> return False
      (_,_,Nothing) -> warning (__ "No data column selected") >> return False
      (Just absCol,Just ordCol,Just dataCol) ->
          do abscissa <- onGridModel $ getColumnValues absCol
             ordinate <- onGridModel $ getColumnValues ordCol
             datas <- onGridModel $ getColumnValues dataCol
             calcPivotTable abscissa ordinate datas 
               (aggregatorFromInt $ aggregatorIndex params) 
               (makeTotals params)

calcPivotTable :: [CellValue] -> [CellValue] -> [CellValue] 
               -> Aggregator -> Bool -> Controller Bool
calcPivotTable abscissa ordinate datas aggregator makeTotals = 
    if not $ typecheck aggregator datas 
    then warning (__ "Can not apply aggregator to selected data column (e.g. because of non-numeric data).")
             >> return False
    else do
      Grid.new

      let association = zip3 abscissa ordinate datas
          nubOrdinate = nub ordinate
          nubAbscissa = nub abscissa
          aggregateSome select =
              let values = mapMaybe (\(a,o,value) -> if select a o 
                                                     then Just value 
                                                     else Nothing
                                    ) association
              in valueToExpr $ apply aggregator values

          aggregate abscissaValue ordinateValue =
              aggregateSome $ \a o -> a == abscissaValue && o == ordinateValue
          aggregateAbs abscissaValue =
              aggregateSome $ \a _ -> a == abscissaValue
          aggregateOrd ordinateValue =
              aggregateSome $ \_ o -> o == ordinateValue

      forM_ nubAbscissa $ \abscissaValue -> 
          let column = map (aggregate abscissaValue) nubOrdinate
          in
            addColumnExpr (Just $ show abscissaValue) column

      Grid.updateRowLabels $ map show nubOrdinate

      when makeTotals $ 
           let column = map aggregateOrd nubOrdinate
               row = map aggregateAbs nubAbscissa
               all = aggregateSome (\_ _ -> True)
           in do
             addColumnExpr (Just $ __ "Total") column
             addRowExpr (Just $ __ "Total") $ row ++ [all]
      return True