IntenseFinance/gnucash
3
0
Fork 0
mirror of https://github.com/Gnucash/gnucash.git synced 2025-02-25 18:55:30 -06:00
Code Issues Packages Projects Releases Wiki Activity

[date-utilities] bugfix: date-intervals produces good month deltas

Browse Source 
Instead of recursing the date, we calculate the next month using an
index-based multiplier, and apply modulo/remainder as appropriate to
determine the next month/year.

Then we attempt to create new mktime, and if the resulting mktime's
month is not as expected, reduce the mday by 1 until resulting month
is correct. This fixes monthly intervals for end-of-month days.

Test via monthly/quarterly deltas, and also includes leapyear
calculation.
This commit is contained in:
Christopher Lam 2019-02-03 09:26:24 +08:00
parent 74d4be19dc
commit 65bfeaf5de
2 changed files with 181 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

85
libgnucash/app-utils/date-utilities.scm
View File

@ -215,32 +215,78 @@
(define (gnc:time64-ge-date t1 t2)
(gnc:time64-le-date t2 t1))
;; Build a list of time intervals.
(define (incdate-months date nmonths)
(let* ((new-date (gnc-localtime date))
(newmonth (+ (tm:mon new-date) nmonths))
(new-month-proper (floor-remainder newmonth 12))
(new-year-proper (+ (tm:year new-date) (floor-quotient newmonth 12))))
(set-tm:year new-date new-year-proper)
(set-tm:mon new-date new-month-proper)
(let loop ((new-mday (tm:mday new-date)))
(set-tm:mday new-date new-mday)
(let ((res (gnc-mktime new-date)))
(if (= new-month-proper (tm:mon (gnc-localtime res)))
res
(loop (1- new-mday)))))))
;; Build a list of time intervals.
;;
;; Note that the last interval will be shorter than <incr> if
;; (<curd>-<endd>) is not an integer multiple of <incr>. If you don't
;; want that you'll have to write another function.
(define (gnc:make-date-interval-list current-date end-date increment)
(if (< current-date end-date)
(let ((next-date (incdate current-date increment)))
(if (< next-date end-date)
(cons (list current-date (decdate next-date SecDelta) '())
(gnc:make-date-interval-list next-date end-date increment))
(cons (list current-date end-date '())
'())))
'()))
(define (gnc:make-date-interval-list startdate enddate incr)
(define month-delta
(assv-ref MonthDeltas incr))
(let loop ((result '())
(date startdate)
(idx 0))
(cond
((>= date enddate)
(reverse result))
(month-delta
(let* ((curr (incdate-months startdate (* month-delta idx)))
(next (incdate-months startdate (* month-delta (1+ idx)))))
(loop (cons (list curr
(if (< next enddate)
(decdate next SecDelta)
enddate))
result)
next
(1+ idx))))
(else
(let ((next (incdate date incr)))
(loop (cons (list date
(if (< next enddate)
(decdate next SecDelta)
enddate))
result)
next
(1+ idx)))))))
;; Build a list of times. The dates are evenly spaced with the
;; stepsize 'incr'. If the difference of 'startdate' and 'enddate' is
;; not an integer multiple of 'incr', 'enddate' will be added as the
;; last element of the list, thus making the last interval smaller
;; than 'incr'.
(define (gnc:make-date-list startdate enddate incr)
(if (< startdate enddate)
(cons startdate
(gnc:make-date-list (incdate startdate incr)
enddate incr))
(list enddate)))
(define month-delta
(assv-ref MonthDeltas incr))
(let loop ((result '())
(date startdate)
(idx 0))
(cond
((>= date enddate)
(reverse (cons enddate result)))
(month-delta
(let* ((curr (incdate-months startdate (* month-delta idx)))
(next (incdate-months startdate (* month-delta (1+ idx)))))
(loop (cons curr result)
next
(1+ idx))))
(else
(loop (cons date result)
(incdate date incr)
(1+ idx))))))
; A reference zero date - the Beginning Of The Epoch
; Note: use of eval is evil... by making this a generator function,
@ -310,6 +356,13 @@
(set-tm:mday ddt 90)
ddt))
(define MonthDeltas
(list
(cons MonthDelta 1)
(cons QuarterDelta 3)
(cons HalfYearDelta 6)
(cons YearDelta 12)))
;; if you add any more FooDeltas, add to this list!!!
(define deltalist

112
libgnucash/app-utils/test/test-date-utilities.scm
View File

@ -57,6 +57,118 @@
(not (weeknums-equal? (cons '(1969 12 28 0 0 1)
'(1970 1 5 0 0 1))))))
(define (test-make-date-list)
(test-equal "make-date-list"
(list (create-time64 '(1969 12 18 0 0 1))
(create-time64 '(1969 12 25 0 0 1))
(create-time64 '(1970 1 1 0 0 1))
(create-time64 '(1970 1 2 0 0 1)))
(gnc:make-date-list
(create-time64 '(1969 12 18 0 0 1))
(create-time64 '(1970 1 2 0 0 1))
WeekDelta))
(test-equal "make-date-list exact"
(list (create-time64 '(1970 1 1 0 0 1))
(create-time64 '(1970 1 8 0 0 1))
(create-time64 '(1970 1 15 0 0 1)))
(gnc:make-date-list
(create-time64 '(1970 1 1 0 0 1))
(create-time64 '(1970 1 15 0 0 1))
WeekDelta))
(test-equal "make-date-list 31-dec-1970 to 15-4-1972 monthly including leapyear"
(list (create-time64 '(1970 12 31 0 0 1))
(create-time64 '(1971 1 31 0 0 1))
(create-time64 '(1971 2 28 0 0 1))
(create-time64 '(1971 3 31 0 0 1))
(create-time64 '(1971 4 30 0 0 1))
(create-time64 '(1971 5 31 0 0 1))
(create-time64 '(1971 6 30 0 0 1))
(create-time64 '(1971 7 31 0 0 1))
(create-time64 '(1971 8 31 0 0 1))
(create-time64 '(1971 9 30 0 0 1))
(create-time64 '(1971 10 31 0 0 1))
(create-time64 '(1971 11 30 0 0 1))
(create-time64 '(1971 12 31 0 0 1))
(create-time64 '(1972 1 31 0 0 1))
(create-time64 '(1972 2 29 0 0 1))
(create-time64 '(1972 3 31 0 0 1))
(create-time64 '(1972 4 15 0 0 1)))
(gnc:make-date-list
(create-time64 '(1970 12 31 0 0 1))
(create-time64 '(1972 4 15 0 0 1))
MonthDelta))
(test-equal "make-date-list 30-aug-1970 to 15-4-1972 quarterly including leapyear"
(list (create-time64 '(1970 8 31 0 0 1))
(create-time64 '(1970 11 30 0 0 1))
(create-time64 '(1971 2 28 0 0 1))
(create-time64 '(1971 5 31 0 0 1))
(create-time64 '(1971 8 31 0 0 1))
(create-time64 '(1971 11 30 0 0 1))
(create-time64 '(1972 2 29 0 0 1))
(create-time64 '(1972 4 15 0 0 1)))
(gnc:make-date-list
(create-time64 '(1970 8 31 0 0 1))
(create-time64 '(1972 4 15 0 0 1))
QuarterDelta))
(test-equal "make-date-list 30-aug-1970 to 15-4-1972 half-yearly including leapyear"
(list (create-time64 '(1970 8 30 0 0 1))
(create-time64 '(1971 2 28 0 0 1))
(create-time64 '(1971 8 30 0 0 1))
(create-time64 '(1972 2 29 0 0 1))
(create-time64 '(1972 4 15 0 0 1)))
(gnc:make-date-list
(create-time64 '(1970 8 30 0 0 1))
(create-time64 '(1972 4 15 0 0 1))
HalfYearDelta))
(test-equal "make-date-interval-list"
(list (list (create-time64 '(1969 12 18 0 0 1))
(create-time64 '(1969 12 25 0 0 0)))
(list (create-time64 '(1969 12 25 0 0 1))
(create-time64 '(1970 1 1 0 0 0)))
(list (create-time64 '(1970 1 1 0 0 1))
(create-time64 '(1970 1 2 0 0 1))))
(gnc:make-date-interval-list
(create-time64 '(1969 12 18 0 0 1))
(create-time64 '(1970 1 2 0 0 1))
WeekDelta))
(test-equal "make-date-interval-list exact"
(list (list (create-time64 '(1970 1 1 0 0 1))
(create-time64 '(1970 1 8 0 0 0)))
(list (create-time64 '(1970 1 8 0 0 1))
(create-time64 '(1970 1 15 0 0 1))))
(gnc:make-date-interval-list
(create-time64 '(1970 1 1 0 0 1))
(create-time64 '(1970 1 15 0 0 1))
WeekDelta))
(test-equal "make-date-interval-list 31/12/71 to 15/3/72 monthly incl leapyear"
(list (list (create-time64 '(1971 12 31 0 0 1))
(create-time64 '(1972 1 31 0 0 0)))
(list (create-time64 '(1972 1 31 0 0 1))
(create-time64 '(1972 2 29 0 0 0)))
(list (create-time64 '(1972 2 29 0 0 1))
(create-time64 '(1972 3 15 0 0 1))))
(gnc:make-date-interval-list
(create-time64 '(1971 12 31 0 0 1))
(create-time64 '(1972 03 15 0 0 1))
MonthDelta))
(test-equal "make-date-interval-list exact monthly"
(list (list (create-time64 '(1970 1 31 0 0 1))
(create-time64 '(1970 2 28 0 0 0)))
(list (create-time64 '(1970 2 28 0 0 1))
(create-time64 '(1970 3 31 0 0 1))))
(gnc:make-date-interval-list
(create-time64 '(1970 1 31 0 0 1))
(create-time64 '(1970 3 31 0 0 1))
MonthDelta)))
(define (test-date-get-quarter-string)
(test-equal "14/02/2001 = Q1"
"Q1"