From 6541fa5316816d6f97a87a370775cfe278e7eeb8 Mon Sep 17 00:00:00 2001 From: Joris Date: Thu, 7 Apr 2016 23:58:23 +0200 Subject: Add cumulative incomes by user --- src/client/elm/LoggedIn/Home/Account/View.elm | 2 +- src/client/elm/LoggedIn/Home/AddPayment/View.elm | 4 +- src/client/elm/LoggedIn/Home/Model.elm | 3 +- src/client/elm/LoggedIn/Home/Model/Payer.elm | 130 --------------------- src/client/elm/LoggedIn/Home/View/Paging.elm | 2 +- src/client/elm/LoggedIn/Income/View.elm | 43 ++++++- src/client/elm/LoggedIn/Stat/View.elm | 14 +++ src/client/elm/Model/Income.elm | 8 ++ src/client/elm/Model/Payer.elm | 140 +++++++++++++++++++++++ src/server/Design/Global.hs | 15 ++- src/server/Design/LoggedIn/Home/Pages.hs | 2 +- src/server/Design/LoggedIn/Income.hs | 5 +- src/server/Model/Message/Key.hs | 2 +- src/server/Model/Message/Translations.hs | 14 +-- 14 files changed, 228 insertions(+), 156 deletions(-) delete mode 100644 src/client/elm/LoggedIn/Home/Model/Payer.elm create mode 100644 src/client/elm/Model/Payer.elm diff --git a/src/client/elm/LoggedIn/Home/Account/View.elm b/src/client/elm/LoggedIn/Home/Account/View.elm index bec75d5..dc72791 100644 --- a/src/client/elm/LoggedIn/Home/Account/View.elm +++ b/src/client/elm/LoggedIn/Home/Account/View.elm @@ -8,11 +8,11 @@ import Html.Attributes exposing (..) import LoggedData exposing (LoggedData) import LoggedIn.Home.Model as HomeModel -import LoggedIn.Home.Model.Payer exposing (..) import LoggedIn.View.Format as Format import Model exposing (Model) import Model.User exposing (getUserName) +import Model.Payer exposing (..) view : LoggedData -> HomeModel.Model -> Html view loggedData homeModel = diff --git a/src/client/elm/LoggedIn/Home/AddPayment/View.elm b/src/client/elm/LoggedIn/Home/AddPayment/View.elm index 562f69b..96f3a6a 100644 --- a/src/client/elm/LoggedIn/Home/AddPayment/View.elm +++ b/src/client/elm/LoggedIn/Home/AddPayment/View.elm @@ -4,7 +4,7 @@ module LoggedIn.Home.AddPayment.View import Result exposing (..) -import Html as H exposing (..) +import Html exposing (..) import Html.Attributes exposing (..) import Html.Events exposing (..) @@ -31,7 +31,7 @@ import Utils.Either exposing (toMaybeError) view : LoggedData -> HomeModel.Model -> Html view loggedData homeModel = - H.form + Html.form [ let update = if homeModel.add.waitingServer then diff --git a/src/client/elm/LoggedIn/Home/Model.elm b/src/client/elm/LoggedIn/Home/Model.elm index 26af63c..217a851 100644 --- a/src/client/elm/LoggedIn/Home/Model.elm +++ b/src/client/elm/LoggedIn/Home/Model.elm @@ -3,10 +3,9 @@ module LoggedIn.Home.Model , init ) where -import LoggedIn.Home.Model.Payer exposing (Payers) - import Model.User exposing (Users, UserId) import Model.Payment exposing (PaymentId, Payments, Frequency(..)) +import Model.Payer exposing (Payers) import LoggedIn.Home.AddPayment.Model as AddPaymentModel diff --git a/src/client/elm/LoggedIn/Home/Model/Payer.elm b/src/client/elm/LoggedIn/Home/Model/Payer.elm deleted file mode 100644 index be40ffa..0000000 --- a/src/client/elm/LoggedIn/Home/Model/Payer.elm +++ /dev/null @@ -1,130 +0,0 @@ -module LoggedIn.Home.Model.Payer - ( Payers - , Payer - , ExceedingPayer - , getOrderedExceedingPayers - ) where - -import Json.Decode as Json exposing (..) -import Dict exposing (..) -import List -import Maybe -import Time exposing (Time) -import Date - -import Model.Payment exposing (Payments, totalPayments) -import Model.User exposing (Users, UserId, userIdDecoder) -import Model.Income exposing (..) - -import Utils.Dict exposing (mapValues) -import Utils.Maybe exposing (isJust) - -type alias Payers = Dict UserId Payer - -type alias Payer = - { preIncomePaymentSum : Int - , postIncomePaymentSum : Int - , incomes : List Income - } - -type alias ExceedingPayer = - { userId : UserId - , amount : Int - } - -getOrderedExceedingPayers : Time -> Users -> Incomes -> Payments -> List ExceedingPayer -getOrderedExceedingPayers currentTime users incomes payments = - let payers = getPayers currentTime users incomes payments - exceedingPayersOnPreIncome = - payers - |> mapValues .preIncomePaymentSum - |> Dict.toList - |> exceedingPayersFromAmounts - firstPaymentTime = - payments - |> List.map (Date.toTime << .creation) - |> List.sort - |> List.head - incomesForAllTime = incomeDefinedForAll (Dict.keys users) incomes - in case (firstPaymentTime, incomesForAllTime) of - (Just paymentTime, Just incomeTime) -> - let since = max paymentTime incomeTime - postPaymentPayers = mapValues (getPostPaymentPayer currentTime since) payers - mbMaxRatio = - postPaymentPayers - |> Dict.toList - |> List.map (.ratio << snd) - |> List.maximum - in case mbMaxRatio of - Just maxRatio -> - postPaymentPayers - |> mapValues (getFinalDiff maxRatio) - |> Dict.toList - |> exceedingPayersFromAmounts - Nothing -> - exceedingPayersOnPreIncome - _ -> - exceedingPayersOnPreIncome - -getPayers : Time -> Users -> Incomes -> Payments -> Payers -getPayers currentTime users incomes payments = - let userIds = Dict.keys users - incomesDefined = incomeDefinedForAll userIds incomes - in userIds - |> List.map (\userId -> - ( userId - , { preIncomePaymentSum = - totalPayments - (\p -> (Date.toTime p.creation) < (Maybe.withDefault currentTime incomesDefined)) - userId - payments - , postIncomePaymentSum = - totalPayments - (\p -> - case incomesDefined of - Nothing -> False - Just t -> (Date.toTime p.creation) >= t - ) - userId - payments - , incomes = List.filter ((==) userId << .userId) (Dict.values incomes) - } - ) - ) - |> Dict.fromList - -exceedingPayersFromAmounts : List (UserId, Int) -> List ExceedingPayer -exceedingPayersFromAmounts userAmounts = - let mbMinAmount = List.minimum << List.map snd <| userAmounts - in case mbMinAmount of - Nothing -> - [] - Just minAmount -> - userAmounts - |> List.map (\userAmount -> - { userId = fst userAmount - , amount = snd userAmount - minAmount - } - ) - |> List.filter (\payer -> payer.amount > 0) - -type alias PostPaymentPayer = - { preIncomePaymentSum : Int - , cumulativeIncome : Int - , ratio : Float - } - -getPostPaymentPayer : Time -> Time -> Payer -> PostPaymentPayer -getPostPaymentPayer currentTime since payer = - let cumulativeIncome = cumulativeIncomesSince currentTime since payer.incomes - in { preIncomePaymentSum = payer.preIncomePaymentSum - , cumulativeIncome = cumulativeIncome - , ratio = toFloat payer.postIncomePaymentSum / toFloat cumulativeIncome - } - -getFinalDiff : Float -> PostPaymentPayer -> Int -getFinalDiff maxRatio payer = - let postIncomeDiff = - -1 * (maxRatio - payer.ratio) * toFloat payer.cumulativeIncome - |> truncate - in postIncomeDiff + payer.preIncomePaymentSum diff --git a/src/client/elm/LoggedIn/Home/View/Paging.elm b/src/client/elm/LoggedIn/Home/View/Paging.elm index b669b6e..939ee55 100644 --- a/src/client/elm/LoggedIn/Home/View/Paging.elm +++ b/src/client/elm/LoggedIn/Home/View/Paging.elm @@ -45,7 +45,7 @@ truncatePages currentPage pages = if currentPage <= showedLeftPages then [1..showedPages] else if currentPage > totalPages - showedRightPages then - [(totalPages - showedPages)..totalPages] + [(totalPages - showedPages + 1)..totalPages] else [(currentPage - showedLeftPages)..(currentPage + showedRightPages)] in List.filter (flip List.member pages) truncatedPages diff --git a/src/client/elm/LoggedIn/Income/View.elm b/src/client/elm/LoggedIn/Income/View.elm index f62902a..9e77fde 100644 --- a/src/client/elm/LoggedIn/Income/View.elm +++ b/src/client/elm/LoggedIn/Income/View.elm @@ -4,6 +4,7 @@ module LoggedIn.Income.View import Dict import Date +import Time exposing (Time) import Html exposing (..) import Html.Events exposing (..) @@ -13,8 +14,10 @@ import Form.Input as Input import LoggedData exposing (LoggedData) -import Model.Income exposing (IncomeId, Income) -import Model.Translations exposing (getMessage) +import Model.Income exposing (IncomeId, Income, userCumulativeIncomeSince) +import Model.Translations exposing (getMessage, getParamMessage) +import Model.Payer exposing (useIncomesFrom) +import Model.User exposing (UserId, User) import LoggedIn.Income.Model as IncomeModel import Mailbox @@ -28,16 +31,46 @@ import LoggedIn.View.Format as Format import Utils.Maybe exposing (isJust) +import LoggedIn.View.Date exposing (renderLongDate) +import View.Events exposing (onSubmitPrevDefault) + view : LoggedData -> IncomeModel.Model -> Html view loggedData incomeModel = div [ class "income" ] - [ h1 [] [ text <| getMessage "AddIncome" loggedData.translations ] + [ case useIncomesFrom loggedData.users loggedData.incomes loggedData.payments of + Just since -> cumulativeIncomesView loggedData since + Nothing -> text "" + , h1 [] [ text <| getMessage "AddIncome" loggedData.translations ] , addIncomeView loggedData incomeModel.addIncome , h1 [] [ text <| getMessage "MonthlyNetIncomes" loggedData.translations ] , incomesView loggedData ] +cumulativeIncomesView : LoggedData -> Time -> Html +cumulativeIncomesView loggedData since = + let longDate = renderLongDate (Date.fromTime since) loggedData.translations + in div + [] + [ h1 [] [ text <| getParamMessage [longDate] "CumulativeIncomesSince" loggedData.translations ] + , ul + [] + ( Dict.toList loggedData.users + |> List.map (\(userId, user) -> + (user.name, userCumulativeIncomeSince loggedData.currentTime since loggedData.incomes userId) + ) + |> List.sortBy snd + |> List.map (\(userName, cumulativeIncome) -> + li + [] + [ text userName + , text ": " + , text <| Format.price loggedData.conf cumulativeIncome + ] + ) + ) + ] + addIncomeView : LoggedData -> Form () IncomeModel.AddIncome -> Html addIncomeView loggedData addIncome = let @@ -49,8 +82,8 @@ addIncomeView loggedData addIncome = creation = Form.getFieldAsString "creation" addIncome amount = Form.getFieldAsString "amount" addIncome in - div - [] + Html.form + [ onSubmitPrevDefault Mailbox.address Action.NoOp ] [ label [] [ text "Creation" ] , Input.textInput creation formAddress [] , errorFor "DateValidationError" creation diff --git a/src/client/elm/LoggedIn/Stat/View.elm b/src/client/elm/LoggedIn/Stat/View.elm index f4bc56c..6661a75 100644 --- a/src/client/elm/LoggedIn/Stat/View.elm +++ b/src/client/elm/LoggedIn/Stat/View.elm @@ -41,8 +41,22 @@ paymentsDetail loggedData payments = , li [] [ text (paymentsSum loggedData.conf payments) ] + , li + [] + [ text "Par utilisateur:" + , totalPayments loggedData + ] + ] + +totalPayments : LoggedData -> Html +totalPayments loggedData = + ul + [] + [ li [] [ text "Jacques: 1 300€" ] + , li [] [ text "Anne: 2 500 €" ] ] + monthsDetail : LoggedData -> Html monthsDetail loggedData = ul diff --git a/src/client/elm/Model/Income.elm b/src/client/elm/Model/Income.elm index f364a8b..ea990e2 100644 --- a/src/client/elm/Model/Income.elm +++ b/src/client/elm/Model/Income.elm @@ -5,6 +5,7 @@ module Model.Income , incomesDecoder , incomeIdDecoder , incomeDefinedForAll + , userCumulativeIncomeSince , cumulativeIncomesSince ) where @@ -55,6 +56,13 @@ incomeDefinedForAll userIds incomes = then head << reverse << List.sort << map .creation << catMaybes <| firstIncomes else Nothing +userCumulativeIncomeSince : Time -> Time -> Incomes -> UserId -> Int +userCumulativeIncomeSince currentTime since incomes userId = + incomes + |> Dict.values + |> List.filter (\income -> income.userId == userId) + |> cumulativeIncomesSince currentTime since + cumulativeIncomesSince : Time -> Time -> (List Income) -> Int cumulativeIncomesSince currentTime since incomes = cumulativeIncome currentTime (getOrderedIncomesSince since incomes) diff --git a/src/client/elm/Model/Payer.elm b/src/client/elm/Model/Payer.elm new file mode 100644 index 0000000..a7ce5fa --- /dev/null +++ b/src/client/elm/Model/Payer.elm @@ -0,0 +1,140 @@ +module Model.Payer + ( Payers + , Payer + , ExceedingPayer + , getOrderedExceedingPayers + , useIncomesFrom + , getPostPaymentPayer + ) where + +import Json.Decode as Json exposing (..) +import Dict exposing (..) +import List +import Maybe +import Time exposing (Time) +import Date + +import Model.Payment exposing (Payments, totalPayments) +import Model.User exposing (Users, UserId, userIdDecoder) +import Model.Income exposing (..) + +import Utils.Dict exposing (mapValues) +import Utils.Maybe exposing (isJust) + +type alias Payers = Dict UserId Payer + +type alias Payer = + { preIncomePaymentSum : Int + , postIncomePaymentSum : Int + , incomes : List Income + } + +type alias ExceedingPayer = + { userId : UserId + , amount : Int + } + +getOrderedExceedingPayers : Time -> Users -> Incomes -> Payments -> List ExceedingPayer +getOrderedExceedingPayers currentTime users incomes payments = + let payers = getPayers currentTime users incomes payments + exceedingPayersOnPreIncome = + payers + |> mapValues .preIncomePaymentSum + |> Dict.toList + |> exceedingPayersFromAmounts + mbSince = useIncomesFrom users incomes payments + in case mbSince of + Just since -> + let postPaymentPayers = mapValues (getPostPaymentPayer currentTime since) payers + mbMaxRatio = + postPaymentPayers + |> Dict.toList + |> List.map (.ratio << snd) + |> List.maximum + in case mbMaxRatio of + Just maxRatio -> + postPaymentPayers + |> mapValues (getFinalDiff maxRatio) + |> Dict.toList + |> exceedingPayersFromAmounts + Nothing -> + exceedingPayersOnPreIncome + _ -> + exceedingPayersOnPreIncome + +useIncomesFrom : Users -> Incomes -> Payments -> Maybe Time +useIncomesFrom users incomes payments = + let firstPaymentTime = + payments + |> List.map (Date.toTime << .creation) + |> List.sort + |> List.head + incomesForAllTime = incomeDefinedForAll (Dict.keys users) incomes + in case (firstPaymentTime, incomesForAllTime) of + (Just paymentTime, Just incomeTime) -> + Just (max paymentTime incomeTime) + _ -> + Nothing + +getPayers : Time -> Users -> Incomes -> Payments -> Payers +getPayers currentTime users incomes payments = + let userIds = Dict.keys users + incomesDefined = incomeDefinedForAll userIds incomes + in userIds + |> List.map (\userId -> + ( userId + , { preIncomePaymentSum = + totalPayments + (\p -> (Date.toTime p.creation) < (Maybe.withDefault currentTime incomesDefined)) + userId + payments + , postIncomePaymentSum = + totalPayments + (\p -> + case incomesDefined of + Nothing -> False + Just t -> (Date.toTime p.creation) >= t + ) + userId + payments + , incomes = List.filter ((==) userId << .userId) (Dict.values incomes) + } + ) + ) + |> Dict.fromList + +exceedingPayersFromAmounts : List (UserId, Int) -> List ExceedingPayer +exceedingPayersFromAmounts userAmounts = + let mbMinAmount = List.minimum << List.map snd <| userAmounts + in case mbMinAmount of + Nothing -> + [] + Just minAmount -> + userAmounts + |> List.map (\userAmount -> + { userId = fst userAmount + , amount = snd userAmount - minAmount + } + ) + |> List.filter (\payer -> payer.amount > 0) + +type alias PostPaymentPayer = + { preIncomePaymentSum : Int + , cumulativeIncome : Int + , ratio : Float + } + +getPostPaymentPayer : Time -> Time -> Payer -> PostPaymentPayer +getPostPaymentPayer currentTime since payer = + let cumulativeIncome = cumulativeIncomesSince currentTime since payer.incomes + in { preIncomePaymentSum = payer.preIncomePaymentSum + , cumulativeIncome = cumulativeIncome + , ratio = toFloat payer.postIncomePaymentSum / toFloat cumulativeIncome + } + +getFinalDiff : Float -> PostPaymentPayer -> Int +getFinalDiff maxRatio payer = + let postIncomeDiff = + -1 * (maxRatio - payer.ratio) * toFloat payer.cumulativeIncome + |> truncate + in postIncomeDiff + payer.preIncomePaymentSum diff --git a/src/server/Design/Global.hs b/src/server/Design/Global.hs index 90dd842..e2e98a7 100644 --- a/src/server/Design/Global.hs +++ b/src/server/Design/Global.hs @@ -36,14 +36,19 @@ global = do a ? cursor pointer h1 ? do - fontSize (px 20) + fontSize (px 24) color Color.red - marginBottom (em 1) + "margin-bottom" -: "3vh" ul ? do - marginBottom (em 1) - li ? do - marginBottom (em 0.5) + "margin-bottom" -: "3vh" + "margin-left" -: "1vh" + li "The date must be day/month/year" French -> "La date doit avoir la forme jour/mois/année" -m l IncomeValidationError = - case l of - English -> "The income must be a positive integer." - French -> "Le revenu doit être un entier positif." - -- Payments m l Add = @@ -269,9 +264,14 @@ m l ByMonths = -- Income +m l CumulativeIncomesSince = + case l of + English -> "Cumulative incomes since {0}" + French -> "Revenus nets cumulés depuis le {0}" + m l AddIncome = case l of - English -> "Add a monthly net income" + English -> "Add a monthly income" French -> "Ajouter un revenu mensuel net" m l Income = @@ -281,7 +281,7 @@ m l Income = m l MonthlyNetIncomes = case l of - English -> "Monthly net incomes" + English -> "Monthly incomes" French -> "Revenus mensuels nets" m l IncomeNotDeleted = -- cgit v1.2.3