X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=composite.lisp;h=afd3e16176a3a81f437f622a28cc7924834edfd2;hb=6c10979737dc10b0c510b1edfe070346bcac3ff5;hp=d9e01fd794f455bd978a921715ce49a4cd014b54;hpb=3f08ed681b40700d27bfd47804d9072816ca1a15;p=umlisp.git diff --git a/composite.lisp b/composite.lisp index d9e01fd..afd3e16 100644 --- a/composite.lisp +++ b/composite.lisp @@ -2,15 +2,13 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; Name: composite.lisp -;;;; Purpose: Composite Classes for UMLisp -;;;; Author: Kevin M. Rosenberg -;;;; Date Started: Apr 2000 -;;;; -;;;; $Id: composite.lisp,v 1.23 2003/05/27 21:43:41 kevin Exp $ +;;;; Name: composite.lisp +;;;; Purpose: Composite Classes for UMLisp +;;;; Author: Kevin M. Rosenberg +;;;; Created: Apr 2000 ;;;; ;;;; This file, part of UMLisp, is -;;;; Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D. +;;;; Copyright (c) 2000-2010 by Kevin M. Rosenberg, M.D. ;;;; ;;;; UMLisp users are granted the rights to distribute and use this software ;;;; as governed by the terms of the GNU General Public License. @@ -18,10 +16,6 @@ (in-package #:umlisp) -(eval-when (:compile-toplevel) - (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))) - - ;;; Semantic type constants (defun find-tui-word (words) @@ -32,7 +26,7 @@ (defun tui-disease-or-syndrome () (find-tui-word "disease or syndrome")) -(defun tui-sign-or-symptom () +(defun tui-sign-or-symptom () (find-tui-word "sign or symptom")) (defun tui-finding () (find-tui-word "finding")) @@ -46,20 +40,20 @@ (defun find-ucon2-tui (ucon tui cui2-func related-con-func) "Returns a list of related ucons that have specific tui" - (remove-duplicates + (remove-duplicates (filter - #'(lambda (c) - (aif (funcall cui2-func c) - (let ((ucon2 (find-ucon-cui it))) - (when (ucon-is-tui? ucon2 tui) - ucon2)) nil)) + #'(lambda (c) + (aif (funcall cui2-func c) + (let ((ucon2 (find-ucon-cui it))) + (when (ucon-is-tui? ucon2 tui) + ucon2)) nil)) (funcall related-con-func ucon)) :key #'cui)) (defun find-ucon2-coc-tui (ucon tui) "Return list of ucon's that have co-occuring concepts of semantic type tui" (find-ucon2-tui ucon tui #'cui2 #'s#coc)) - + (defun find-ucon2-rel-tui (ucon tui) "Return list of ucon's that have related concepts to ucon and semantic type tui" (find-ucon2-tui ucon tui #'cui2 #'s#rel)) @@ -68,7 +62,7 @@ (defclass freq (hyperobject) ((freq :value-type integer :initarg :freq :accessor freq - :print-formatter fmt-comma-integer)) + :print-formatter fmt-comma-integer)) (:metaclass hyperobject-class) (:default-initargs :freq 0) (:user-name "Frequency class" "Frequency classes") @@ -100,12 +94,12 @@ (let ((usty_freqs '())) (dolist (tuple (mutex-sql-query "select distinct TUI from MRSTY")) (let* ((tui (car tuple)) - (freq (ensure-integer - (caar (mutex-sql-query - (format nil "select count(*) from MRSTY where TUI=~a" tui))))) - (usty (find-usty-tui tui))) - (push (make-instance 'usty_freq :sty (sty usty) - :tui (tui usty) :freq freq) usty_freqs))) + (freq (ensure-integer + (caar (mutex-sql-query + (format nil "select count(*) from MRSTY where TUI=~a" tui))))) + (usty (find-usty-tui tui))) + (push (make-instance 'usty_freq :sty (sty usty) + :tui (tui usty) :freq freq) usty_freqs))) (sort usty_freqs #'> :key #'freq))) @@ -121,36 +115,36 @@ (defun find-usrl_freq-all () (let ((freqs '())) (dolist (usrl (find-usrl-all)) - (let ((freq (ensure-integer - (caar (mutex-sql-query - (format nil "select count(*) from MRSO where SAB='~a'" - (sab usrl))))))) - (push (make-instance 'usrl_freq :sab (sab usrl) :srl (srl usrl) - :freq freq) - freqs))) + (let ((freq (ensure-integer + (caar (mutex-sql-query + (format nil "select count(*) from MRSO where SAB='~a'" + (sab usrl))))))) + (push (make-instance 'usrl_freq :sab (sab usrl) :srl (srl usrl) + :freq freq) + freqs))) (sort freqs #'> :key #'freq))) (defun find-ucon2_freq-coc-tui (ucon tui) -"Return sorted list of tuples with ucon and freq that have co-occuring concepts of semantic type tui" - (let ((ucon_freqs '())) - (dolist (ucoc (s#coc ucon)) - (aif (cui2 ucoc) - (let ((ucon2 (find-ucon-cui it))) +"Return sorted list of tuples with ucon and freq that have co-occuring concepts of semantic type tui" + (let ((ucon_freqs '())) + (dolist (ucoc (s#coc ucon)) + (aif (cui2 ucoc) + (let ((ucon2 (find-ucon-cui it))) (when (ucon-is-tui? ucon2 tui) - (push (make-instance 'ucon_freq :cui (cui ucon2) :lrl (lrl ucon2) - :pfstr (pfstr ucon2) :freq (cof ucoc)) - ucon_freqs))))) + (push (make-instance 'ucon_freq :cui (cui ucon2) :lrl (lrl ucon2) + :pfstr (pfstr ucon2) :freq (cof ucoc)) + ucon_freqs))))) (setq ucon_freqs (delete-duplicates ucon_freqs :key #'cui)) (sort ucon_freqs #'> :key #'freq))) - + (defun find-ucon2-str&sty (str sty lookup-func) "Call lookup-func for ucon and usty for given str and sty" (let ((ucon (car (find-ucon-str str))) - (usty (car (find-usty-word sty)))) + (usty (car (find-usty-word sty)))) (if (and ucon usty) - (funcall lookup-func ucon (tui usty)) + (funcall lookup-func ucon (tui usty)) nil))) - + (defun find-ucon2-coc-str&sty (str sty) "Find all ucons that are a co-occuring concept for concept named str and that have semantic type of sty" @@ -168,16 +162,16 @@ (let ((ucon_freqs (make-array (1+ (find-cui-max)) :initial-element nil))) (dolist (ucon (find-ucon-tui tui)) ;; for all disease-or-syn (dolist (ucon2 (funcall ucon2-tui-func ucon tui)) ;; for each related disease - (aif (aref ucon_freqs (cui ucon2)) - (setf (freq it) (1+ (freq it))) - (setf (aref ucon_freqs (cui ucon2)) - (make-instance 'ucon_freq :cui (cui ucon2) :lrl (lrl ucon2) - :pfstr (pfstr ucon2) :freq 1))))) + (aif (aref ucon_freqs (cui ucon2)) + (setf (freq it) (1+ (freq it))) + (setf (aref ucon_freqs (cui ucon2)) + (make-instance 'ucon_freq :cui (cui ucon2) :lrl (lrl ucon2) + :pfstr (pfstr ucon2) :freq 1))))) (let ((ucon_freq-list '())) (dotimes (i (find-cui-max)) - (declare (fixnum i)) - (awhen (aref ucon_freqs i) - (push it ucon_freq-list))) + (declare (fixnum i)) + (awhen (aref ucon_freqs i) + (push it ucon_freq-list))) (sort ucon_freq-list #'> :key #'freq)))) (defun find-ucon2_freq-rel-tui-all (tui) @@ -187,9 +181,9 @@ (defun find-ucon2_freq-coc-tui-all (tui) (find-ucon2_freq-tui-all tui #'find-ucon2-coc-tui)) -#+(or cmu scl) +#+(or scl) (dolist (c '(ucon_freq ustr_freq usty_freq usrl_freq)) (let ((cl #+cmu (pcl:find-class c) - #+scl (find-class c))) + #+scl (find-class c))) #+cmu (pcl:finalize-inheritance cl) #+scl (clos:finalize-inheritance cl)))