Multiple aggregates in a single pass, using Purescript

Aggregation.purs

-- This is based on ideas from the excellent article "Beautiful Aggregations
-- with Haskell" by Evan Borden: https://tech.freckle.com/2017/09/22/aggregations/
module Aggregation where

import Prelude

import Data.Foldable (foldMap)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (un)

type Person = { name :: String, occupation :: String, age :: Int }

rows :: Array Person
rows = [ { name: "Bob", occupation: "Dentist", age: 34 }
       , { name: "Tim", occupation: "Nurse", age: 25 }
       , { name: "Ann", occupation: "Programmer", age: 47 }
       , { name: "Mae", occupation: "Astronaut", age: 38 }
       , { name: "Ann", occupation: "Truck driver", age: 55 }
       ]

-- | Produce some summary information from a given list of people in a single pass.
-- |
-- | > summary rows
-- | { annCount: 2, occupations: ["Dentist","Nurse","Programmer","Astronaut","Truck driver"], sumOfAges: 199 }
-- |
-- | Note that this could be written more concisely/generally, but I'm trying to be explicit.
summary :: Array Person -> { occupations :: Array String, sumOfAges :: Int, annCount :: Int }
summary people =
  -- foldMap works like a map/reduce, where each value in a collection is put into a
  -- monoidal value, and those "wrapped" values are combined together into a single
  -- value by the particular monoid that is in use.
  unpack (foldMap step people)
  where
    -- Return a monoidal result for each folded item. It just so happens
    -- that a record whose fields are all monoids is also a monoid, so this function
    -- just returns a record. These records get combined together into a single record
    -- by having their corresponding field values successively combined monoidally.
    step { name, occupation, age } =
      { occupations: pure occupation
      , sumOfAges: pure age
      , annCount: if name == "Ann" then pure 1 else mempty }

    -- Unpack the combined monoidal accumulator, which just involves unpacking
    -- individual fields
    unpack { occupations, sumOfAges, annCount } =
      { occupations, sumOfAges: un Additive sumOfAges, annCount: un Additive annCount }

This can be written more succinctly, though with a bit more magic, using the Control.Fold library:

module Aggregation where

import Prelude

import Control.Fold as F
import Data.Profunctor (lcmap)

type Person = { name :: String, occupation :: String, age :: Int }

rows :: Array Person
rows = [ { name: "Bob", occupation: "Dentist", age: 34 }
       , { name: "Tim", occupation: "Nurse", age: 25 }
       , { name: "Ann", occupation: "Programmer", age: 47 }
       , { name: "Mae", occupation: "Astronaut", age: 38 }
       , { name: "Ann", occupation: "Truck driver", age: 55 }
       ]

type Summary = { occupations :: Array String, sumOfAges :: Int, annCount :: Int }

-- | Produce some summary information from a given list of people in a single pass.
-- |
-- | > summary rows
-- | { annCount: 2, occupations: ["Dentist","Nurse","Programmer","Astronaut","Truck driver"], sumOfAges: 199 }
summary :: Array Person -> Summary
summary people = F.foldl summF people

summF :: F.Fold Person Summary
summF = toRec
        <$> (pure <<< _.occupation) `lcmap` F.mconcat
        <*> _.age `lcmap` F.sum
        <*> (\p -> if p.name == "Ann" then 1 else 0) `lcmap` F.sum
  where
    toRec occupations sumOfAges annCount = { occupations, sumOfAges, annCount }

Here are some extra little fold combinators I wrote:

import Control.Comonad as CoM
import Control.Fold
import Data.FoldableWithIndex (class FoldableWithIndex, foldMapWithIndex)
import Data.Map (Map, alter)
import Data.Maybe (fromMaybe)

groupBy :: forall a r g . Ord g => (a -> g) -> Fold a r -> Fold a (Map g r)
groupBy grouper f1 = unfoldFold mempty combine (map CoM.extract)
  where
    combine :: Map g (Fold a r) -> a -> Map g (Fold a r)
    combine m x = alter (\mf -> pure (stepFold x (fromMaybe f1 mf))) (grouper x) m

flattenWithIndex :: forall a g r b fi . FoldableWithIndex g fi => Monoid b => (g -> r -> b) -> Fold a (fi r) -> Fold a b
flattenWithIndex f = map (foldMapWithIndex f)

👍