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

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

[Jack Kamm]

I have started a package that defines org-capture datetrees following
year-quarter-week and year-month-week formats:

https://gitlab.com/jackkamm/org-grouped-weektree

I'd appreciate feedback on 2 points:

1. Are any of these datetree formats worth upstreaming into org-mode
   proper?

2. Can we add a public interface for `org-datetree--find-create', and
   are there any suggestions on how to do it?

Regarding #2, an ugly aspect of my current implementation is the abuse
of the private function `org-datetree--find-create'. I also pass in
the week or quarter for the DAY and MONTH arguments of this function,
though I note that `org-datetree-find-iso-week-create' does something
similar in its implementation.

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

[Ihor Radchenko]

Jack Kamm <jackkamm@gmail.com> writes:

> https://gitlab.com/jackkamm/org-grouped-weektree
>
> I'd appreciate feedback on 2 points:
>
> 1. Are any of these datetree formats worth upstreaming into org-mode
>    proper?

That would make sense.

> 2. Can we add a public interface for `org-datetree--find-create', and
>    are there any suggestions on how to do it?
>
> Regarding #2, an ugly aspect of my current implementation is the abuse
> of the private function `org-datetree--find-create'. I also pass in
> the week or quarter for the DAY and MONTH arguments of this function,
> though I note that `org-datetree-find-iso-week-create' does something
> similar in its implementation.

The API of `org-datetree--find-create' is generally very limiting.
It would be nice to come up with something less limiting.

-- 
Ihor Radchenko // yantar92,
Org mode contributor,
Learn more about Org mode at <https://orgmode.org/>.
Support Org development at <https://liberapay.com/org-mode>,
or support my work at <https://liberapay.com/yantar92>

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

[Jack Kamm]

Ihor Radchenko <yantar92@posteo.net> writes:

>> https://gitlab.com/jackkamm/org-grouped-weektree
>>
>> I'd appreciate feedback on 2 points:
>>
>> 1. Are any of these datetree formats worth upstreaming into org-mode
>>    proper?
>
> That would make sense.
>
>> 2. Can we add a public interface for `org-datetree--find-create', and
>>    are there any suggestions on how to do it?
>>
>> Regarding #2, an ugly aspect of my current implementation is the abuse
>> of the private function `org-datetree--find-create'. I also pass in
>> the week or quarter for the DAY and MONTH arguments of this function,
>> though I note that `org-datetree-find-iso-week-create' does something
>> similar in its implementation.
>
> 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 :''-(

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

[Ihor Radchenko]

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 ;)

-- 
Ihor Radchenko // yantar92,
Org mode maintainer,
Learn more about Org mode at <https://orgmode.org/>.
Support Org development at <https://liberapay.com/org-mode>,
or support my work at <https://liberapay.com/yantar92>

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

[Jack Kamm]

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 ;)

Hi Ihor -- Sorry for the delayed response.  I'm working on this now and
should have something ready for review in the coming days.

Best,
Jack

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

[Jack Kamm]

