Re: Month-week and quarter-week datetrees (RFC and package announcement)

[Jack Kamm <jackkamm@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 1177 bytes --]

Ihor Radchenko <yantar92@posteo.net> writes:

> Jack Kamm <jackkamm@gmail.com> writes:
>
>>> The API of `org-datetree--find-create' is generally very limiting.
>>> It would be nice to come up with something less limiting.
>>
>> Thanks for the feedback -- I'll start working on something along these
>> lines.  Though this might take me a little while since the holiday is
>> ending soon :''-(
>
> Maybe the holiday is just beginning this year? Bumping this thread just
> in case ;)

I attach a pair of patches for this.

The first patch is just a prelude, it adds a couple unit tests for bugs
I noticed in the current implementation.

The second patch is the main work.  It is a substantial reworking of
org-datetree.el that allows for arbitrary number of datetree levels.
For capture datetrees, :tree-type can now be any subset of (year quarter
month week day), and a datetree with the corresponding levels will be
constructed.  Another notable addition is the elisp function
`org-datetree-find-create-hierarchy', which should allow constructing
general datetrees for other calendar systems (e.g. lunar calendars,
university academic calendars, retail 4-4-5 calendars, etc).


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-org-datetree-Add-unit-tests-for-incorrect-sorting.patch --]
[-- Type: text/x-patch, Size: 2547 bytes --]

From b890687ec6732eaf90d4aa03c6ab450504a5988a Mon Sep 17 00:00:00 2001
From: Jack Kamm <jackkamm@gmail.com>
Date: Sun, 29 Dec 2024 00:48:35 -0800
Subject: [PATCH 1/2] org-datetree: Add unit tests for incorrect sorting

*
testing/lisp/test-org-datetree.el (test-org-datetree/find-date-create):
Add test that a subtree is inserted in the correct location, even if
there exists another subtree that looks like a datetree.
(test-org-datetree/find-iso-week-create): Add test that days within a
week spanning 2 years are sorted correctly.
---
 testing/lisp/test-org-datetree.el | 39 +++++++++++++++++++++++++++++++
 1 file changed, 39 insertions(+)

diff --git a/testing/lisp/test-org-datetree.el b/testing/lisp/test-org-datetree.el
index bd06462f2..620a916df 100644
--- a/testing/lisp/test-org-datetree.el
+++ b/testing/lisp/test-org-datetree.el
@@ -108,6 +108,30 @@ (ert-deftest test-org-datetree/find-date-create ()
         (let ((org-datetree-add-timestamp nil))
 	  (org-datetree-find-date-create '(3 29 2012)))
         (org-trim (buffer-string)))))
