Archive subtrees under the same hierarchy as original in the archive files.

org-archive-subtree.el

(defadvice org-archive-subtree (around fix-hierarchy activate)
  (let* ((fix-archive-p (and (not current-prefix-arg)
                             (not (use-region-p))))
         (afile (org-extract-archive-file (org-get-local-archive-location)))
         (buffer (or (find-buffer-visiting afile) (find-file-noselect afile))))
    ad-do-it
    (when fix-archive-p
      (with-current-buffer buffer
        (goto-char (point-max))
        (while (org-up-heading-safe))
        (let* ((olpath (org-entry-get (point) "ARCHIVE_OLPATH"))
               (path (and olpath (split-string olpath "/")))
               (level 1)
               tree-text)
          (when olpath
            (org-mark-subtree)
            (setq tree-text (buffer-substring (region-beginning) (region-end)))
            (let (this-command) (org-cut-subtree))
            (goto-char (point-min))
            (save-restriction
              (widen)
              (-each path
                (lambda (heading)
                  (if (re-search-forward
                       (rx-to-string
                        `(: bol (repeat ,level "*") (1+ " ") ,heading)) nil t)
                      (org-narrow-to-subtree)
                    (goto-char (point-max))
                    (unless (looking-at "^")
                      (insert "\n"))
                    (insert (make-string level ?*)
                            " "
                            heading
                            "\n"))
                  (cl-incf level)))
              (widen)
              (org-end-of-subtree t t)
              (org-paste-subtree level tree-text))))))))

It seems that only the level 1 titles will be also recorded in the _archive file, but not level 2, level 3, etc.

For example, when I have
* L1
** L2
*** L3
and I org-archive-subtree when my cursor is on ** L3, this is what I get in the _archive file:
* L1
** L3

Is there any ways to fix it?
Thank you so much for your work.

Org mode version 9.0.5
GNU Emacs 25.1.1 (x86_64-apple-darwin16.1.0, NS appkit-1504.60 Version 10.12.1 (Build 16B2555)) of 2016-11-27

@tsktsktsk64 It works for me as expected on Emacs 24.5.1 with Org mode 9.0.5.

I think some function might have changed in new Emacs to make this stop working.

You could try to edebug the form and then step through it to see where it fails. I will fix it one day when I migrate to Emacs 25 for sure :)

This has been turned into a blog post here: https://fuco1.github.io/2017-04-20-Archive-subtrees-under-the-same-hierarchy-as-original-in-the-archive-files.html

Hi Matus,

I'm using your org-archive-subtree function since some time but some weeks ago I discovered it does not work anymore because
org-extract-archive-file and org-get-local-archive-location have been removed from org-archive.el. org-archive--compute-location has to be used instead.

Here to you the required changes: daviderestivo/galactic-emacs@cb439c9

Thanks and regards,
Davide

Hi,

I like very much the idea of this advice, but playing with it, I found another problem.
Looking at org-archive-location, it allows to specify a target separated by :: from a header.
Something like

(setq org-archive-location "Archive/2019.org_archive::* From %s")

If you use a header in org-archive-location, then the advice fails.
I fixed it in the following way:

(defadvice org-archive-subtree (around fix-hierarchy activate)
  (let* ((fix-archive-p (and (not current-prefix-arg)
                             (not (use-region-p))))
         (location (org-archive--compute-location org-archive-location))
         (afile (car location))
         (offset (if (= 0 (length (cdr location)))
                     1
                   (1+ (string-match "[^*]" (cdr location)))))
         (buffer (or (find-buffer-visiting afile) (find-file-noselect afile))))
    ad-do-it
    (when fix-archive-p
      (with-current-buffer buffer
        (goto-char (point-max))
        (while (> (org-current-level) offset) (org-up-heading-safe))
        (let* ((olpath (org-entry-get (point) "ARCHIVE_OLPATH"))
               (path (and olpath (split-string olpath "/")))
               (level offset)
               tree-text)
          (when olpath
            (org-mark-subtree)
            (setq tree-text (buffer-substring (region-beginning) (region-end)))
            (let (this-command) (org-cut-subtree))
            (goto-char (point-min))
            (save-restriction
              (widen)
              (-each path
                (lambda (heading)
                  (if (re-search-forward
                       (rx-to-string
                        `(: bol (repeat ,level "*") (1+ " ") ,heading)) nil t)
                      (org-narrow-to-subtree)
                    (goto-char (point-max))
                    (unless (looking-at "^")
                      (insert "\n"))
                    (insert (make-string level ?*)
                            " "
                            heading
                            "\n"))
                  (cl-incf level)))
              (widen)
              (org-end-of-subtree t t)
              (org-paste-subtree level tree-text))))))))

