measures.hs

import Data.List (sort)

type Pairs   = [(Double,Double)]
type Measure = [Double] -> Double

midpoints :: Pairs -> [Double]
midpoints = map (\(x, y) -> (x + y) / 2)

mean :: Measure
mean xs = sum xs / (fromIntegral $ length xs)

range :: Measure
range [] = 0
range [x] = 0
range xs = let xs' = sort xs in (last xs' - head xs')

midrange :: Measure
midrange [] = 0
midrange [x] = 0
midrange xs = (head xs + last xs) / 2

median :: Measure
median [] = 0
median [x] = x
median zs =
  let recurse (x0:_) (_:[]) = x0
      recurse (x0:x1:_) (_:_:[]) = (x0 + x1) / 2
      recurse (_:xs) (_:_:ys) = recurse xs ys
      recurse _ _ = error "IMPOSSIBLE"
  in recurse zs zs

data FreqMean = FreqError String | FreqDouble Double

instance Show FreqMean where
  show (FreqError s) = show s
  show (FreqDouble d) = show d

freqMean :: Pairs -> [Double] -> FreqMean
freqMean xs fs
  | length xs /= length fs =
      FreqError
      $ "ERROR: "
      ++ "Length of Classes is " ++ show (length xs) ++ ", but "
      ++ "Length of Frequences is " ++ show (length fs)
  | otherwise = FreqDouble $ 
      let fxm = zipWith (*) (midpoints xs) fs
          sfxm = sum fxm
          sfs = sum fs
      in (sum fxm) / (sum fs)

weightedMean :: [Double] -> [Double] -> FreqMean
weightedMean ws vs
  | length ws /= length vs =
      FreqError
      $ "ERROR: "
      ++ "Length of Weights is " ++ show (length ws) ++ ", but "
      ++ "Length of Values is " ++ show (length vs)
  | otherwise = FreqDouble $
      let sumPairs = sum $ zipWith (*) ws vs
          sumWeights = sum ws
      in sumPairs / sumWeights

data SType = Population | Sample

variance :: SType -> [Double] -> Double
variance t xs =
  let len = length xs
      denom = case t of
        Population -> fromIntegral len
        Sample -> fromIntegral $ len - 1
      x_bar = mean xs
      adjusted = sum $ map (\x -> (x - x_bar) ** 2) xs
  in adjusted / denom

stdev :: SType -> Measure
stdev t xs = sqrt $ variance t xs

freqVariance :: Pairs -> Measure
freqVariance xs fs =
  let n   = sum fs
      midpoints' = midpoints xs
      midpoints2 = map (** 2) midpoints'
      s1 = sum $ zipWith (*) fs midpoints2
      s2 = sum $ zipWith (*) fs midpoints'
  in (n * s1 - (s2 ** 2)) / (n * (n - 1))

freqStdev :: Pairs -> Measure
freqStdev xs fs = sqrt (freqVariance xs fs)

cv :: Double -> Double -> Double
cv std mn = 100 * (std / mn)

-- truncates values when it shouldn't need to
chebyshev ::
     (Double, Double) -- ^ interval 1
  -> (Double, Double) -- ^ interval 2
  -> Double -- ^ distribution size
  -> Double -- ^ mean
  -> Double -- ^ interval 1 size
  -> Double
chebyshev (_, upperBound1) (_, upperBound2) distributionSize mean_ interval1Size =
  let p = (interval1Size / distributionSize)
      k1 = trunc (sqrt $ 1 / (1 - p)) 1
      s  = trunc ((upperBound1 - mean_) / k1) 1
      n_ = upperBound2 - mean_
      k2 = trunc (n_ / s) 1
  in 100 * (1 - (1 / k2**2))

trunc :: Double -> Int -> Double
trunc f n = (fromIntegral $ round $ f * (10 ^ n)) / (10.0 ^^ n)