/[clarity]/gui/clarity-interface-functions.lisp
ViewVC logotype

Contents of /gui/clarity-interface-functions.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1 - (show annotations)
Wed Aug 16 20:18:39 2006 UTC (7 years, 8 months ago) by skleinberg
File size: 11787 byte(s)
Initial import
1 ;;; -*- Mode: Lisp -*-
2
3 #|CLARITY: Common Lisp Data Alignment Repository
4 Copyright (c) 2006 Samantha Kleinberg
5 All rights reserved.
6
7 This library is free software; you can redistribute it and/or modify it under the terms of the GNU
8 Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the
9 License, or (at your option) any later version.
10
11 This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even
12 the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser
13 General Public License for more details.
14
15 You should have received a copy of the GNU Lesser General Public License along with this library;
16 if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
17
18 contact: Samantha AT Bioinformatics DOT nyu DOT edu
19 715 Broadway, 10th floor
20 New York, NY 10003|#
21
22 (in-package "CLARITY")
23
24
25 (eval-when (:compile-toplevel :load-toplevel :execute)
26 (require "sql")
27 (require "odbc"))
28
29
30 #.(sql:enable-sql-reader-syntax)
31
32
33 (defconstant *up* 0)
34 (defconstant *down* 1)
35 (defconstant *neutral* 2)
36 (defconstant *inactive* 3)
37
38 (defclass phylogeny-item()
39 ((tree-id :accessor phylogeny-tree-id :initarg :phylogeny-tree-id)
40 (data-id :accessor phylogeny-data-id :initarg :phylogeny-data-id))
41 )
42
43 (defclass phylogeny-term()
44 ((term-name :accessor term-name :initarg :term-name)
45 (data-id :accessor data-id :initarg :data-id)
46 ))
47
48 (defclass phylogeny-window()
49 ((term :accessor phylogeny-window-term :initarg :phylogeny-window-term)
50 (window-start :accessor phylogeny-window-start :initarg :phylogeny-window-start)
51 (window-end :accessor phylogeny-window-end :initarg :phylogeny-window-end)
52 (regulation :accessor phylogeny-window-reg :initarg :phylogeny-window-reg)
53 ))
54
55 (defclass phylogeny-associations()
56 ()
57 )
58
59
60 (defmethod insert-file-popup ((interface clarity-interface))
61 (let ((idi (make-instance 'insert-data-interface)))
62 (when (capi:display-dialog idi)
63 (cond ((eq t (capi:button-enabled
64 (probe-check-box idi)))
65 (insert-with-probes (clarity-handle interface)
66 (file-location idi)
67 (capi:text-input-pane-text (file-date-input idi))))
68 (t (insert (clarity-handle interface)
69 (file-location idi)
70 (capi:text-input-pane-text (file-date-input idi)))))
71 )
72 ))
73
74
75 (defmethod get-filename ((interface insert-data-interface))
76 (let ((file (capi:prompt-for-file "Select data file to insert.")))
77 (setf (file-location interface) file)
78
79 (capi:apply-in-pane-process
80 (file-location-pane interface)
81 #'(setf capi:display-pane-text)
82 (print-partial-filename file) (file-location-pane interface))
83 )
84 )
85
86 (defmethod get-phylogeny-root ((clh clarity-handle))
87 (let ((root (get-root clh)))
88 (make-instance 'phylogeny-item
89 :phylogeny-tree-id root
90 :phylogeny-data-id (first (sql:with-transaction
91 (sql:select [|timecourse_data_id|]
92 :from [|tree|]
93 :where [= [id] root]
94 :database (connection clh)
95 :flatp t
96 )))
97 )))
98
99 (defmethod get-phylogeny-children ((node phylogeny-item))
100 (let ((children (get-children (phylogeny-tree-id node))))
101 (if children
102 (loop for c in children
103 collecting (make-instance 'phylogeny-item
104 :phylogeny-tree-id c
105 :phylogeny-data-id (first (sql:with-transaction
106 (sql:select [|timecourse_data_id|]
107 :from [|tree|]
108 :where [= [id] c]
109 :database (connection *current-clarity-handle*)
110 :flatp t
111 )))))
112 nil
113 )))
114
115 (defmethod make-phylogeny-terms-roots ((clh clarity-handle) node-id term-list)
116 (let ((timecourse-id (first (sql:with-transaction
117 (sql:select [|timecourse_data_id|]
118 :from [|tree|]
119 :where [= [id] node-id]
120 :database (connection clh)
121 :flatp t))))
122 )
123 ;;is consensus
124 (loop for term in term-list
125 collecting (make-instance 'phylogeny-term
126 :term-name term
127 :data-id timecourse-id)))
128 )
129
130
131 (defmethod get-phylogeny-terms-children (tree-node)
132 (cond ((typep tree-node 'phylogeny-term)
133 (loop for (start end num) in (sql:select [|window_start|] [|window_end|] [|data|]
134 :from [|numerical_data|]
135 :where [and [= [|timecourse_data_id|] (data-id tree-node)]
136 [= [|term_name|] (term-name tree-node)]]
137 :database (connection *current-clarity-handle*)
138 :distinct t
139 )
140 collecting (make-instance 'phylogeny-window
141 :phylogeny-window-term tree-node
142 :phylogeny-window-start start
143 :phylogeny-window-end end
144 :phylogeny-window-reg (cond ((> num 0) *up*)
145 ((< num 0) *down*)
146 ((= num 0) *neutral*)
147 (t *inactive*))
148 )))
149 ((typep tree-node 'phylogeny-window)
150 (split-sequence:split-sequence #\Space (first (sql:with-transaction
151 (sql:select [|probe_ids|]
152 :from [|numerical_data|]
153 :where [and [= [term_name] (term-name (phylogeny-window-term tree-node))]
154 [= [window_start] (phylogeny-window-start tree-node)]
155 [= [window_end] (phylogeny-window-end tree-node)]
156 [= [timecourse_data_id]
157 (data-id (phylogeny-window-term tree-node))]]
158 :database (connection *current-clarity-handle*)
159 :flatp t)))
160 :remove-empty-subseqs t))
161 (t nil)
162 ))
163
164 (defmethod phylogeny-window-icon (node)
165 (cond ((typep node 'phylogeny-window)
166 (phylogeny-window-reg node))
167 (t 4))
168 )
169
170 (defmethod phylogeny-terms-print-function (node)
171 (cond ((typep node 'phylogeny-term)
172 (term-name node))
173 ((typep node 'phylogeny-window)
174 (format nil "Window ~a-~a" (phylogeny-window-start node) (phylogeny-window-end node))
175 )
176 (t node)
177 )
178 )
179
180 (defmethod database-switch-callback (data (interface clarity-interface))
181 (cond ((equal data "View all entries")
182 (setf (capi:collection-items
183 (database-all-entries interface)) (get-all-data (clarity-handle interface)))
184 (capi:apply-in-pane-process
185 (database-switchable interface)
186 #'(setf capi:switchable-layout-visible-child)
187 (database-all-entries interface) (database-switchable interface))
188 )
189
190 ((equal data "Search entries")
191 (capi:apply-in-pane-process
192 (database-switchable interface)
193 #'(setf capi:switchable-layout-visible-child)
194 (database-single-entry interface) (database-switchable interface)))
195 ))
196
197 ;;should store nodes locally as in cl-godb, will fix this later
198 (defmethod phylogeny-select-callback ((item phylogeny-item) interface)
199 (let* ((node-id (phylogeny-tree-id item))
200 (children (get-children node-id)))
201 (if children
202 ;;is internal node
203 (let ((consensus (get-node-terms (clarity-handle interface) node-id)))
204 (setf (capi:collection-items
205 (consensus-detail interface))
206 consensus)
207
208 (setf (capi:tree-view-roots (left-child-detail interface))
209 (make-phylogeny-terms-roots (clarity-handle interface)
210 (first children)
211 (set-difference (get-node-terms (clarity-handle interface)
212 (first children))
213 consensus
214 :test #'equal)))
215 (setf (capi:tree-view-roots (right-child-detail interface))
216 (make-phylogeny-terms-roots (clarity-handle interface)
217 (second children)
218 (set-difference (get-node-terms (clarity-handle interface)
219 (second children))
220 consensus
221 :test #'equal))))
222 ;;is leaf
223 (leaf-callback node-id interface)
224
225 )))
226
227 (defmethod leaf-callback (node-id interface)
228 (setf (capi:collection-items
229 (leaf-terms interface))
230 (flatten (get-node-terms (clarity-handle interface) node-id)))
231 (clear-node-data-panes interface)
232 )
233
234 (defmethod clear-node-data-panes (interface)
235 (setf (capi:collection-items
236 (consensus-detail interface))
237 nil)
238 (setf (capi:tree-view-roots
239 (right-child-detail interface))
240 nil)
241 (setf (capi:tree-view-roots
242 (left-child-detail interface))
243 nil)
244 )
245
246
247 (defun print-partial-filename (f)
248 (let* ((f (pathname f))
249 (pd (pathname-directory f))
250 (pn (pathname-name f))
251 (pt (pathname-type f))
252 (last-pd (first (last pd)))
253 )
254 (format nil
255 "~@[.../~A/~]~@[~A.~A~]"
256 last-pd
257 pn
258 pt)))
259
260
261

  ViewVC Help
Powered by ViewVC 1.1.5