Issue archiving when maintaining org-mode subtree structure

Question

I'm trying to archive DONE org-mode tasks while maintaining the subtree structure. There's a partial solution for what I'm trying to attempt at https://gist.github.com/edgimar/072d99d8650abe81a9fe7c8687c0c993.

This could be a really nice solution, however, it only works for me when executing on a single DONE task. If I try extending it to all DONE tasks in a subtree using org-map-entries as shown below, it creates a new top-level * ARCHIVED heading each time it's run. Is there a way to avoid this unwanted behavior?

Example of undesired behavior with org-map-entries

Define function to operate on all DONE tasks in current subtree:

(defun org-archive-done-tasks ()
  (interactive)
  (org-map-entries 'org-archive-subtree-hierarchical "/DONE" 'tree))

Note: org-archive-subtree-hierarchical defined in above link.

Now if I take the following buffer

* Project 1
** TODO Task 1
** TODO Task 2
** TODO Task 3

and mark Task 1 as DONE, run org-archive-done-tasks on Project 1, and then do the same for Task 2, I get

* ARCHIVED
** Project 1
*** DONE Task 1

* ARCHIVED
** Project 1
*** DONE Task 2

* Project 1
** TODO Task 3

Here is the desired result, which is what would happen if org-archive-subtree-hierarchical were run directly on ** DONE Task 1 and then ** DONE Task 2 (as children of * Project 1)

* ARCHIVED
** Project 1
*** DONE Task 1
*** DONE Task 2

* Project 1
** TODO Task 3

The whole point is to avoid having to run such an archive command on each individual DONE task. Is the desired behavior possible using something similar to org-map-entries? Is there a better method of executing org-archive-subtree-hierarchical on all DONE tasks in a subtree multiple times without duplicating the archive target heading?

Answer 1

See Stefan van der Walt's answer to this question. Note that the accepted answer in that question is incorrect.

Briefly, modifying the function as follows works in my experiments:

(defun org-archive-done-tasks ()
  (interactive)
  (org-map-entries
   (lambda ()
     (org-archive-subtree-hierarchical)
     (setq org-map-continue-from (outline-previous-heading)))
   "/DONE" 'file))

The file looks like this afterwards:

* ARCHIVED
** Project 1
*** DONE Task 2

*** DONE Task 1
* Project 1
** TODO Task 3

There is an interesting problem here: since archiving is done into the same file, then archiving again operates on everything, including the already archived entries and archiving them recursively. That can probably be cured in either of two ways: changing the scope of org-map-entries to 'tree (rather than using 'file as I did) and being careful where you run the command, or archiving to a different file, which I think is preferable because it is somewhat more robust: that would require customizing org-archive-location to something like this:

(setq org-archived_location "archive/archived_%s::* ARCHIVED")

but this has too many problems that I have not been able to resolve - the 'tree idea does not sound that bad any longer :-)

One thing to note however is that org-archive-subtree-hierarchical uses three functions that have been deleted from the development branch of org-mode. I had to retrieve them from an earlier version and add them to the archive-with-ancestors.el file that I obtained through the link you provided. Depending on the org-mode version you are running, you may not have this problem (yet), but when you do, here are the functions that need to be added back:

(defun org-get-local-archive-location ()
  "Get the archive location applicable at point."
  (let ((re "^[ \t]*#\\+ARCHIVE:[ \t]+\\(\\S-.*\\S-\\)[ \t]*$")
    prop)
    (save-excursion
      (save-restriction
    (widen)
    (setq prop (org-entry-get nil "ARCHIVE" 'inherit))
    (cond
     ((and prop (string-match "\\S-" prop))
      prop)
     ((or (re-search-backward re nil t)
          (re-search-forward re nil t))
      (match-string 1))
     (t org-archive-location))))))

(defun org-extract-archive-file (&optional location)
  "Extract and expand the file name from archive LOCATION.
if LOCATION is not given, the value of `org-archive-location' is used."
  (setq location (or location org-archive-location))
  (if (string-match "\\(.*\\)::\\(.*\\)" location)
      (if (= (match-beginning 1) (match-end 1))
      (buffer-file-name (buffer-base-buffer))
    (expand-file-name
     (format (match-string 1 location)
         (file-name-nondirectory
          (buffer-file-name (buffer-base-buffer))))))))

(defun org-extract-archive-heading (&optional location)
  "Extract the heading from archive LOCATION.
if LOCATION is not given, the value of `org-archive-location' is used."
  (setq location (or location org-archive-location))
  (if (string-match "\\(.*\\)::\\(.*\\)" location)
      (format (match-string 2 location)
          (file-name-nondirectory
           (buffer-file-name (buffer-base-buffer))))))

I run a close-to-bleeding-edge version from the master branch of the org-mode repo, currently Org mode version 9.2.3 (release_9.2.3-339-gab311b).