;;; -*- Mode: Lisp -*- #|CLARITY: Common Lisp Data Alignment Repository Copyright (c) 2006 Samantha Kleinberg All rights reserved. This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA contact: Samantha AT Bioinformatics DOT nyu DOT edu 715 Broadway, 10th floor New York, NY 10003|# (in-package "CLARITY") (eval-when (:compile-toplevel :load-toplevel :execute) (require "sql") (require "odbc")) #.(sql:enable-sql-reader-syntax) (defconstant *up* 0) (defconstant *down* 1) (defconstant *neutral* 2) (defconstant *inactive* 3) (defclass phylogeny-item() ((tree-id :accessor phylogeny-tree-id :initarg :phylogeny-tree-id) (data-id :accessor phylogeny-data-id :initarg :phylogeny-data-id)) ) (defclass phylogeny-term() ((term-name :accessor term-name :initarg :term-name) (data-id :accessor data-id :initarg :data-id) )) (defclass phylogeny-window() ((term :accessor phylogeny-window-term :initarg :phylogeny-window-term) (window-start :accessor phylogeny-window-start :initarg :phylogeny-window-start) (window-end :accessor phylogeny-window-end :initarg :phylogeny-window-end) (regulation :accessor phylogeny-window-reg :initarg :phylogeny-window-reg) )) (defclass phylogeny-associations() () ) (defmethod insert-file-popup ((interface clarity-interface)) (let ((idi (make-instance 'insert-data-interface))) (when (capi:display-dialog idi) (cond ((eq t (capi:button-enabled (probe-check-box idi))) (insert-with-probes (clarity-handle interface) (file-location idi) (capi:text-input-pane-text (file-date-input idi)))) (t (insert (clarity-handle interface) (file-location idi) (capi:text-input-pane-text (file-date-input idi))))) ) )) (defmethod get-filename ((interface insert-data-interface)) (let ((file (capi:prompt-for-file "Select data file to insert."))) (setf (file-location interface) file) (capi:apply-in-pane-process (file-location-pane interface) #'(setf capi:display-pane-text) (print-partial-filename file) (file-location-pane interface)) ) ) (defmethod get-phylogeny-root ((clh clarity-handle)) (let ((root (get-root clh))) (make-instance 'phylogeny-item :phylogeny-tree-id root :phylogeny-data-id (first (sql:with-transaction (sql:select [|timecourse_data_id|] :from [|tree|] :where [= [id] root] :database (connection clh) :flatp t ))) ))) (defmethod get-phylogeny-children ((node phylogeny-item)) (let ((children (get-children (phylogeny-tree-id node)))) (if children (loop for c in children collecting (make-instance 'phylogeny-item :phylogeny-tree-id c :phylogeny-data-id (first (sql:with-transaction (sql:select [|timecourse_data_id|] :from [|tree|] :where [= [id] c] :database (connection *current-clarity-handle*) :flatp t ))))) nil ))) (defmethod make-phylogeny-terms-roots ((clh clarity-handle) node-id term-list) (let ((timecourse-id (first (sql:with-transaction (sql:select [|timecourse_data_id|] :from [|tree|] :where [= [id] node-id] :database (connection clh) :flatp t)))) ) ;;is consensus (loop for term in term-list collecting (make-instance 'phylogeny-term :term-name term :data-id timecourse-id))) ) (defmethod get-phylogeny-terms-children (tree-node) (cond ((typep tree-node 'phylogeny-term) (loop for (start end num) in (sql:select [|window_start|] [|window_end|] [|data|] :from [|numerical_data|] :where [and [= [|timecourse_data_id|] (data-id tree-node)] [= [|term_name|] (term-name tree-node)]] :database (connection *current-clarity-handle*) :distinct t ) collecting (make-instance 'phylogeny-window :phylogeny-window-term tree-node :phylogeny-window-start start :phylogeny-window-end end :phylogeny-window-reg (cond ((> num 0) *up*) ((< num 0) *down*) ((= num 0) *neutral*) (t *inactive*)) ))) ((typep tree-node 'phylogeny-window) (split-sequence:split-sequence #\Space (first (sql:with-transaction (sql:select [|probe_ids|] :from [|numerical_data|] :where [and [= [term_name] (term-name (phylogeny-window-term tree-node))] [= [window_start] (phylogeny-window-start tree-node)] [= [window_end] (phylogeny-window-end tree-node)] [= [timecourse_data_id] (data-id (phylogeny-window-term tree-node))]] :database (connection *current-clarity-handle*) :flatp t))) :remove-empty-subseqs t)) (t nil) )) (defmethod phylogeny-window-icon (node) (cond ((typep node 'phylogeny-window) (phylogeny-window-reg node)) (t 4)) ) (defmethod phylogeny-terms-print-function (node) (cond ((typep node 'phylogeny-term) (term-name node)) ((typep node 'phylogeny-window) (format nil "Window ~a-~a" (phylogeny-window-start node) (phylogeny-window-end node)) ) (t node) ) ) (defmethod database-switch-callback (data (interface clarity-interface)) (cond ((equal data "View all entries") (setf (capi:collection-items (database-all-entries interface)) (get-all-data (clarity-handle interface))) (capi:apply-in-pane-process (database-switchable interface) #'(setf capi:switchable-layout-visible-child) (database-all-entries interface) (database-switchable interface)) ) ((equal data "Search entries") (capi:apply-in-pane-process (database-switchable interface) #'(setf capi:switchable-layout-visible-child) (database-single-entry interface) (database-switchable interface))) )) ;;should store nodes locally as in cl-godb, will fix this later (defmethod phylogeny-select-callback ((item phylogeny-item) interface) (let* ((node-id (phylogeny-tree-id item)) (children (get-children node-id))) (if children ;;is internal node (let ((consensus (get-node-terms (clarity-handle interface) node-id))) (setf (capi:collection-items (consensus-detail interface)) consensus) (setf (capi:tree-view-roots (left-child-detail interface)) (make-phylogeny-terms-roots (clarity-handle interface) (first children) (set-difference (get-node-terms (clarity-handle interface) (first children)) consensus :test #'equal))) (setf (capi:tree-view-roots (right-child-detail interface)) (make-phylogeny-terms-roots (clarity-handle interface) (second children) (set-difference (get-node-terms (clarity-handle interface) (second children)) consensus :test #'equal)))) ;;is leaf (leaf-callback node-id interface) ))) (defmethod leaf-callback (node-id interface) (setf (capi:collection-items (leaf-terms interface)) (flatten (get-node-terms (clarity-handle interface) node-id))) (clear-node-data-panes interface) ) (defmethod clear-node-data-panes (interface) (setf (capi:collection-items (consensus-detail interface)) nil) (setf (capi:tree-view-roots (right-child-detail interface)) nil) (setf (capi:tree-view-roots (left-child-detail interface)) nil) ) (defun print-partial-filename (f) (let* ((f (pathname f)) (pd (pathname-directory f)) (pn (pathname-name f)) (pt (pathname-type f)) (last-pd (first (last pd))) ) (format nil "~@[.../~A/~]~@[~A.~A~]" last-pd pn pt)))