Hierarchical archiving for Org-mode

org-archive-subtree-hierarchical.el

;; org-archive-subtree-hierarchical.el
;;
;; version 0.2
;; modified from https://lists.gnu.org/archive/html/emacs-orgmode/2014-08/msg00109.html
;; modified from https://stackoverflow.com/a/35475878/259187

;; In orgmode
;; * A
;; ** AA
;; *** AAA
;; ** AB
;; *** ABA
;; Archiving AA will remove the subtree from the original file and create
;; it like that in archive target:

;; * AA
;; ** AAA

;; And this give you
;; * A
;; ** AA
;; *** AAA
;;
;; Install file to your include path and include in your init file with:
;;
;;  (require 'org-archive-subtree-hierarchical)
;;  (setq org-archive-default-command 'org-archive-subtree-hierarchical)
;;
(provide 'org-archive-subtree-hierarchical)
(require 'org-archive)

(defun org-archive-subtree-hierarchical--line-content-as-string ()
  "Returns the content of the current line as a string"
  (save-excursion
    (beginning-of-line)
    (buffer-substring-no-properties
     (line-beginning-position) (line-end-position))))

(defun org-archive-subtree-hierarchical--org-child-list ()
  "This function returns all children of a heading as a list. "
  (interactive)
  (save-excursion
    ;; this only works with org-version > 8.0, since in previous
    ;; org-mode versions the function (org-outline-level) returns
    ;; gargabe when the point is not on a heading.
    (if (= (org-outline-level) 0)
        (outline-next-visible-heading 1)
      (org-goto-first-child))
    (let ((child-list (list (org-archive-subtree-hierarchical--line-content-as-string))))
      (while (org-goto-sibling)
        (setq child-list (cons (org-archive-subtree-hierarchical--line-content-as-string) child-list)))
      child-list)))

(defun org-archive-subtree-hierarchical--org-struct-subtree ()
  "This function returns the tree structure in which a subtree
belongs as a list."
  (interactive)
  (let ((archive-tree nil))
    (save-excursion
      (while (org-up-heading-safe)
        (let ((heading
               (buffer-substring-no-properties
                (line-beginning-position) (line-end-position))))
          (if (eq archive-tree nil)
              (setq archive-tree (list heading))
            (setq archive-tree (cons heading archive-tree))))))
    archive-tree))

(defun org-archive-subtree-hierarchical ()
  "This function archives a subtree hierarchical"
  (interactive)
  (let ((org-tree (org-archive-subtree-hierarchical--org-struct-subtree))
        (this-buffer (current-buffer))
        (file (abbreviate-file-name
               (or (buffer-file-name (buffer-base-buffer))
                   (error "No file associated to buffer")))))
    (save-excursion
      (setq location org-archive-location
            afile (car (org-archive--compute-location
		                   (or (org-entry-get nil "ARCHIVE" 'inherit) location)))
            ;; heading (org-extract-archive-heading location)
            infile-p (equal file (abbreviate-file-name (or afile ""))))
      (unless afile
        (error "Invalid `org-archive-location'"))
      (if (> (length afile) 0)
          (setq newfile-p (not (file-exists-p afile))
                visiting (find-buffer-visiting afile)
                buffer (or visiting (find-file-noselect afile)))
        (setq buffer (current-buffer)))
      (unless buffer
        (error "Cannot access file \"%s\"" afile))
      (org-cut-subtree)
      (set-buffer buffer)
      (org-mode)
      (goto-char (point-min))
      (while (not (equal org-tree nil))
        (let ((child-list (org-archive-subtree-hierarchical--org-child-list)))
          (if (member (car org-tree) child-list)
              (progn
                (search-forward (car org-tree) nil t)
                (setq org-tree (cdr org-tree)))
            (progn
              (goto-char (point-max))
              (newline)
              (org-insert-struct org-tree)
              (setq org-tree nil)))))
      (newline)
      (org-yank)
      (when (not (eq this-buffer buffer))
        (save-buffer))
      (message "Subtree archived %s"
               (concat "in file: " (abbreviate-file-name afile))))))

(defun org-insert-struct (struct)
  "TODO"
  (interactive)
  (when struct
    (insert (car struct))
    (newline)
    (org-insert-struct (cdr struct))))

(defun org-archive-subtree ()
  (org-archive-subtree-hierarchical)
  )

Hi.
When I try to archive using C-c C-x C-a, it says (Windows OS):
"Wrong type argument: commandp, org-archive-subtree"

What is value of your org-archive-default-command variable? And were your C-c C-x C-a binding leads? Here is my binding:

, s A runs the command org-archive-subtree-default, which is an autoloaded
interactive Lisp closure in ‘org-archive.el’.

It is bound to M-RET s A, M-m m s A, C-c C-x C-a, and many ordinary text
characters.

(org-archive-subtree-default)

Archive the current subtree with the default command.
This command is set with the variable ‘org-archive-default-command’.

and variable:

org-archive-default-command is a variable defined in ‘org-archive.el’.
Its value is ‘org-archive-subtree-hierarchical’
Original value was org-archive-subtree

Maybe you didn't include it correctly in your init file? Try something like

(require 'org-archive-subtree-hierarchical)
(setq org-archive-default-command 'org-archive-subtree-hierarchical)

Hi
I am quite newbie, so I've tried adding those lines:

(require 'org-archive-subtree-hierarchical)
(setq org-archive-default-command 'org-archive-subtree-hierarchical)

I didn't modify any variable, just loaded your script, so I was using C-c C-x C-a because it is the default binding to "archive", it works if I don't try to improve it with your work.

After just adding your 2 lines I get this message:
"Symbol's function definition is void: org-archive--compute-location"

Is it possible you installed only org package without contrib part? Try to install package org-plus-contrib which contains org-archive.el and that should include your missing function. I'm not sure if it would help but its best fast guess.

I would definitely not call this "my work", to be hones, I barely understand the code, I just really depends on its functionality and need to fix it when it broke with new org :)

Hi. Thanks.
I'm sure the cause is what you are saying, but... it seems I am too newbie to solve it: I have installed ELPA, listed its packages, but I can't find "org-archive.el", nor "org-archive-subtree-hierarchical.el". Is that the way?

org-archive.el is included in package org-plus-contrib, so just try to list packages and check if it is installed. Second .el is this file (one from this gist) which need to be placed to location where your emacs will find it.

Working!!!
Thanks!

Hmm, when I use this to archive a heading with several sub-headings, if I do it for each of the subheadings individually, then I get a bunch of added newlines in the archive. Each heading gains a newline that can be collapsed

I tried commenting out the (newline) on line 119, but then it reproduces the sub-structure each time rather than adding to the existing one.

Does this reproduce for you?

Also:
I've added the following in my config so that things are archived in an archive directory rather than in the current directory.
Eg
~/org/file1 is archived to ~/org/archive/file1_archive
~/org/notes/file2 is archived to ~org/archive/notes/file2_archive

(defun org-archive-subtree-hierarchical-archive-dir ()
     (interactive)
     (let* ((org-archive-location (concat "~/org/archive/"
                                          (file-relative-name buffer-file-name "~/org/")
                                          "_archive::")))
       (org-archive-subtree-hierarchical)))

The newlines appear regardless of whether I include that code.

Oh, I finally found time to check your comment after almost a year... To be honest, I currently don't mind multiple newlines as I'm not working with archive too much. I'm archiving a lot, but almost never searching it for anything. Not sure on first glance where that new line is comming from but looks like I have redundant new lines too.

As for archive location, I have them in archive subfolder too, but if I remember correctly, it is coming from archive location in my case:

    (setq org-archive-location "~/org/archive/%s_archive::* Archived Tasks")

Subtrees are inserted in archive file automatically in exact place were they should be (the Archived Tasks heading is not added).

Hi kepi, thanks for sharing this script, I was looking exactly for something like that and, considering my newbiness to emacs orgmode, this was perfect!

I have a similar configuration to your example above but in my case is:

(setq org-archive-location "~/org/archive/archive.org::* From %s")

I was wandering if it would be possible to insert subtrees including the From %s heading?
In this way I can have one single archive file with the list of archived items grouped by original file name