+    ;; Insert at correct location, even if some other heading has a
+    ;; subtree that looks like a datetree
+    (should
+     (string-match
+      "\\`\\* Dummy heading
+
+\\*\\* 2012
+
+\\* 2012
+
+\\*\\* 2012-03 March
+
+\\*\\*\\* 2012-03-29 .*\\'"
+      (org-test-with-temp-text "\
+* Dummy heading
+
+** 2012
+
+* 2012
+
+** 2012-03 March"
+                               (let ((org-datetree-add-timestamp nil))
+	                         (org-datetree-find-date-create '(3 29 2012)))
+                               (org-trim (buffer-string)))))
     ;; Always leave point at beginning of day entry.
     (should
      (string-match
@@ -188,6 +212,21 @@ (ert-deftest test-org-datetree/find-iso-week-create ()
 	  (org-datetree-find-iso-week-create '(9 1 2015))
 	  (org-datetree-find-iso-week-create '(12 31 2014)))
         (org-trim (buffer-string)))))
+    ;; Sort new entry in correct order within its week when
+    ;; iso-week-year is not calendar year
+    (should
+     (string-match
+      "\\`\\* 2015
+
+\\*\\* 2015-W01
+
+\\*\\*\\* 2014-12-31 .*
+\\*\\*\\* 2015-01-01 .*"
+      (org-test-with-temp-text "* 2015"
+        (let ((org-datetree-add-timestamp nil))
+	  (org-datetree-find-iso-week-create '(1 1 2015))
+	  (org-datetree-find-iso-week-create '(12 31 2014)))
+        (org-trim (buffer-string)))))
     ;; When `org-datetree-add-timestamp' is non-nil, insert a timestamp
     ;; in entry.  When set to `inactive', insert an inactive one.
     (should
-- 
2.47.1


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: 0002-org-datetree-Add-additional-tree-types-e.g.-quarter-.patch --]
[-- Type: text/x-patch, Size: 29206 bytes --]

From b8cc188103baec26c7af337417f8ef84c2af81da Mon Sep 17 00:00:00 2001
From: Jack Kamm <jackkamm@gmail.com>
Date: Sun, 29 Dec 2024 00:52:59 -0800
Subject: [PATCH 2/2] org-datetree: Add additional tree types (e.g. quarter,
 month+week)

* lisp/org-capture.el (org-capture-templates): Update docstring for
new datetree tree-type options.
(org-capture-set-target-location): Allow tree-type to be a set, and
switch to using `org-datetree-find-create-entry' to support this.
* lisp/org-datetree.el: Add requirements on cal-iso and org-element.
(org-datetree-find-date-create,org-datetree-find-month-create): Replace
`org-datetree--find-create-group' with `org-datetree-find-create-entry'.
(org-datetree--find-create-group): Removed in favor of
`org-datetree-find-create-entry'.
(org-datetree-find-iso-week-create): Turn into a wrapper for
`org-datetree-find-create-entry'.
(org-datetree-find-create-entry): Generalizes the now removed
`org-datetree--find-create-group' to handle more general tree type
sets.  It is in turn a wrapper around
`org-datetree-find-create-hierarchy' which allows for constructing
other datetree hierarchies.
(org-datetree--compare-fun-from-regex): Generator for
string-comparison functions, used by `org-datetree-find-create-entry'
when calling `org-datetree-find-create-hierarchy'.
(org-datetree-find-create-hierarchy): New function that allows
constructing generic types of datetrees for other calendar systems.
(org-datetree-insert-line): Delete undocumented helper function.
(org-datetree--find-create-subheading): Generic replacement for
`org-datetree--find-create', that doesn't assume year/month/day
calendar system.

*
testing/lisp/test-org-datetree.el (test-org-datetree/find-quarter-month-create):
Test year-quarter-month datetree.
(test-org-datetree/find-quarter-month-day-create): Test
year-quarter-month-day datetree.
(test-org-datetree/find-quarter-week-create): Test year-quarter-week
datetree.
(test-org-datetree/find-month-week-create): Test year-month-week datetree.
---
 doc/org-manual.org                |  13 +-
 etc/ORG-NEWS                      |  43 ++++
 lisp/org-capture.el               |  13 +-
 lisp/org-datetree.el              | 372 +++++++++++++++++-------------
 testing/lisp/test-org-datetree.el |  48 ++++
 5 files changed, 325 insertions(+), 164 deletions(-)

diff --git a/doc/org-manual.org b/doc/org-manual.org
index 1b3c33f96..93786f3f3 100644
--- a/doc/org-manual.org
+++ b/doc/org-manual.org
@@ -8177,10 +8177,15 @@ Now lets look at the elements of a template definition.  Each entry in
 
   - ~:tree-type~ ::
 
-    Use ~week~ to make a week tree instead of the month-day tree,
-    i.e., place the headings for each day under a heading with the
-    current ISO week.  Use ~month~ to group entries by month
-    only.  Default is to group entries by day.
+    Default is to group entries by day.  Use ~week~ to make a week
+    tree instead of the month-day tree, i.e., place the headings for
+    each day under a heading with the current ISO week.  Use ~month~
+    to group entries by month only.  Use any subset of ~(year quarter
+    month week day)~ to group by the specified levels.  In case
+    ~month~ and ~week~ are both specified, weeks are assigned to the
+    month containing Thursday, to be consistent with the ISO year-week
+    rule.  In case ~quarter~ and ~week~ but not ~month~ are specified,
+    quarters are 13-week periods; otherwise they are 3-month periods.
 
   - ~:unnarrowed~ ::
 
diff --git a/etc/ORG-NEWS b/etc/ORG-NEWS
index 85411ecc1..eb9967e96 100644
--- a/etc/ORG-NEWS
+++ b/etc/ORG-NEWS
@@ -141,6 +141,30 @@ See the new [[info:org#Repeating commands]["Repeating commands"]] section in Org
 Tables copied into the clipboard from LibreOffice Calc documents can
 now be pasted as an Org table using ~yank-media~.
 
+*** New datetree capture ~:tree-type~ options
+:PROPERTIES:
+:CUSTOM_ID: 9.8-datetree-treetype
+:END:
+
+For datetree capture, ~:tree-type~ can now be any subset of ~(year
+quarter month week day)~ to construct a datetree with the specified
+levels.  For back-compatibility, the default value of ~nil~ is an
+alias for ~(year month day)~, ~month~ is an alias for ~(year month)~,
+and ~week~ is an alias for ~(year week day)~.
+
+If ~:tree-type~ is a superset of ~(month week)~, then weeks are
+assigned to the month containing Thursday, to be consistent with the
+ISO-8601 year-week rule.  If ~:tree-type~ contains ~(quarter week)~
+but does not contain ~month~, then quarters are defined as 13-week
+periods (the final quarter of a 53-week year has 14-weeks).
+Otherwise, quarters are defined as 3-month periods.
+
+Furthermore, the new elisp function ~org-datetree-find-create-entry~
+generalizes ~org-datetree-find-date-create~,
+~org-datetree-find-month-create~, and
+~org-datetree-find-iso-week-create~ to handle the new available
+datetree hierarchies.
+
 ** New and changed options
 
 # Changes deadling with changing default values of customizations,
@@ -281,6 +305,18 @@ leave extra prompts after evaluation, and skipping the prompt
 filtering can be more robust for such languages (as this avoids
 removing false positive prompts).
 
+*** Elisp functions for new datetree tree-types
+
+Accompanying the [[#9.8-datetree-treetype][new datetree capture ~:tree-type~ options]], on the
+elisp level ~org-datetree-find-create-entry~ provides the new tree
+type options to generalize ~org-datetree-find-date-create~,
+~org-datetree-find-month-create~, and
+~org-datetree-find-iso-week-create~.
+
+In addition, ~org-datetree-find-create-hierarchy~ provides a mechanism
+for constructing datetrees for other calendar systems (e.g. lunar
+calendar, school semesters, the retail 4-4-5 calendar, etc).
+
 ** Removed or renamed functions and variables
 
 *** ~org-cycle-display-inline-images~ is renamed to ~org-cycle-display-link-previews~
@@ -299,6 +335,13 @@ previews of supported link types besides image links.
 The behavior is unchanged, except in that the new variable now affects
 previews of supported link types besides image links.
 
+*** Obsolete functions and variables removed from ~org-datetree~
+
+Due to the refactoring of ~org-datetree~ to support the [[#9.8-datetree-treetype][new datetree
+capture ~:tree-type~ options]], the internal variable
+~org-datetree-base-level~ has been removed, as well as the
+undocumented helper function ~org-datetree-insert-line~.
+
 ** Miscellaneous
 *** Org mode no longer prevents =flyspell= from spell-checking inside =LOGBOOK= drawers
 
diff --git a/lisp/org-capture.el b/lisp/org-capture.el
index 486304df2..5d6f1df2d 100644
--- a/lisp/org-capture.el
+++ b/lisp/org-capture.el
@@ -293,7 +293,9 @@ (defcustom org-capture-templates nil
 
  :tree-type          When `week', make a week tree instead of the month-day
                      tree.  When `month', make a month tree instead of the
-                     month-day tree.
+                     month-day tree.  When any subset of
+                     `(year quarter month week day)', create a datetree
+                     hierarchy with the specified levels.
 
  :unnarrowed         Do not narrow the target buffer, simply show the
                      full buffer.  Default is to narrow it so that you
@@ -1090,10 +1092,13 @@ (defun org-capture-set-target-location (&optional target)
 	   ;; yesterday, if we are extending dates for a couple of
 	   ;; hours)
 	   (funcall
+            #'org-datetree-find-create-entry
 	    (pcase (org-capture-get :tree-type)
-	      (`week #'org-datetree-find-iso-week-create)
-	      (`month #'org-datetree-find-month-create)
-	      (_ #'org-datetree-find-date-create))
+	      (`week '(year week day))
+	      (`month '(year month))
+	      (`day '(year month day))
+              ((pred not) '(year month day))
+              (grouping grouping))
 	    (calendar-gregorian-from-absolute
 	     (cond
 	      (org-overriding-default-time
diff --git a/lisp/org-datetree.el b/lisp/org-datetree.el
index d0cc1fabb..7101cbf93 100644
--- a/lisp/org-datetree.el
+++ b/lisp/org-datetree.el
@@ -24,23 +24,20 @@
 ;;
 ;;; Commentary:
 
-;; This file contains code to create entries in a tree where the top-level
-;; nodes represent years, the level 2 nodes represent the months, and the
-;; level 1 entries days.
+;; This file contains code to create entries in a tree where the
+;; top-level nodes represent years, the level 2 nodes represent the
+;; months, and the level 1 entries days.  It also implements
+;; extensions to the datetree that allow for other levels such as
+;; quarters and weeks.
 
 ;;; Code:
 
 (require 'org-macs)
 (org-assert-version)
 
+(require 'cal-iso)
 (require 'org)
-
-(defvar org-datetree-base-level 1
-  "The level at which years should be placed in the date tree.
-This is normally one, but if the buffer has an entry with a
-DATE_TREE (or WEEK_TREE for ISO week entries) property (any
-value), the date tree will become a subtree under that entry, so
-the base level will be properly adjusted.")
+(require 'org-element)
 
 (defcustom org-datetree-add-timestamp nil
   "When non-nil, add a time stamp matching date of entry.
@@ -59,174 +56,237 @@ (defun org-datetree-find-date-create (d &optional keep-restriction)
 When it is nil, the buffer will be widened to make sure an existing date
 tree can be found.  If it is the symbol `subtree-at-point', then the tree
 will be built under the headline at point."
-  (org-datetree--find-create-group d 'day keep-restriction))
+  (org-datetree-find-create-entry '(year month day) d keep-restriction))
 
 ;;;###autoload
 (defun org-datetree-find-month-create (d &optional keep-restriction)
   "Find or create a month entry for date D.
 Compared to `org-datetree-find-date-create' this function creates
-entries grouped by month instead of days.
+entries grouped by year-month instead of year-month-day.
 If KEEP-RESTRICTION is non-nil, do not widen the buffer.
 When it is nil, the buffer will be widened to make sure an existing date
 tree can be found.  If it is the symbol `subtree-at-point', then the tree
 will be built under the headline at point."
-  (org-datetree--find-create-group d 'month keep-restriction))
-
-(defun org-datetree--find-create-group
-    (d time-grouping &optional keep-restriction)
-  "Find or create an entry for date D.
-If time-period is day, group entries by day.
-If time-period is month, then group entries by month."
-  (setq-local org-datetree-base-level 1)
-  (save-restriction
-    (if (eq keep-restriction 'subtree-at-point)
-	(progn
-	  (unless (org-at-heading-p) (error "Not at heading"))
-	  (widen)
-	  (org-narrow-to-subtree)
-	  (setq-local org-datetree-base-level
-		      (org-get-valid-level (org-current-level) 1)))
-      (unless keep-restriction (widen))
-      ;; Support the old way of tree placement, using a property
-      (let ((prop (org-find-property "DATE_TREE")))
-	(when prop
-	  (goto-char prop)
-	  (setq-local org-datetree-base-level
-		      (org-get-valid-level (org-current-level) 1))
-	  (org-narrow-to-subtree))))
-    (goto-char (point-min))
-    (let ((year (calendar-extract-year d))
-	  (month (calendar-extract-month d))
-	  (day (calendar-extract-day d)))
-      (org-datetree--find-create
-       "\\([12][0-9]\\{3\\}\\)"
-       year nil nil nil t)
-      (org-datetree--find-create
-       "%d-\\([01][0-9]\\) \\w+"
-       year month nil nil t)
-      (when (eq time-grouping 'day)
-	(org-datetree--find-create
-         "%d-%02d-\\([0123][0-9]\\) \\w+"
-	 year month day nil t)))))
+  (org-datetree-find-create-entry '(year month) d keep-restriction))
 
 ;;;###autoload
 (defun org-datetree-find-iso-week-create (d &optional keep-restriction)
   "Find or create an ISO week entry for date D.
 Compared to `org-datetree-find-date-create' this function creates
-entries ordered by week instead of months.
-When it is nil, the buffer will be widened to make sure an existing date
-tree can be found.  If it is the symbol `subtree-at-point', then the tree
-will be built under the headline at point."
-  (setq-local org-datetree-base-level 1)
-  (save-restriction
-    (if (eq keep-restriction 'subtree-at-point)
-	(progn
-	  (unless (org-at-heading-p) (error "Not at heading"))
-	  (widen)
-	  (org-narrow-to-subtree)
-	  (setq-local org-datetree-base-level
-		      (org-get-valid-level (org-current-level) 1)))
-      (unless keep-restriction (widen))
-      ;; Support the old way of tree placement, using a property
-      (let ((prop (org-find-property "WEEK_TREE")))
-	(when prop
-	  (goto-char prop)
-	  (setq-local org-datetree-base-level
-		      (org-get-valid-level (org-current-level) 1))
-	  (org-narrow-to-subtree))))
-    (goto-char (point-min))
-    (require 'cal-iso)
-    (let* ((year (calendar-extract-year d))
-	   (month (calendar-extract-month d))
-	   (day (calendar-extract-day d))
-	   (time (org-encode-time 0 0 0 day month year))
-	   (iso-date (calendar-iso-from-absolute
-		      (calendar-absolute-from-gregorian d)))
-	   (weekyear (nth 2 iso-date))
-	   (week (nth 0 iso-date)))
-      ;; ISO 8601 week format is %G-W%V(-%u)
-      (org-datetree--find-create
-       "\\([12][0-9]\\{3\\}\\)"
-       weekyear nil nil (format-time-string "%G" time) t)
-      (org-datetree--find-create
-       "%d-W\\([0-5][0-9]\\)"
-       weekyear week nil (format-time-string "%G-W%V" time) t)
-      ;; For the actual day we use the regular date instead of ISO week.
-      (org-datetree--find-create
-       "%d-%02d-\\([0123][0-9]\\) \\w+" year month day nil t))))
+entries grouped by year-week-day instead of year-month-day.  If
+KEEP-RESTRICTION is non-nil, do not widen the buffer.  When it is
+nil, the buffer will be widened to make sure an existing date
+tree can be found.  If it is the symbol `subtree-at-point', then
+the tree will be built under the headline at point."
+  (org-datetree-find-create-entry '(year week day) d keep-restriction))
 
-(defun org-datetree--find-create
-    (regex-template year &optional month day insert match-title)
-  "Find the datetree matched by REGEX-TEMPLATE for YEAR, MONTH, or DAY.
-REGEX-TEMPLATE is passed to `format' with YEAR, MONTH, and DAY as
-arguments.
+;;;###autoload
+(defun org-datetree-find-create-entry
+    (time-grouping d &optional keep-restriction)
+  "Find or create an entry for date D.
+TIME-GROUPING specifies the grouping levels of the datetree, and
+should be a subset of `(year quarter month week day)'.  Weeks are
+assigned to years according to ISO-8601.  If TIME-GROUPING
+contains both `month' and `week', then weeks are assigned to the
+month containing Thursday, for consistency with the ISO-8601
+year-week rule.  If TIME-GROUPING contains `quarter' and `week'
+but not `month', quarters are defined as 13-week periods;
+otherwise they are defined as 3-month periods.
 
-If MATCH-TITLE is non-nil, REGEX-TEMPLATE is matched against
-heading title and the exact regexp matched against heading line is:
+If KEEP-RESTRICTION is non-nil, do not widen the buffer.  When it
+is nil, the buffer will be widened to make sure an existing date
+tree can be found.  If it is the symbol `subtree-at-point', then
+the tree will be built under the headline at point."
+  (let* ((year (calendar-extract-year d))
+	 (month (calendar-extract-month d))
+	 (day (calendar-extract-day d))
+         (time (org-encode-time 0 0 0 day month year))
+         (iso-date (calendar-iso-from-absolute
+		    (calendar-absolute-from-gregorian d)))
+         (week (nth 0 iso-date))
+         (nominal-year
+          (if (memq 'week time-grouping)
+              (nth 2 iso-date)
+            year))
+         (nominal-month
+          (if (memq 'week time-grouping)
+              (calendar-extract-month
+               ;; anchor on Thurs, to be consistent with weekyear
+               (calendar-gregorian-from-absolute
+                (calendar-iso-to-absolute
+                 `(,week 4 ,nominal-year))))
+            month))
+         (quarter (if (and (memq 'week time-grouping)
+                           (not (memq 'month time-grouping)))
+                      (min 4 (1+ (/ (1- week) 13)))
+                    (1+ (/ (1- nominal-month) 3)))))
+    (org-datetree-find-create-hierarchy
+     (append
+      (when (memq 'year time-grouping)
+        (list (list (number-to-string nominal-year)
+                    (org-datetree--compare-fun-from-regex
+                     "\\([12][0-9]\\{3\\}\\)"))))
+      (when (memq 'quarter time-grouping)
+        (list (list (format "%d-Q%d" nominal-year quarter)
+                    (org-datetree--compare-fun-from-regex
+                     "\\([12][0-9]\\{3\\}-Q[1-4]\\)"))))
+      (when (memq 'month time-grouping)
+        (list (list (format-time-string
+                     "%Y-%m %B" (org-encode-time 0 0 0 1 nominal-month
+                                                 nominal-year))
+                    (org-datetree--compare-fun-from-regex
+                     "\\([12][0-9]\\{3\\}-[01][0-9]\\) \\w+"))))
+      (when (memq 'week time-grouping)
+        (list (list (format-time-string "%G-W%V" time)
+                    (org-datetree--compare-fun-from-regex
+                     "\\([12][0-9]\\{3\\}-W[0-5][0-9]\\)"))))
+      (when (memq 'day time-grouping)
+        ;; Use regular date instead of ISO-week year/month
+        (list (list (format-time-string
+                     "%Y-%m-%d %A" (org-encode-time 0 0 0 day month year))
+                    (org-datetree--compare-fun-from-regex
+                     "\\([12][0-9]\\{3\\}-[01][0-9]-[0123][0-9]\\) \\w+")))))
+     keep-restriction
+     ;; Support the old way of tree placement, using a property
+     (cond
+      ((seq-set-equal-p time-grouping '(year month day))
+       "DATE_TREE")
+      ((seq-set-equal-p time-grouping '(year month))
+       "DATE_TREE")
+      ((seq-set-equal-p time-grouping '(year week day))
+       "WEEK_TREE")))
+    (when (memq 'day time-grouping)
+      (when org-datetree-add-timestamp
+        (save-excursion
+          (end-of-line)
+          (insert "\n")
+          (org-indent-line)
+          (org-insert-timestamp
+           (org-encode-time 0 0 0 day month year)
+           nil
+           (eq org-datetree-add-timestamp 'inactive)))))))
 
-  (format org-complex-heading-regexp-format
-          (format regex-template year month day))
+(defun org-datetree--compare-fun-from-regex (sibling-regex)
+  "Construct comparison function based on regular expression.
+SIBLING-REGEX should be a regex that matches the headline and its
+siblings, with 1 match group.  Headlines are compared by the
+lexicographic ordering of match group 1."
+  (lambda (sibling-title new-title)
+    (let ((target-match (and (string-match sibling-regex new-title)
+                             (match-string 1 new-title)))
+          (sibling-match (and (string-match sibling-regex sibling-title)
+                              (match-string 1 sibling-title))))
+      (cond
+       ((not (and target-match sibling-match)) nil)
+       ((string< sibling-match target-match) -1)
+       ((string> sibling-match target-match) 1)
+       (t 0)))))
 
-If MATCH-TITLE is nil, the regexp matched against heading line is
-REGEX-TEMPLATE:
+(defun org-datetree-find-create-hierarchy
+    (hier-pairs &optional keep-restriction legacy-prop)
+  "Insert a new entry into a datetree from the entry's full date hierarchy.
+HIER-PAIRS is a list whose first entry corresponds to the outermost element
+(e.g. year) and last entry corresponds to the innermost (e.g. day).
+Each entry of the list is a pair, the car is the headline for that level
+(e.g. \"2024\" or \"2024-12-28\"), and the cadr is a string
+comparison function for sorting each headline among its siblings.
+The comparison function should take 2 arguments, corresponding to
+the titles of 2 headlines, and return a negative number of the
+first headline precedes the second, a positive number of the
+second has precedence, 0 if the headlines are at the same time,
+or `nil' if a headline isn't a valid datetree subheading.  For
+example, HIER-PAIRS could look like
 
-  (format regex-template year month day)
+   ((\"2024\" compare-year-fun)
+    (\"2024-12 December\" compare-month-fun)
+    (\"2024-12-28 Saturday\" compare-day-fun))
 
-Match group 1 in REGEX-TEMPLATE is compared against the specified date
-component.  If INSERT is non-nil and there is no match then it is
-inserted into the buffer."
-  (when (or month day)
-    (org-narrow-to-subtree))
-  ;; ensure that the first match group in REGEX-TEMPLATE
-  ;; is the first inside `org-complex-heading-regexp-format'
-  (when (and match-title
-             (not (string-match-p "\\\\(\\?1:" regex-template))
-             (string-match "\\\\(" regex-template))
-    (setq regex-template (replace-match "\\(?1:" nil t regex-template)))
-  (let ((re (if match-title
-                (format org-complex-heading-regexp-format
-                        (format regex-template year month day))
-              (format regex-template year month day)))
-	match)
-    (goto-char (point-min))
-    (while (and (setq match (re-search-forward re nil t))
-                (goto-char (match-beginning 1))
-		(< (string-to-number (match-string 1)) (or day month year))))
-    (cond
-     ((not match)
-      (goto-char (point-max))
-      (unless (bolp) (insert "\n"))
-      (org-datetree-insert-line year month day insert))
-     ((= (string-to-number (match-string 1)) (or day month year))
-      (forward-line 0))
-     (t
-      (forward-line 0)
-      (org-datetree-insert-line year month day insert)))))
+where compare-month-fun would be some function where
+(compare-month-fun \"2024-12-December\" \"2024-12-November\") is
+negative, and (compare-month-fun \"2024-12-December\" \"Potato\")
+is nil.
 
-(defun org-datetree-insert-line (year &optional month day text)
-  (delete-region (save-excursion (skip-chars-backward " \t\n") (point)) (point))
-  (when (org--blank-before-heading-p) (insert "\n"))
-  (insert "\n" (make-string org-datetree-base-level ?*) " \n")
-  (backward-char)
-  (when month (org-do-demote))
-  (when day (org-do-demote))
-  (if text
-      (insert text)
-    (insert (format "%d" year))
-    (when month
+If KEEP-RESTRICTION is non-nil, do not widen the buffer.
+When it is nil, the buffer will be widened to make sure an existing date
+tree can be found.  If it is the symbol `subtree-at-point', then the tree
+will be built under the headline at point.
+
+If LEGACY-PROP is non-nil, the tree is located by searching for a
+headline with property LEGACY-PROP, supporting the old way of
+tree placement via a property."
+  (let (tree)
+    (save-restriction
+      ;; get the datetree base and narrow to it
+      (if (eq keep-restriction 'subtree-at-point)
+          (progn
+	    (unless (org-at-heading-p) (error "Not at heading"))
+	    (widen)
+	    (org-narrow-to-subtree)
+            (setq tree (car (org-element-contents (org-element-parse-buffer 'headline)))))
+        (unless keep-restriction (widen))
+        ;; Support the old way of tree placement, using a property
+        (let ((prop (and legacy-prop (org-find-property legacy-prop))))
+          (if prop
+              (progn
+                (goto-char prop)
+	        (org-narrow-to-subtree)
+                (setq tree (car (org-element-contents (org-element-parse-buffer 'headline)))))
+            (setq tree (org-element-parse-buffer)))))
+      (cl-loop
+       for pair in hier-pairs
+       do
+       (setq tree
+             (org-datetree--find-create-subheading
+              (cadr pair) (car pair) tree)))
+      tree)))
+
+(defun org-datetree--find-create-subheading
+    (compare-fun new-title tree)
+  "Find datetree subheading, or create it if it doesn't exist.
+After insertion, move point to beginning of the subheading, and
+narrow to its subtree.  NEW-TITLE is the subheading to be found
+or created.  TREE is the parent headline, or an element of type
+`org-data' if NEW-TITLE is to be at level 1.  COMPARE-FUN is a
+function of 2 arguments for comparing headline titles; it should
+return a negative number if the first headline precedes the
+second, a positive number if the second number has precedence, 0
+if the headlines are at the same time, and `nil' if a headline
+isn't a valid datetree subheading at this level."
+  (let* ((level (if (eq (org-element-type tree) 'org-data)
+                    1
+                  (1+ (org-element-property :level tree))))
+         (sibling (org-element-map tree 'headline
+                    (lambda (d)
+                      (when (= (org-element-property :level d) level)
+                        (let ((compare-result
+                               (funcall compare-fun
+                                        (org-element-property :raw-value d)
+                                        new-title)))
+                          (and compare-result (>= compare-result 0) d))))
+                    nil t)))
+    ;; go to headline, or first successor sibling, or end of buffer
+    (if sibling
+        (goto-char (org-element-property :begin sibling))
+      (goto-char (point-max))
+      (unless (bolp) (insert "\n")))
+    (if (and sibling
+             (= 0 (funcall compare-fun
+                           (org-element-property :raw-value sibling)
+                           new-title)))
+        ;; narrow and return the matched headline
+        (progn
+          (org-narrow-to-subtree)
+          sibling)
+      ;; insert new headline, narrow, and return it
+      (delete-region (save-excursion (skip-chars-backward " \t\n") (point)) (point))
+      (when (org--blank-before-heading-p) (insert "\n"))
       (insert
-       (if day
-	   (format-time-string "-%m-%d %A" (org-encode-time 0 0 0 day month year))
-	 (format-time-string "-%m %B" (org-encode-time 0 0 0 1 month year))))))
-  (when (and day org-datetree-add-timestamp)
-    (save-excursion
-      (insert "\n")
-      (org-indent-line)
-      (org-insert-timestamp
-       (org-encode-time 0 0 0 day month year)
-       nil
-       (eq org-datetree-add-timestamp 'inactive))))
-  (forward-line 0))
+       (format "\n%s %s\n"
+               (make-string (if org-odd-levels-only (1- (* 2 level)) level) ?*)
+               new-title))
+      (forward-line -1)
+      (org-narrow-to-subtree)
+      (org-element-at-point))))
 
 (defun org-datetree-file-entry-under (txt d)
   "Insert a node TXT into the date tree under date D."
diff --git a/testing/lisp/test-org-datetree.el b/testing/lisp/test-org-datetree.el
index 620a916df..585bd692c 100644
--- a/testing/lisp/test-org-datetree.el
+++ b/testing/lisp/test-org-datetree.el
@@ -160,6 +160,54 @@ (ert-deftest test-org-datetree/find-month-create ()
 	  (org-datetree-find-month-create '(3 29 2012)))
         (org-trim (buffer-string)))))))
 
+(ert-deftest test-org-datetree/find-quarter-month-create ()
+  "Test `org-datetree-find-quarter-month-create' specifications."
+  (let ((org-blank-before-new-entry '((heading . t))))
+    ;; When date is missing, create it with the entry under month.
+    (should
+     (string-match
+      "\\`\\* 2012\n\n\\*\\* 2012-Q1\n\n\\*\\*\\* 2012-03 .*\\'"
+      (org-test-with-temp-text ""
+        (let ((org-datetree-add-timestamp nil))
+	  (org-datetree-find-create-entry '(year quarter month) '(3 29 2012)))
+        (org-trim (buffer-string)))))))
+
+(ert-deftest test-org-datetree/find-quarter-month-day-create ()
+  "Test `org-datetree-find-quarter-month-day-create' specifications."
+  (let ((org-blank-before-new-entry '((heading . t))))
+    ;; When date is missing, create it with the entry under month.
+    (should
+     (string-match
+      "\\`\\* 2012\n\n\\*\\* 2012-Q1\n\n\\*\\*\\* 2012-03 .*\n\n\\*\\*\\*\\* 2012-03-29 .*\\'"
+      (org-test-with-temp-text ""
+        (let ((org-datetree-add-timestamp nil))
+	  (org-datetree-find-create-entry '(year quarter month day) '(3 29 2012)))
+        (org-trim (buffer-string)))))))
+
+(ert-deftest test-org-datetree/find-quarter-week-create ()
+  "Test `org-datetree-find-quarter-week-create' specifications."
+  (let ((org-blank-before-new-entry '((heading . t))))
+    ;; When date is missing, create it with the entry under month.
+    (should
+     (string-match
+      "\\`\\* 2024\n\n\\*\\* 2024-Q4\n\n\\*\\*\\* 2024-W52\\'"
+      (org-test-with-temp-text ""
+        (let ((org-datetree-add-timestamp nil))
+	  (org-datetree-find-create-entry '(year quarter week) '(12 27 2024)))
+        (org-trim (buffer-string)))))))
+
+(ert-deftest test-org-datetree/find-month-week-create ()
+  "Test `org-datetree-find-month-week-create' specifications."
+  (let ((org-blank-before-new-entry '((heading . t))))
+    ;; When date is missing, create it with the entry under month.
+    (should
+     (string-match
+      "\\`\\* 2024\n\n\\*\\* 2024-12 .*\n\n\\*\\*\\* 2024-W52\\'"
+      (org-test-with-temp-text ""
+        (let ((org-datetree-add-timestamp nil))
+	  (org-datetree-find-create-entry '(year month week) '(12 27 2024)))
+        (org-trim (buffer-string)))))))
+
 (ert-deftest test-org-datetree/find-iso-week-create ()
   "Test `org-datetree-find-iso-date-create' specification."
   (let ((org-blank-before-new-entry '((heading . t))))
-- 
2.47.1