[-- 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

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

[Ihor Radchenko]

Jack Kamm <jackkamm@gmail.com> writes:

> I attach a pair of patches for this.

Thanks! See my comments inline.

> +(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."

Please also document how `org-datetree-add-timestamp' affects this function.

> +     ;; 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")))

It would be a good idea to add a few tests for this scenario.
To make sure that refactoring did not break things.

> +        ;; 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)))))

Why do you need object granularity by default (second call to
`org-element-parse-buffer')?
Also, more importantly, do you have to run the full parsing here? Maybe
utilize `org-element-cache-map' instead? Full parsing is going to be
much slower.

> +      (cl-loop
> +       for pair in hier-pairs
> +       do
> +       (setq tree
> +             (org-datetree--find-create-subheading
> +              (cadr pair) (car pair) tree)))

It is undocumented in the `org-datetree--find-create-subheading'
docstring that it returns something.

-- 
Ihor Radchenko // yantar92,
Org mode maintainer,
Learn more about Org mode at <https://orgmode.org/>.
Support Org development at <https://liberapay.com/org-mode>,
or support my work at <https://liberapay.com/yantar92>

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

[Jack Kamm]

Ihor Radchenko <yantar92@posteo.net> writes:

>> +        ;; 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)))))
>
> Why do you need object granularity by default (second call to
> `org-element-parse-buffer')?
> Also, more importantly, do you have to run the full parsing here? Maybe
> utilize `org-element-cache-map' instead? Full parsing is going to be
> much slower.

We don't need object granularity, that was an oversight on my part --
should have specified headline granularity.

Does `org-element-cache-map' traverse elements in the order they're in
the buffer?  That is something we need for this.

On my working branch I have an earlier commit that implements many of
the improvements here but using the old regexp search way instead of the
org-element way.  Would it be worth reverting to that point?
Specifically, the new `org-datetree-find-create-entry' that allows for
nested years/quarters/months/weeks/days is still pretty straightforward
to implement in the regexp approach.  The more general
`org-datetree-find-create-hierarchy' (that allows elisp hackers to build
new kinds of datetrees) might be trickier without org-element, but we
could also defer that for future work.

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

[Ihor Radchenko]

Jack Kamm <jackkamm@gmail.com> writes:

> Does `org-element-cache-map' traverse elements in the order they're in
> the buffer?  That is something we need for this.

Yes, it does.
You can even edit buffer along the way.
`org-element-cache-map' combines regexp search and parser cache trying
to be as fast as possible.

> On my working branch I have an earlier commit that implements many of
> the improvements here but using the old regexp search way instead of the
> org-element way.  Would it be worth reverting to that point?
> Specifically, the new `org-datetree-find-create-entry' that allows for
> nested years/quarters/months/weeks/days is still pretty straightforward
> to implement in the regexp approach.  The more general
> `org-datetree-find-create-hierarchy' (that allows elisp hackers to build
> new kinds of datetrees) might be trickier without org-element, but we
> could also defer that for future work.

I believe that `org-element-cache-map' should be good enough to do
everything.

-- 
Ihor Radchenko // yantar92,
Org mode maintainer,
Learn more about Org mode at <https://orgmode.org/>.
Support Org development at <https://liberapay.com/org-mode>,
or support my work at <https://liberapay.com/yantar92>

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

[Jack Kamm]

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

Thanks for the feedback. I attach a squashed updated patch for part 2.
You can also see the unsquashed changes at https://github.com/jackkamm/org-mode/tree/2024-grouped-weektree-rebase

>> +(defun org-datetree-find-create-entry
> Please also document how `org-datetree-add-timestamp' affects this function.

Done.  On reviewing this I also found a bug (datestamp added again if
entry already existed) -- I fixed it and added a unit test.

>> +     ;; 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")))
>
> It would be a good idea to add a few tests for this scenario.
> To make sure that refactoring did not break things.

There was already a couple tests for DATE_TREE and WEEK_TREE, but I've
added a few more now, mainly around finding existing headings (the
previous tests only created new headings under the DATE_TREE or
WEEK_TREE).

> Why do you need object granularity by default (second call to
> `org-element-parse-buffer')?
> Also, more importantly, do you have to run the full parsing here? Maybe
> utilize `org-element-cache-map' instead? Full parsing is going to be
> much slower.

I've switched to `org-element-cache-map' now -- thanks for the info
about it.

> It is undocumented in the `org-datetree--find-create-subheading'
> docstring that it returns something.

I changed the return behavior and documented it.  It now returns non-nil
if the subheading already exists -- this is needed to prevent
adding a datestamp twice when `org-datetree-add-timestamp'.

Finally, I made one more substantial change -- I now allow :tree-type to
be a function in the org-capture template.  This allows using new types
of datetrees from `org-datetree-find-create-hierarchy' with org-capture.
Relatedly, I made `org-datetree-comparefun-from-regex' public to help
with building new types of datetrees.


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

From b8447f23c5618239bb3926a59d111fd21d985afe 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: Declare `org-datetree-find-create-hierarchy'.
(org-capture-templates): Update docstring for
new datetree tree-type options.
(org-capture-set-target-location): Allow tree-type to be a set
or function, and call `org-datetree-find-create-entry' or
`org-datetree-find-create-hierarchy' in those cases.
* 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-comparefun-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-capture.el (test-org-capture/entry): Add tests
for datetree capture with list or function :tree-type.
*
testing/lisp/test-org-datetree.el  (test-org-datetree/find-date-create):
Add test to not add the timestamp twice.  Add additional test for
legacy DATE_TREE method.
(test-org-datetree/find-month-create): Add tests for legacy DATE_TREE
method.
(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.
(test-org-datetree/find-iso-week-create): Additional test for legacy
WEEK_TREE method.
---
 doc/org-manual.org                |  18 +-
 etc/ORG-NEWS                      |  39 +++
 lisp/org-capture.el               |  27 +-
 lisp/org-datetree.el              | 399 ++++++++++++++++++------------
 testing/lisp/test-org-capture.el  |  45 ++++
 testing/lisp/test-org-datetree.el | 103 +++++++-
 6 files changed, 466 insertions(+), 165 deletions(-)

diff --git a/doc/org-manual.org b/doc/org-manual.org
index 1b3c33f96..f59f46f91 100644
--- a/doc/org-manual.org
+++ b/doc/org-manual.org
@@ -8177,10 +8177,20 @@ 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.
+
+    #+findex: org-datetree-find-create-hierarchy
+    ~:tree-type~ can also be a function, in which it should take the
+    date as an argument and generate a list of pairs for
+    ~org-datetree-find-create-hierarchy~.
 
   - ~:unnarrowed~ ::
 
diff --git a/etc/ORG-NEWS b/etc/ORG-NEWS
index 85411ecc1..8779bdad1 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.
+
+Additionally, ~:tree-type~ can be a function, in which case it should
+take the date as an argument, and generate a list of pairs for
+~org-datetree-find-create-hierarchy~.  This allows for creating new
+types of datetrees (e.g. for lunar calendars, academic calendars,
+retail 4-4-5 calendars, etc).
+
 ** New and changed options
 
 # Changes deadling with changing default values of customizations,
@@ -281,6 +305,14 @@ 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~ and
+~org-datetree-find-create-hierarchy~ generalize
+~org-datetree-find-date-create~, ~org-datetree-find-month-create~, and
+~org-datetree-find-iso-week-create~ to new datetree types.
+
 ** Removed or renamed functions and variables
 
 *** ~org-cycle-display-inline-images~ is renamed to ~org-cycle-display-link-previews~
@@ -299,6 +331,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..818ed179b 100644
--- a/lisp/org-capture.el
+++ b/lisp/org-capture.el
@@ -59,6 +59,7 @@ (declare-function org-at-table-p "org-table" (&optional table-type))
 (declare-function org-clock-update-mode-line "org-clock" (&optional refresh))
 (declare-function org-datetree-find-date-create "org-datetree" (date &optional keep-restriction))
 (declare-function org-datetree-find-month-create "org-datetree" (d &optional keep-restriction))
+(declare-function org-datetree-find-create-hierarchy "org-datetree" (hier-pairs &optional keep-restriction legacy-prop))
 (declare-function org-decrypt-entry "org-crypt" ())
 (declare-function org-element-at-point "org-element" (&optional pom cached-only))
 (declare-function org-element-lineage "org-element-ast" (datum &optional types with-self))
@@ -293,7 +294,13 @@ (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.  Can also be a function, in which
+                     case it should take the date as an argument
+                     and generate a list of pairs to pass to
+                     `org-datetree-find-create-hierarchy'.
 
  :unnarrowed         Do not narrow the target buffer, simply show the
                      full buffer.  Default is to narrow it so that you
@@ -1090,10 +1097,22 @@ (defun org-capture-set-target-location (&optional target)
 	   ;; yesterday, if we are extending dates for a couple of
 	   ;; hours)
 	   (funcall
-	    (pcase (org-capture-get :tree-type)
-	      (`week #'org-datetree-find-iso-week-create)
+            (pcase (org-capture-get :tree-type)
+              (`week #'org-datetree-find-iso-week-create)
 	      (`month #'org-datetree-find-month-create)
-	      (_ #'org-datetree-find-date-create))
+	      (`day #'org-datetree-find-date-create)
+              ((pred not) #'org-datetree-find-date-create)
+              ;; NOTE function case needs to be before list case to
+              ;; handle lambda forms correctly
+              ((and (pred functionp) fun)
+               (lambda (d keep-restriction)
+                 (org-datetree-find-create-hierarchy
+                  (funcall fun d) keep-restriction)))
+              ((and (pred listp) grouping)
+               (lambda (d keep-restriction)
+                 (funcall #'org-datetree-find-create-entry grouping
+                          d keep-restriction)))
+              (_ (error "Unrecognized :tree-type")))
 	    (calendar-gregorian-from-absolute
 	     (cond
 	      (org-overriding-default-time
diff --git a/lisp/org-datetree.el b/lisp/org-datetree.el
index d0cc1fabb..4da3c8dc8 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,264 @@ (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.
+Moves point to the beginning of the entry.
 
-If MATCH-TITLE is non-nil, REGEX-TEMPLATE is matched against
-heading title and the exact regexp matched against heading line is:
+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.
 
-  (format org-complex-heading-regexp-format
-          (format regex-template 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.
 
-If MATCH-TITLE is nil, the regexp matched against heading line is
-REGEX-TEMPLATE:
+If `org-datetree-add-timestamp' is non-nil and TIME-GROUPING
+includes `day' and a new entry is created, adds a time stamp
+after the new headline."
+  (when-let ((setdiff (seq-difference time-grouping
+                                      '(year quarter month week day))))
+    (error (format "Unrecognized datetree grouping elements %s" setdiff)))
+  (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))))
+         (found-p
+          (org-datetree-find-create-hierarchy
+           (append
+            (when (memq 'year time-grouping)
+              (list (list (number-to-string nominal-year)
+                          (org-datetree-comparefun-from-regex
+                           "\\([12][0-9]\\{3\\}\\)"))))
+            (when (memq 'quarter time-grouping)
+              (list (list (format "%d-Q%d" nominal-year quarter)
+                          (org-datetree-comparefun-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-comparefun-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-comparefun-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-comparefun-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 (and (not found-p) 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 regex-template year month day)
+(defun org-datetree-comparefun-from-regex (sibling-regex)
+  "Construct comparison function based on regular expression.
+The generated comparison function can be used with
+`org-datetree-find-create-hierarchy'.  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.  The generated function returns -1 if the first
+argument is earlier, 1 if later, 0 if equal, or nil if either
+argument doesn't match."
+  (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)))))
 
-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)))))
+(defun org-datetree-find-create-hierarchy
+    (hier-pairs &optional keep-restriction legacy-prop)
+  "Find or create entry in datetree using the full date hierarchy.
+Moves point to the beginning of the entry.  Returns non-nil if an
+existing entry was found, or nil if a new entry was created.
+
+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 Saturday\"), 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 if the first headline is earlier, a positive number if the
+second headline is earlier, 0 or t 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
 
-(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
+   ((\"2024\" compare-year-fun)
+    (\"2024-12 December\" compare-month-fun)
+    (\"2024-12-28 Saturday\" compare-day-fun))
+
+where compare-month-fun would be some function where
+(compare-month-fun \"2024-11 November\" \"2024-12 December\") is
+negative, and (compare-month-fun \"2024-12-December\" \"Potato\")
+is nil.  One way to construct such a comparison function is with
+`org-datetree-comparefun-from-regex'.
+
+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 ((level 1)
+        found-p)
+    (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 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 (and legacy-prop (org-find-property legacy-prop))))
+          (when prop
+            (progn
+              (goto-char prop)
+	      (org-narrow-to-subtree)
+              (setq level (org-get-valid-level (org-current-level) 1))))))
+      (cl-loop
+       for pair in hier-pairs
+       do
+       (setq found-p (org-datetree--find-create-subheading
+                      (cadr pair) (car pair) level))
+       (setq level (1+ level))))
+    found-p))
+
+(defun org-datetree--find-create-subheading
+    (compare-fun new-title level)
+  "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.  Returns non-nil if the heading was found,
+or nil if a new heading was created.
+
+NEW-TITLE is the title of the subheading to be found or created.
+LEVEL is the level of the headline to be found or created.
+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 or t if the headlines are at the same time, and nil
+if a headline isn't a valid datetree subheading at this level."
+  (let* ((nstars (if org-odd-levels-only (1- (* 2 level)) level))
+         (heading-re (format "^\\*\\{%d\\}" nstars))
+         (sibling (car (org-element-cache-map
+                        (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
+                                   (or (eq compare-result t) (>= compare-result 0))
+                                   d))))
+                        :granularity 'headline
+                        :restrict-elements '(headline)
+                        :next-re heading-re
+                        :fail-re heading-re
+                        :narrow t
+                        :limit-count 1))))
+    ;; 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
+             (memq (funcall compare-fun
+                            (org-element-property :raw-value sibling)
+                            new-title)
+                   '(0 t)))
+        ;; narrow and return the matched headline
+        (progn
+          (org-narrow-to-subtree)
+          t)
+      ;; 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 nstars ?*)
+               new-title))
+      (forward-line -1)
+      (org-narrow-to-subtree)
+      nil)))
 
 (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-capture.el b/testing/lisp/test-org-capture.el
index 4aed0e99e..ff7e242d2 100644
--- a/testing/lisp/test-org-capture.el
+++ b/testing/lisp/test-org-capture.el
@@ -324,6 +324,51 @@ (ert-deftest test-org-capture/entry ()
 	  (insert "Capture text")
 	  (org-capture-finalize)))
       (buffer-string))))
+  ;; test datetree capture with list tree-type
+  (should
+   (equal
+    "* A\n** B\n*** 2024\n**** 2024-Q2\n***** 2024-06 June\n****** 2024-06-16 Sunday\n******* H1 Capture text\n** C\n"
+    (org-test-with-temp-text-in-file "* A\n** B\n** C\n"
+      (let* ((file (buffer-file-name))
+            (org-capture-templates
+             `(("t"
+                 "Todo"
+                 entry
+                 (file+olp+datetree ,file (lambda ()
+                                            (should (equal ,file (buffer-file-name)))
+                                            '("A" "B")))
+                 "* H1 %?"
+                 :tree-type
+                 (year quarter month day)))))
+       (org-test-at-time "2024-06-16"
+                         (org-capture nil "t")
+                         (insert "Capture text")
+                         (org-capture-finalize)))
+      (buffer-string))))
+  ;; test datetree capture with function tree-type
+  (should
+   (equal
+    "* A\n** B\n*** 2024\n**** 06\n***** 16\n****** H1 Capture text\n** C\n"
+    (org-test-with-temp-text-in-file "* A\n** B\n** C\n"
+      (let* ((file (buffer-file-name))
+            (org-capture-templates
+             `(("t"
+                 "Todo"
+                 entry
+                 (file+olp+datetree ,file (lambda ()
+                                            (should (equal ,file (buffer-file-name)))
+                                            '("A" "B")))
+                 "* H1 %?"
+                 :tree-type
+                 (lambda (d)
+                   `((,(format "%d" (calendar-extract-year d)) compare-strings)
+                     (,(format "%02d" (calendar-extract-month d)) compare-strings)
+                     (,(format "%02d" (calendar-extract-day d)) compare-strings)))))))
+       (org-test-at-time "2024-06-16"
+                         (org-capture nil "t")
+                         (insert "Capture text")
+                         (org-capture-finalize)))
+      (buffer-string))))
   (should
    (equal
     "* A\n** B\n*** 2024\n**** 2024-06 June\n***** 2024-06-16 Sunday\n****** H1 Capture text\n** C\n"
diff --git a/testing/lisp/test-org-datetree.el b/testing/lisp/test-org-datetree.el
index 620a916df..d6ba32887 100644
--- a/testing/lisp/test-org-datetree.el
+++ b/testing/lisp/test-org-datetree.el
@@ -91,6 +91,15 @@ (ert-deftest test-org-datetree/find-date-create ()
         (let ((org-datetree-add-timestamp 'inactive))
 	  (org-datetree-find-date-create '(3 29 2012)))
         (org-trim (buffer-string)))))
+    ;; don't add the timestamp twice
+    (should
+     (string-match
+      "\\`\\* 2012\n\n\\*\\* 2012-03 .*\n\n\\*\\*\\* \\(2012-03-29\\) .*\n[ \t]*<\\1.*?>\\'"
+      (org-test-with-temp-text "* 2012\n"
+        (let ((org-datetree-add-timestamp t))
+	  (org-datetree-find-date-create '(3 29 2012))
+          (org-datetree-find-date-create '(3 29 2012)))
+        (org-trim (buffer-string)))))
     ;; Insert at top level, unless some node has DATE_TREE property.  In
     ;; this case, date tree becomes one of its sub-trees.
     (should
@@ -108,6 +117,15 @@ (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)))))
+    ;; Do not create new year/month node in DATE_TREE when it already exists
+    (should
+     (string-match
+      "\\`\\* H1\n\n\\*\\* H1.1\n:PROPERTIES:\n:DATE_TREE: t\n:END:\n\n\\*\\*\\* 2012\n\n\\*\\*\\*\\* 2012-03 month\n\n\\*\\*\\*\\*\\* 2012-03-29 .*\n\n\\* H2\\'"
+      (org-test-with-temp-text
+	  "* H1\n\n** H1.1\n:PROPERTIES:\n:DATE_TREE: t\n:END:\n\n*** 2012\n\n**** 2012-03 month\n\n* H2"
+        (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
@@ -155,9 +173,83 @@ (ert-deftest test-org-datetree/find-month-create ()
     (should
      (string-match
       "\\`\\* 2012\n\n\\*\\* 2012-03 .*\\'"
+      (org-test-with-temp-text ""
+                               (let ((org-datetree-add-timestamp nil))
+	                         (org-datetree-find-month-create '(3 29 2012)))
+                               (org-trim (buffer-string)))))
+    ;; Insert at top level, unless some node has DATE_TREE property.  In
+    ;; this case, date tree becomes one of its sub-trees.
+    (should
+     (string-match
+      "\\* 2012"
+      (org-test-with-temp-text "* Top"
+                               (let ((org-datetree-add-timestamp nil))
+	                         (org-datetree-find-month-create '(3 29 2012)))
+                               (org-trim (buffer-string)))))
+    (should
+     (string-match
+      "\\*\\* H1.1\n:PROPERTIES:\n:DATE_TREE: t\n:END:\n\n\\*\\*\\* 2012"
+      (org-test-with-temp-text
+       "* H1\n\n** H1.1\n:PROPERTIES:\n:DATE_TREE: t\n:END:\n\n* H2"
+       (let ((org-datetree-add-timestamp nil))
+	 (org-datetree-find-month-create '(3 29 2012)))
+       (org-trim (buffer-string)))))
+    ;; Do not create new year/month node in DATE_TREE when it already exists
+    (should
+     (string-match
+      "\\`\\* H1\n\n\\*\\* H1.1\n:PROPERTIES:\n:DATE_TREE: t\n:END:\n\n\\*\\*\\* 2012\n\n\\*\\*\\*\\* 2012-03 month\n\n\\* H2\\'"
+      (org-test-with-temp-text
+       "* H1\n\n** H1.1\n:PROPERTIES:\n:DATE_TREE: t\n:END:\n\n*** 2012\n\n**** 2012-03 month\n\n* H2"
+       (let ((org-datetree-add-timestamp nil))
+	 (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-month-create '(3 29 2012)))
+	  (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 ()
@@ -260,6 +352,15 @@ (ert-deftest test-org-datetree/find-iso-week-create ()
         (let ((org-datetree-add-timestamp nil))
 	  (org-datetree-find-iso-week-create '(12 31 2014)))
         (org-trim (buffer-string)))))
+    ;; Do not create new year/week node when it exists in WEEK_TREE
+    (should
+     (string-match
+      "\\`\\* H1\n\\*\\* H1.1\n:PROPERTIES:\n:WEEK_TREE: t\n:END:\n\n\\*\\*\\* 2015\n\n\\*\\*\\*\\* 2015-W01\n\n\\*\\*\\*\\*\\* 2014-12-31 .*\n\n\\* H2\\'"
+      (org-test-with-temp-text
+	  "* H1\n** H1.1\n:PROPERTIES:\n:WEEK_TREE: t\n:END:\n\n*** 2015\n\n**** 2015-W01\n\n* H2"
+        (let ((org-datetree-add-timestamp nil))
+	  (org-datetree-find-iso-week-create '(12 31 2014)))
+        (org-trim (buffer-string)))))
     ;; Always leave point at beginning of day entry.
     (should
      (string-match
-- 
2.47.1

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

[Ihor Radchenko]

Jack Kamm <jackkamm@gmail.com> writes:

> Thanks for the feedback. I attach a squashed updated patch for part 2.
> You can also see the unsquashed changes at https://github.com/jackkamm/org-mode/tree/2024-grouped-weektree-rebase
> ...

I have no further comments.
Feel free to push.

-- 
Ihor Radchenko // yantar92,
Org mode maintainer,
Learn more about Org mode at <https://orgmode.org/>.
Support Org development at <https://liberapay.com/org-mode>,
or support my work at <https://liberapay.com/yantar92>