dna-mode.el

;; dna-mode.el --- a major mode for editing dna sequences
;;
;; ~harley/share/emacs/pkg/dna/dna-mode.el ---
;;
;; $Id: dna-mode.el,v 1.43 2008/03/28 10:10:41 harley Exp $
;;

;; Author:    Harley Gorrell <harley@panix.com>
;; URL:       http://www.mahalito.net/~harley/elisp/dna-mode.el
;; License:   GPL v2
;; Keywords:  dna, emacs, editing

;;; Commentary:
;; * A collection of functions for editing DNA sequences.  It
;;   provides functions to make editing dna in Emacs easier.
;;
;; Dna-mode will:
;;  * Fontify keywords and line numbers in sequences.
;;  * Fontify bases when font-lock-mode is disabled.
;;  * Incrementally search dna over pads and numbers.
;;  * Complement and reverse complement a region.
;;  * Move over bases and entire sequences.
;;  * Detect sequence files by content.

;;; Installation:
;; --------------------
;; Here are two suggested ways for installing this package.
;; You can choose to autoload it when needed, or load it
;; each time emacs is started.  Put one of the following
;; sections in your .emacs:
;;
;; ---Autoload:
;;  (autoload 'dna-mode "dna-mode" "Major mode for dna" t)
;;  (add-to-list 'magic-mode-alist '("^>\\|ID\\|LOCUS\\|DNA" . dna-mode))
;;  (add-to-list
;;     'auto-mode-alist
;;     '("\\.\\(fasta\\|fa\\|exp\\|ace\\|gb\\)\\'" . dna-mode))
;;  (add-hook 'dna-mode-hook 'turn-on-font-lock)
;;
;; ---Load:
;;  (setq dna-do-setup-on-load t)
;;  (load "/pathname/dna-mode")
;;
;; The dna-isearch-forward function (and isearch in general)
;; is much more useful with something like the following:
;;  (make-face 'isearch)
;;  (set-face-background 'isearch "yellow")
;;  (setq-default search-highlight t)

;;; History:
;;  2003-03-16: Updated URL and contact info
;;  2004-04-20: Added dna-color-bases-region to the keymap for Mike.

;;; User customizable vars start here

;;; Code:
(defvar dna-mode-hook nil
  "*Hook to setup `dna-mode'.")

(defvar dna-mode-load-hook nil
  "*Hook to run when `dna-mode' is loaded.")

(defvar dna-setup-on-load nil
  "*If not nil setup dna mode on load by running `dna-`add-hook's'.")

;; Bases
(defvar dna-valid-base-regexp
  "[-*:acgtmrwsykvhdbxnACGTMRWSYKVHDBXN]"
  "*A regexp which matches a single base.")

(defvar dna-base-complement-list
  '((?- . ?-) (?n . ?n) (?* . ?*) (?x . ?x) (?: . ?:) ; identity
    (?a . ?t) (?c . ?g) (?g . ?c) (?t . ?a) ; single
    (?m . ?k) (?r . ?y) (?w . ?w) (?s . ?s) (?y . ?r) (?k . ?m) ; double
    (?v . ?b) (?h . ?d) (?d . ?h) (?b . ?v) ; triple
    )
  "*List of bases and their complements.
Bases should be lowercase, as they are upcased when the `vector is made.")

;; These are the colors used when coloring bases.
(defvar dna-base-color-a "blue")
(defvar dna-base-color-c "black")
(defvar dna-base-color-g "green")
(defvar dna-base-color-t "red")

;; Dna-isearch
(defvar dna-cruft-regexp "[* 0-9\t\n]"
  "*Regexp to match cruft which may appear between bases.
Skip over it during dna-motion and dna-isearch.")

(defvar dna-isearch-case-fold-search t
  "*Case fold dna-isearches if set.")

;; Sequence
(defvar dna-sequence-start-regexp
  "^\\(>\\|ID\\|LOCUS\\|DNA\\)"
  "A regexp which matches the start of a sequence.")

;;; End of user customizable vars

;;; Start of internal vars and code

(defvar dna-base-complement-vector
  (let ((c-vec (make-vector 256 nil))
	(c-list dna-base-complement-list))
    (while c-list
      (aset c-vec (car (car c-list)) (cdr (car c-list)))
      (aset c-vec (upcase (car (car c-list))) (upcase (cdr (car c-list))))
      (setq c-list (cdr c-list)))
    c-vec)
  "A vector of upper and lower case bases and their complements.")

;; I also use "Alt" as C-c is too much to type for cursor motions.
(defvar dna-mode-map
  (let ((map (make-sparse-keymap)))
    ;; Ctrl bindings
    (define-key map "\C-c\C-f"	'dna-forward-base)
    (define-key map "\C-cf"	'dna-forward-base)
    (define-key map "\C-c\C-b"	'dna-backward-base)
    (define-key map "\C-cb"	'dna-backward-base)
    (define-key map "\C-c="     'dna-base-position)
    (define-key map "\C-cp"	'dna-beginning-of-sequence)
    (define-key map "\C-c\C-s"	'dna-isearch-forward)
    (define-key map "\C-cs"	'dna-isearch-forward)
    (define-key map "\C-cr"	'dna-reverse-complement-region)
    (define-key map "\C-cc"	'dna-complement-region)
    (define-key map "\C-c#"	'dna-count-bases-region)
    (define-key map "\M-\C-h"	'dna-mark-sequence)
    (define-key map "\M-\C-a"	'dna-beginning-of-sequence)
    (define-key map "\M-\C-e"	'dna-end-of-sequence)
    ;; base coloring
    (define-key map "\C-cg"     'dna-color-bases-region)
    (define-key map "\C-cl"     'font-lock-mode)
    ;; XEmacs does not like the Alt bindings
    (when (not (string-match "XEmacs" (emacs-version)))
      (define-key map [A-right]	'dna-forward-base)
      (define-key map [A-left]	'dna-backward-base)
      (define-key map [A-up]	'dna-beginning-of-sequence)
      (define-key map [A-down]	'dna-end-of-sequence)
      (define-key map [?\A-\C-s]	'dna-isearch-forward))
    map)
  "The local keymap for `dna-mode'.")

;;;###autoload
(defun dna-mode ()
  "Major mode for editing DNA sequences.

This mode also customizes isearch to search over line
breaks.  Use \\[universal-argument] number as a prefix to
`dna-forward-base' to move that many bases.  This skips line
breaks and spaces.

`dna-color-bases-region' disables `font-lock-mode'
automaticly as they cant work together.
\\[dna-color-bases-region] turns `font-lock-mode' back on.

\\{dna-mode-map}"
  (interactive)
  ;;
  (kill-all-local-variables)
  (setq mode-name "dna")
  (setq major-mode 'dna-mode)
  (use-local-map dna-mode-map)
  ;;
  (make-local-variable 'font-lock-defaults)
  (setq font-lock-defaults '(dna-font-lock-keywords))
  ;;
  (make-local-variable 'dna-valid-base-regexp)
  (make-local-variable 'dna-sequence-start-regexp)
  (make-local-variable 'dna-cruft-regexp)
  (make-local-variable 'dna-isearch-case-fold-search)
  ;;
  (run-hooks 'dna-mode-hook))

;; Keywords
;; Todo: Seperate the keywords into a list for each format, rather
;; than one for all.
(defvar dna-font-lock-keywords
  '(
    ;; Fasta
    ("^\\(>\\)\\([-_.|a-zA-Z0-9]+\\)\\([ \t]+.*\\)?"
     (1 font-lock-keyword-face)
     (2 font-lock-function-name-face)
     (3 font-lock-comment-face nil t))

    ;; Exp
    ("^\\(ID\\) +\\([-_.a-zA-Z_0-9]+\\)"
     (1 font-lock-keyword-face) (2 font-lock-function-name-face))
    ("^\\(CC\\|SQ\\)\\([ \t]\\(.*\\)\\)?$"
     (1 font-lock-keyword-face) (3 font-lock-comment-face nil t))
    ("^\\(\\sw\\sw\\)[ \t]"
     (1 font-lock-keyword-face))
    ("^\\(//\\)"
     (1 font-lock-keyword-face))

    ;; Ace (phrap output)
    ("^\\(DNA\\|Sequence\\|BaseQuality\\) +\\([-_.a-zA-Z_0-9]+\\)"
     (1 font-lock-keyword-face) (2 font-lock-function-name-face))

    ;; Genbank
    ("^\\(LOCUS\\) +\\([-_.a-zA-Z_0-9]+\\)";; are '-_.' allowed?
     (1 font-lock-keyword-face) (2 font-lock-function-name-face))
    "ORIGIN"

    ;; More genbank keywords...
    "ACCESSION" "AUTHORS" "AUTHORS" "BASE COUNT" "DEFINITION"
    "FEATURES" "JOURNAL" "JOURNAL" "KEYWORDS" "MEDLINE" "NID"
    "ORGANISM" "REFERENCE" "SEGMENT" "SOURCE" "TITLE"

    ;; line numbers...
    ("^[ \t]*\\([0-9]+\\)"
     (1 font-lock-string-face))

    ;; others...?
    )
  "Expressions to hilight in `dna-mode'.")


;;; Setup functions
(defun dna-find-file-func ()
  "Invoke `dna-mode' if the buffer look like a sequence.
and another mode is not active.
This function is added to `find-file-hooks'."
  (if (and (eq major-mode 'fundamental-mode)
           (looking-at dna-sequence-start-regexp))
    (dna-mode)))

;;;###autoload
(defun dna-add-hooks ()
  "Add a default set of dna-hooks.
These hooks will activate `dna-mode' when visiting a file
which has a dna-like name (.fasta or .gb) or whose contents
looks like dna.  It will also turn enable fontification for `dna-mode'."
  (add-hook 'dna-mode-hook 'turn-on-font-lock)
  (add-hook 'find-file-hooks 'dna-find-file-func)
  (add-to-list
   'auto-mode-alist
   '("\\.\\(fasta\\|fa\\|exp\\|ace\\|gb\\)\\'" . dna-mode)))

;; Setup hooks on request when this mode is loaded.
(if dna-setup-on-load
  (dna-add-hooks))

(defun dna-next-char-func ()
  "Should never be called.  Overridden in `dna-forward-base'."
  (error "This shouldnt have been called"))

;; Motion
(defun dna-forward-base (count)
  "Move forward COUNT bases.  Move backward if negative.
Skip over dna-isearch-cruft.  Stop on non-base or
non-whitespace characters."
  (interactive "p")
  (let ((c 0)
        (abscount (abs count))
        (dir (if (< count 0) -1 1))
        dna-next-char-func
        bstr)
    ;; 
    (fset 'dna-next-char-func (if (< dir 0) 'preceding-char 'following-char))
    ;;
    (while (< c abscount)
      (setq bstr (char-to-string (dna-next-char-func)))
      (cond
       ((string-match dna-valid-base-regexp bstr)
        (forward-char dir)
        (setq c (1+ c)))
       ((string-match dna-cruft-regexp bstr)
        (forward-char dir))
       (t
        (message "Moved %d bases forward." c)
        (setq abscount c))))            ; stop the while

    ;; Move over trailing junk when moving forward
    (if (= dir 1)
      (while (string-match dna-cruft-regexp
                           (char-to-string (dna-next-char-func)))
        (forward-char dir))
      )
    ;; return the distance moved
    (* dir abscount)))

;; aaaaaaaaaa cccccccccc | gggggggggg tttttttttt

(defun dna-backward-base (count)
  "Move backward COUNT bases.  See `dna-forward-base'."
  (interactive "p")
  (dna-forward-base (- count)))

(defun dna-beginning-of-sequence-p ()
  "At the beginning of a sequence?"
  (looking-at dna-sequence-start-regexp))

(defun dna-beginning-of-sequence ()
  "Move to the start of the sequence or the buffer."
  (interactive)
  (goto-char
   (or
    (search-backward-regexp dna-sequence-start-regexp (point-min) t)
    (point-min))))

(defun dna-end-of-sequence ()
  "Move to the end of the sequence or the buffer."
  (interactive)
  (end-of-line)
  (skip-syntax-forward "-")
  (let ((seqstart
         (search-forward-regexp dna-sequence-start-regexp (point-max) t)))
    (if seqstart (progn
                   (goto-char seqstart)
                   (beginning-of-line))
        (goto-char (point-max)))))

(defun dna-mark-sequence ()
  "Put point at the beginning of a sequence, mark at end."
  (interactive)
  (dna-end-of-sequence)
  (set-mark (point))
  (dna-beginning-of-sequence))

(defun dna-count-bases-region (d-start d-end)
  "Count the number of bases in the region D-START to D-END.
Echos the number of bases counted.
If an invalid base is found, stops on the base and signals an error."
  (interactive "r")
  (let ((basecount 0))
    (goto-char d-start)
    (while (< (point) d-end)
      (cond
       ((looking-at dna-valid-base-regexp)
        (setq basecount (1+ basecount))
        (forward-char 1))
       ((looking-at dna-cruft-regexp)
        (forward-char 1))
       (t
        (error "Bad base '%s' found at position %d (%dbp)"
               (buffer-substring-no-properties (point) (1+ (point)))
               (point) basecount)) ))
    (message "There are %d bases in the region." basecount)
    basecount))

(defun dna-sequence-title ()
  "Return the title of the dna sequence."
  (save-excursion
    (unless (dna-beginning-of-sequence-p)
      (dna-beginning-of-sequence))
    (cond
     ((looking-at ">\\([-.|a-zA-Z0-9]+\\)") ;; fa
      (match-string-no-properties 1))
     ((looking-at "ID\\s-*\\([-.|a-zA-Z0-9]+\\)") ;; EXP
      (match-string-no-properties 1)))))

(defun dna-goto-start-of-bases ()
  "Starting from sequence beginning, move to the start of the bases."
  (interactive)
  (cond
   ((looking-at "^>") ;; fasta
    (next-line 1)
    (beginning-of-line))
   ((looking-at "^ID") ;; exp
    (if (search-forward-regexp "^\\s-*SEQ" (point-max) t)
      (progn (forward-char 1) (point))
      nil))
   ;; TODO: add more formats
   (t
    (error "Unknown sequence format")) ))

(defun dna-base-position ()
  "Return the postition of the base in the sequence."
  (interactive)
  (let ((r-end (point)) pos title)
    (save-excursion
      (unless (dna-beginning-of-sequence-p)
        (dna-beginning-of-sequence))
      (when (setq title (dna-sequence-title))
        (dna-goto-start-of-bases)
        (if (< r-end (point))
          (error "Not in sequence '%s'" title))
        (setq pos (dna-count-bases-region (point) r-end))
        (message "Sequence: '%s' %dbp" title pos)
        pos))))

;;; reverse and complement
(defun dna-complement-base-list (base)
  "Complement the BASE using a list based method.
Returns the complement of the base.
It can also be used to test if the character is a base,
as all bases should have a complement."
  (cdr (assq base dna-base-complement-list)))

(defun dna-complement-base (base)
  "Complement a BASE using a vector based method.
See `dna-complement-base-list' for more info."
  (aref dna-base-complement-vector base))

(defun dna-complement (base)
  "Look up the complement of the BASE and print a message.
Handy for us CS types."
  (interactive "cComplement of base:")
  (message "Complement of '%c' is '%c'." base (dna-complement-base base)))

(defun dna-complement-region (r-start r-end)
  "Complement a region of bases from R-START to R-END.
Complement a region of the buffer by deleting it and
inserting the complements, base by base.  Non-bases are
passed over unchanged."
  (interactive "r")
  (let (r-string r-length r-point r-base r-cbase)
    (goto-char r-start)
    (setq r-string (buffer-substring-no-properties r-start r-end))
    (setq r-length (length r-string))
    (delete-region r-start r-end)
    (setq r-point 0)
    (while (< r-point r-length)
      (setq r-base (aref r-string r-point))
      (setq r-cbase (dna-complement-base r-base))
      (insert (if r-cbase r-cbase r-base))
      (setq r-point (1+ r-point)))))

;;;###autoload
(defun dna-reverse-complement-region (r-start r-end)
  "Reverse complement a region of dna from R-START to R-END.
Works by deleting the region and inserting bases reversed
and complemented, while entering non-bases in the order
found."
  (interactive "r")
  (let (r-string r-length r-base r-cbase r-point r-mark)
    (goto-char r-start)
    (setq r-string (buffer-substring-no-properties r-start r-end))
    (setq r-length (length r-string))
    (setq r-mark (1- r-length))
    (setq r-point 0)

    ;; goodbye
    (delete-region r-start r-end)

    ;; insert the bases from back to front base by base
    ;; insert non-bases from front to back to preserve spacing
    (while (< r-point r-length)
      (setq r-base (aref r-string r-point))
      (setq r-cbase (dna-complement-base r-base))
      (if r-cbase
        (progn
          ;; it is a base. find the reverse and complement it
          (while (not (dna-complement-base (aref r-string r-mark)))
            (setq r-mark (1- r-mark)))
          (insert (dna-complement-base (aref r-string r-mark)))
          (setq r-mark (1- r-mark)) )
        ;; not a base, no change
        (insert r-base))
      (setq r-point (1+ r-point)))))

;; format
(defun dna-guess-format-func ()
  "Guess the format of the sequence the point is at or after.
Returns the format or nil."
  (save-excursion
    (end-of-line)
    (dna-beginning-of-sequence)
    (cond
     ((looking-at "^>")   'fasta)
     ((looking-at "^DNA") 'phrap)
     ((looking-at "^ID")  'exp)
     (t nil))))

(defun dna-guess-format ()
  "Guess and print the format of the sequence."
  (interactive)
  (message "%s" (dna-guess-format-func)))

;;; dna-isearch stuff
(defun dna-isearch-mangle-str (str)
  "Mangle the string STR into a regexp to search over cruft in sequence.
Inserts a regexp between each base which matches sequence formatting cruft.
For example, if `dna-cruft-regexp' is            '[ ]',
the search string 'acgt' would transformed into  'a[ ]*c[ ]*g[ ]*t[ ]*'"
  (let ((i 0) (out ""))
    (while (< i (length str))
      (setq out (concat out (substring str i (1+ i)) dna-cruft-regexp "*"))
      (setq i (1+ i)))
    out))

(defadvice isearch-message-prefix (around dna-isearch-ismp)
  "Set the isearch prompt string to show dna search is active.
This serves as a warning that the string is being mangled."
  ad-do-it
  (setq ad-return-value (concat "DNA " ad-return-value)))

(defadvice isearch-search (around dna-isearch-iss)
  "The advice used to mangle the search string in isearch."
  (let ((isearch-regexp t)
        ;; force case folding
        (isearch-case-fold-search dna-isearch-case-fold-search)
        (isearch-string (dna-isearch-mangle-str isearch-string)) )
    ad-do-it))

;;;###autoload
(defun dna-isearch-forward ()
  "Isearch forward on dna sequence.
Enable the `dna-mode' search string mangling advice and start the search."
  (interactive)
  ;; Enable the prompt
  (ad-enable-advice 'isearch-message-prefix 'around 'dna-isearch-ismp)
  (ad-activate 'isearch-message-prefix)
  ;; Enable the mangling
  (ad-enable-advice 'isearch-search 'around 'dna-isearch-iss)
  (ad-activate 'isearch-search)

  ;; run the search
  (isearch-forward)

  ;;
  (ad-disable-advice 'isearch-message-prefix 'around 'dna-isearch-ismp)
  (ad-activate 'isearch-message-prefix)
  ;; 
  (ad-disable-advice 'isearch-search 'around 'dna-isearch-iss)
  (ad-activate 'isearch-search))

;;; Work with columns of sequences.

(defun dna-column-select-func ()
  "Return the start and end of the column as a cons.
Point is moved forward one."
  (let (s m e)
    (setq m (point))
    ;; work our way up
    (while (looking-at dna-valid-base-regexp)
      (setq s (point))
      (previous-line 1))
    (goto-char m)
    ;; work our way down
    (while (looking-at dna-valid-base-regexp)
      (setq e (point))
      (next-line 1))
    (goto-char m)
    ;; return the start and end of the column
    (cons s (1+ e))))

(defun dna-column-select ()
  "Select the current column of text.
Sets the mark at the top and the point at the bottom of a non-blank column."
  (interactive)
  (let ((se (dna-column-select-func)))
    (goto-char (car se))
    (push-mark)
    (goto-char (cdr se))))

(defvar dna-column-pad "*"
  "Character to use when inserting a column of pads.")

(defun dna-column-insert-pad ()
  "Insert a column of pads."
  (interactive)
  (save-excursion
    (let ((se (dna-column-select-func)))
      (string-rectangle (car se) (cdr se) dna-column-pad))))

(defun dna-column-delete ()
  "Delete the current column of dna."
  (interactive)
  (save-excursion
    (let ((se (dna-column-select-func)))
      (kill-rectangle (car se) (cdr se)))))

;;; Per base colors

(defun dna-base-color-make-faces (&optional force)
  "Build a face to display bases with.  FORCE remakes the faces."
  (when (or (not (facep 'dna-face-t)) force)
    (let ((base-list '("a" "c" "g" "t"))
          base base-face)
      (while base-list
        (setq base (car base-list))
        (setq base-face (intern (concat "dna-base-face-" base)))
        (make-face base-face)
        (set-face-foreground
         base-face (symbol-value (intern (concat "dna-base-color-" base))))
        (setq base-list (cdr base-list))))))

;; Make faces on load
(dna-base-color-make-faces t)

(defvar dna-color-bases-auto t
  "Automaticly deactivate option `font-lock-mode' when `dna-color-bases' is run.
See dna-color-bases for details.")
;; (setq dna-color-bases-auto t)

(defun dna-color-bases-region (s e)
  "Color the bases in the region S to E.
NOTE: The function `font-lock-mode' will undo the work of this
function if activated.  Disable it before using this
function.  If `dna-color-bases-auto' is set then option `font-lock-mode'
is deactivated automatically."
  (interactive "r")
  (if (and dna-color-bases-auto font-lock-mode)
    (font-lock-mode -1))
  (if font-lock-mode
    (error "Font-lock-mode is on -- deactivate it"))
  (save-excursion
    (let (c)
      (goto-char s)
      (while (< s e)
        (setq c (downcase (char-after s)))
        (cond
         ((eq c ?a)
          (set-text-properties s (+ s 1) '(face dna-base-face-a)))
         ((eq c ?c)
          (set-text-properties s (+ s 1) '(face dna-base-face-c)))
         ((eq c ?g)
          (set-text-properties s (+ s 1) '(face dna-base-face-g)))
         ((eq c ?t)
          (set-text-properties s (+ s 1) '(face dna-base-face-t)))
         (t nil))
        (setq s (+ s 1))))))

(defun dna-uncolor-bases-region (s e)
  "Uncolor the bases from S to E."
  (interactive "r")
  (remove-text-properties s e '(face nil)))

;;; Functions for me.

;; I like to datestamp sequences I work with.
(defvar dna-timestamp-format "%Y%m%d"
  "Format of the time stamp which `dna-timestamp-seq' uses.")

(defun dna-timestamp-seq ()
  "Insert the current date into the sequence.
Assumes fasta format."
  (interactive)
  (end-of-line)
  (dna-beginning-of-sequence)
  (end-of-line)
  (insert "   " (format-time-string dna-timestamp-format (current-time))))

;; done loading
(run-hooks 'dna-mode-load-hook)
(provide 'dna-mode)

;;; dna-mode.el ends here