Maybe not very smart, but it seems to work as expected.
Regards,

I guess it's about time to turn this into a package, seems like enough people are interested.

I'll take both feedbacks into consideration.

Some more input if you want to look deeper into this @Fuco1 (or someone else for that matter)

@daviderestivo has some more changes in his version:
https://github.com/daviderestivo/galactic-emacs/blob/master/lisp/org-archive-subtree.el .

I have put up a version using another approach here: https://gitlab.com/andersjohansson/org-archive-hierarchically (based on some other code from https://stackoverflow.com/a/35475878 and https://gist.github.com/kepi/2f4acc3cc93403c75fbba5684c5d852d). But that solution duplicates much more code from the standard archiving functions (and it’s definitely not perfect, statistics cookies causes problems for example). I think your approach of using a single function/advice for fixing it up after it has been moved to the archive file is a simpler idea.

I don’t think there’s a need for making it an advice though. The variable `org-archive-default-command´ allows for customization so we can just do something like:

(setq org-archive-default-command #'org-archive-subtree-hierarchically)

(defun org-archive-subtree-hierarchically (&optional prefix)
  (interactive "P")
  (let* ((fix-archive-p (and (not prefix)
                             (not (use-region-p))))
         (afile  (car (org-archive--compute-location
                       (or (org-entry-get nil "ARCHIVE" 'inherit) org-archive-location))))
         (buffer (or (find-buffer-visiting afile) (find-file-noselect afile))))
    (org-archive-subtree prefix)
    (when fix-archive-p
      (with-current-buffer buffer
        (goto-char (point-max))
        (while (org-up-heading-safe))
        (let* ((olpath (org-entry-get (point) "ARCHIVE_OLPATH"))
               (path (and olpath (split-string olpath "/")))
               (level 1)
               tree-text)
          (when olpath
            (org-mark-subtree)
            (setq tree-text (buffer-substring (region-beginning) (region-end)))
            (let (this-command (inhibit-message t)) (org-cut-subtree)) ; we don’t want to see "Cut subtree" messages
            (goto-char (point-min))
            (save-restriction
              (widen)
              (-each path
                (lambda (heading)
                  (if (re-search-forward
                       (rx-to-string
                        `(: bol (repeat ,level "*") (1+ " ") ,heading)) nil t)
                      (org-narrow-to-subtree)
                    (goto-char (point-max))
                    (unless (looking-at "^")
                      (insert "\n"))
                    (insert (make-string level ?*)
                            " "
                            heading
                            "\n"))
                  (cl-incf level)))
              (widen)
              (org-end-of-subtree t t)
              (org-paste-subtree level tree-text))))))))

HI all, any advice on which function/advice :) to use to accomplish hierarchical archiving? I got somewhat lost amongst all the comments. Is there a current version of this function that is working as expected? Thank you"

@Gahamelas: I'm using this one: https://github.com/daviderestivo/galactic-emacs/blob/master/lisp/org-archive-subtree.el since some years successfully :)

Thanks @daviderestivo! If my archive format is datetree, and I mark as DONE the following tasks on different days

* Heading 1
* * task 1 (DONE on 2020-01-01)
* * task 2
* * * task 3 (DONE on 2020-01-02)

What can I expect to get in my datetree?

* 2020
**   2020-01 January
***     2020-01-01 Saturday
{what to expect here}
***     2020-01-02 Sunday
{what to expect here}

Thanks!

Unfortunately this advice does nothing related to date trees. It will recreate the parents the same way as they exist in the original file. If you mark task 3 as done it will be placed under Heading1 > task2 > task3.

To make it archive in a date tree you would need to write a new function (as andersjohansson points out it doesn't need to be an advice).

@Fuco1: Thanks for having answered 👍

Thanks for the quick response, @Fuco1, as I don't know Elisp, I will have to continue as I am :) Thanks anyway!

The advice still works however it adds the archived subtree to the kill ring.
It also only works if the org archive locations isn't under another subtree.

I put in the advice in a small emacs package that has a function to enable and disable the advice:
https://gitlab.com/Thaodan/emacs.d-lisp/-/blob/master/org-archive-subtree-hierarchy.el