From 4cb16b6f42ea7ea088fa4134f8fe4ccfec16a56d Mon Sep 17 00:00:00 2001 From: =?utf8?q?Mattias=20Engdeg=C3=A5rd?= Date: Wed, 30 Sep 2020 23:57:27 +0200 Subject: [PATCH] Calc: fix business days calculation (bug43677) The calculation of business days was broken in 2012 (probably 310e60d9454fe2 or thereabouts) when the date representation changed epoch so that Jan 1, 1 AD became day number 1 instead of 0. Repair this, along with an unrelated bug that prevented arbitrary holiday weekdays from working. Reported by Aaron Zeng. * lisp/calc/calc-forms.el (math-to-business-day) (math-from-business-day): Correct calculation of weekdays using Calc's current (Rata Die) chronology. Modify loop condition to cope with odd sets of holiday weekdays. * test/lisp/calc/calc-tests.el (calc-business-days): New test. --- lisp/calc/calc-forms.el | 13 +++--- test/lisp/calc/calc-tests.el | 76 ++++++++++++++++++++++++++++++++++++ 2 files changed, 83 insertions(+), 6 deletions(-) diff --git a/lisp/calc/calc-forms.el b/lisp/calc/calc-forms.el index 5a8f0a38d24..6d70126c098 100644 --- a/lisp/calc/calc-forms.el +++ b/lisp/calc/calc-forms.el @@ -1870,8 +1870,8 @@ and ends on the last Sunday of October at 2 a.m." (and days (= day (car days)) (setq holiday t))) (let* ((weekdays (nth 3 math-holidays-cache)) - (weeks (1- (/ (+ day 6) 7))) - (wkday (- day 1 (* weeks 7)))) + (weeks (/ day 7)) + (wkday (mod day 7))) ; Day of week: 0=Sunday, 6=Saturday (setq delta (+ delta (* weeks (length weekdays)))) (while (and weekdays (< (car weekdays) wkday)) (setq weekdays (cdr weekdays) @@ -1905,14 +1905,15 @@ and ends on the last Sunday of October at 2 a.m." (setq delta (1+ delta))) (setq day (+ day delta))) (let* ((weekdays (nth 3 math-holidays-cache)) - (bweek (- 7 (length weekdays))) - (weeks (1- (/ (+ day (1- bweek)) bweek))) - (wkday (- day 1 (* weeks bweek))) + (bweek (- 7 (length weekdays))) ; Business days in a week, 1..7. + (weeks (/ day bweek)) ; Whole weeks. + (wkday (mod day bweek)) ; Business day in last week, 0..bweek-1 (w 0)) (setq day (+ day (* weeks (length weekdays)))) + ;; Add business days in the last week; `w' is weekday, 0..6. (while (if (memq w weekdays) (setq day (1+ day)) - (> (setq wkday (1- wkday)) 0)) + (>= (setq wkday (1- wkday)) 0)) (setq w (1+ w))) (let ((hours (nth 7 math-holidays-cache))) (if hours diff --git a/test/lisp/calc/calc-tests.el b/test/lisp/calc/calc-tests.el index dce82b6f536..4dded007f79 100644 --- a/test/lisp/calc/calc-tests.el +++ b/test/lisp/calc/calc-tests.el @@ -458,6 +458,82 @@ An existing calc stack is reused, otherwise a new one is created." (calcFunc-choose '(frac -15 2) 3)) (calc-tests--choose -7.5 3)))) +(ert-deftest calc-business-days () + (cl-flet ((m (s) (math-parse-date s)) + (b+ (a b) (calcFunc-badd a b)) + (b- (a b) (calcFunc-bsub a b))) + ;; Sanity check. + (should (equal (m "2020-09-07") '(date 737675))) + + ;; Test with standard business days (Mon-Fri): + (should (equal (b+ (m "2020-09-07") 1) (m "2020-09-08"))) ; Mon->Tue + (should (equal (b+ (m "2020-09-08") 1) (m "2020-09-09"))) ; Tue->Wed + (should (equal (b+ (m "2020-09-09") 1) (m "2020-09-10"))) ; Wed->Thu + (should (equal (b+ (m "2020-09-10") 1) (m "2020-09-11"))) ; Thu->Fri + (should (equal (b+ (m "2020-09-11") 1) (m "2020-09-14"))) ; Fri->Mon + + (should (equal (b+ (m "2020-09-07") 4) (m "2020-09-11"))) ; Mon->Fri + (should (equal (b+ (m "2020-09-07") 6) (m "2020-09-15"))) ; Mon->Tue + + (should (equal (b+ (m "2020-09-12") 1) (m "2020-09-14"))) ; Sat->Mon + (should (equal (b+ (m "2020-09-13") 1) (m "2020-09-14"))) ; Sun->Mon + + (should (equal (b- (m "2020-09-11") 1) (m "2020-09-10"))) ; Fri->Thu + (should (equal (b- (m "2020-09-10") 1) (m "2020-09-09"))) ; Thu->Wed + (should (equal (b- (m "2020-09-09") 1) (m "2020-09-08"))) ; Wed->Tue + (should (equal (b- (m "2020-09-08") 1) (m "2020-09-07"))) ; Tue->Mon + (should (equal (b- (m "2020-09-07") 1) (m "2020-09-04"))) ; Mon->Fri + + (should (equal (b- (m "2020-09-11") 4) (m "2020-09-07"))) ; Fri->Mon + (should (equal (b- (m "2020-09-15") 6) (m "2020-09-07"))) ; Tue->Mon + + (should (equal (b- (m "2020-09-12") 1) (m "2020-09-11"))) ; Sat->Fri + (should (equal (b- (m "2020-09-13") 1) (m "2020-09-11"))) ; Sun->Fri + + ;; Stepping fractional days + (should (equal (b+ (m "2020-09-08 21:00") '(frac 1 2)) + (m "2020-09-09 09:00"))) + (should (equal (b+ (m "2020-09-11 21:00") '(frac 1 2)) + (m "2020-09-14 09:00"))) + (should (equal (b- (m "2020-09-08 21:00") '(frac 1 2)) + (m "2020-09-08 09:00"))) + (should (equal (b- (m "2020-09-14 06:00") '(frac 1 2)) + (m "2020-09-11 18:00"))) + + ;; Test with a couple of extra days off: + (let ((var-Holidays (list 'vec + '(var sat var-sat) '(var sun var-sun) + (m "2020-09-09") (m "2020-09-11")))) + + (should (equal (b+ (m "2020-09-07") 1) (m "2020-09-08"))) ; Mon->Tue + (should (equal (b+ (m "2020-09-08") 1) (m "2020-09-10"))) ; Tue->Thu + (should (equal (b+ (m "2020-09-10") 1) (m "2020-09-14"))) ; Thu->Mon + (should (equal (b+ (m "2020-09-14") 1) (m "2020-09-15"))) ; Mon->Tue + (should (equal (b+ (m "2020-09-15") 1) (m "2020-09-16"))) ; Tue->Wed + + (should (equal (b- (m "2020-09-16") 1) (m "2020-09-15"))) ; Wed->Tue + (should (equal (b- (m "2020-09-15") 1) (m "2020-09-14"))) ; Tue->Mon + (should (equal (b- (m "2020-09-14") 1) (m "2020-09-10"))) ; Mon->Thu + (should (equal (b- (m "2020-09-10") 1) (m "2020-09-08"))) ; Thu->Tue + (should (equal (b- (m "2020-09-08") 1) (m "2020-09-07"))) ; Tue->Mon + ) + + ;; Test with odd non-business weekdays (Tue, Wed, Sat): + (let ((var-Holidays '(vec (var tue var-tue) + (var wed var-wed) + (var sat var-sat)))) + (should (equal (b+ (m "2020-09-07") 1) (m "2020-09-10"))) ; Mon->Thu + (should (equal (b+ (m "2020-09-10") 1) (m "2020-09-11"))) ; Thu->Fri + (should (equal (b+ (m "2020-09-11") 1) (m "2020-09-13"))) ; Fri->Sun + (should (equal (b+ (m "2020-09-13") 1) (m "2020-09-14"))) ; Sun->Mon + + (should (equal (b- (m "2020-09-14") 1) (m "2020-09-13"))) ; Mon->Sun + (should (equal (b- (m "2020-09-13") 1) (m "2020-09-11"))) ; Sun->Fri + (should (equal (b- (m "2020-09-11") 1) (m "2020-09-10"))) ; Fri->Thu + (should (equal (b- (m "2020-09-10") 1) (m "2020-09-07"))) ; Thu->Mon + ) + )) + (provide 'calc-tests) ;;; calc-tests.el ends here -- 2.39.5