X-Git-Url: http://git.kpe.io/?p=umlisp.git;a=blobdiff_plain;f=composite.lisp;h=1c453e1805c31b9cf8823a9f642703cdf6c6842f;hp=d31c51321494f3cb4b9422e2085c3d1dfe660a80;hb=HEAD;hpb=cd8b476663925be5a1ebbeb569a056e2e5b93aba diff --git a/composite.lisp b/composite.lisp index d31c513..1c453e1 100644 --- a/composite.lisp +++ b/composite.lisp @@ -1,19 +1,32 @@ -;;;; $Id: composite.lisp,v 1.1 2002/10/08 22:08:56 kevin Exp $ - -(in-package :umlisp) - +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: composite.lisp +;;;; Purpose: Composite Classes for UMLisp +;;;; Author: Kevin M. Rosenberg +;;;; Created: Apr 2000 +;;;; +;;;; This file, part of UMLisp, is +;;;; 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. +;;;; ************************************************************************* + +(in-package #:umlisp) ;;; Semantic type constants (defun find-tui-word (words) - (gu:aif (car (find-usty-word words)) - (tui gu::it) + (aif (car (find-usty-word words)) + (tui it) nil)) -(gu:memoize 'find-tui-word) +(memoize 'find-tui-word) (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")) @@ -27,120 +40,112 @@ (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) - (gu:aif (funcall cui2-func c) - (let ((ucon2 (find-ucon-cui gu::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) +#+mrcoc (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)) ;;; Composite Objects -(defclass ucon_freq (umlsclass) - ((ucon :type ucon :initarg :ucon :reader ucon) - (freq :type fixnum :initarg :freq :accessor freq)) - (:metaclass ml-class) - (:default-initargs :cui nil :pfstr nil :freq nil) - (:title "Concept and Count") - (:fields (cui :string fmt-cui) (freq :fixnum) (pfstr :cdata)) - (:ref-fields (cui find-ucon-cui)) - (:documentation "Composite object of ucon/freq")) - -(defun ucon_freq-cui (c) - (cui (ucon c))) - -(defun ucon_freq-pfstr (c) - (pfstr (ucon c))) - -(defclass ustr_freq (umlsclass) - ((ustr :type ustr :initarg :ustr :reader ustr) - (freq :type fixnum :initarg :freq :accessor freq)) - (:metaclass ml-class) - (:default-initargs :cui nil :pfstr nil :freq nil) - (:title "String and Count") - (:fields (sui :string fmt-sui) (freq :fixnum) (stt :string) (lrl :fixnum) (str :cdata)) - (:ref-fields (sui find-ustr-sui)) - (:documentation "Composite object of ustr/freq")) - -(defun ustr_freq-sui (s) - (sui (ustr s))) - -(defun ustr_freq-str (s) - (str (ustr s))) - -(defun ustr_freq-lrl (s) - (lrl (ustr s))) - -(defun ustr_freq-stt (s) - (stt (ustr s))) - -(defclass usty_freq (umlsclass) - ((usty :type usty :initarg :usty :reader usty) - (freq :type fixnum :initarg :freq :accessor freq)) - (:metaclass ml-class) - (:default-initargs :usty nil :freq nil) - (:title "Semantic Type and Count") - (:ref-fields (tui find-ucon-tui "subobjects=no")) - (:fields (tui :string fmt-tui) (freq :fixnum) (sty :string)) - (:documentation "Composite object of usty/freq")) - -(defun usty_freq-tui (s) - (tui (usty s))) - -(defun usty_freq-sty (s) - (sty (usty s))) - -(defclass usrl_freq (umlsclass) - ((usrl :type usrl :initarg :usrl :reader usrl) - (freq :type fixnum :initarg :freq :accessor freq)) - (:metaclass ml-class) - (:default-initargs :usrl nil :freq nil) - (:title "Source and Count") - (:ref-fields (sab find-ustr-sab)) - (:fields (sab :string) (freq :commainteger) (srl :fixnum)) - (:documentation "Composite object of usrl/freq")) - -(defun usrl_freq-sab (s) - (sab (usrl s))) - -(defun usrl_freq-srl (s) - (srl (usrl s))) - +(defclass freq (hyperobject) + ((freq :value-type integer :initarg :freq :accessor freq + :print-formatter fmt-comma-integer)) + (:metaclass hyperobject-class) + (:default-initargs :freq 0) + (:user-name "Frequency class" "Frequency classes") + (:default-print-slots freq) + (:description "Base class containing frequency slot, used for multi-inherited objects")) + +(defclass ucon_freq (ucon freq) + () + (:metaclass hyperobject-class) + (:user-name "Concept and Count" "Concepts and Counts") + (:default-print-slots cui freq pfstr) + (:description "Composite object of ucon/freq")) + +(defclass ustr_freq (ustr freq) + () + (:metaclass hyperobject-class) + (:user-name "String and Count" "Strings and Counts") + (:default-print-slots sui freq stt lrl str) + (:description "Composite object of ustr/freq")) + +(defclass usty_freq (usty freq) + () + (:metaclass hyperobject-class) + (:user-name "Semantic Type and Count" "Semantic Types and Counts") + (:default-print-slots tui freq sty) + (:description "Composite object of usty/freq")) + +(defun find-usty_freq-all () + (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))) + (sort usty_freqs #'> :key #'freq))) + + +(defclass usrl_freq (usrl freq) + () + (:metaclass hyperobject-class) + (:user-name "Source and Count" "Sources and Counts") + (:default-print-slots sab freq srl) + (:description "Composite object of usrl/freq")) ;; Frequency finding functions -(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)) - (gu:aif (cui2 ucoc) - (let ((ucon2 (find-ucon-cui gu::it))) + +(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))) + (sort freqs #'> :key #'freq))) + +#+mrcoc (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))) (when (ucon-is-tui? ucon2 tui) - (push (make-instance 'ucon_freq :ucon 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) + +#+mrcoc (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" (find-ucon2-str&sty str sty #'find-ucon2-coc-tui)) @@ -157,21 +162,28 @@ (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 - (gu:aif (aref ucon_freqs (cui ucon2)) - (setf (freq gu::it) (1+ (freq gu::it))) - (setf (aref ucon_freqs (cui ucon2)) - (make-instance 'ucon_freq :ucon 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)) - (gu:awhen (aref ucon_freqs i) - (push gu::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) "Sorted list of ucon_freq with semantic type tui that are rel's of ucons with semantic type tui" (find-ucon2_freq-tui-all tui #'find-ucon2-rel-tui)) -(defun find-ucon2_freq-coc-tui-all (tui) +#+mrcoc (defun find-ucon2_freq-coc-tui-all (tui) (find-ucon2_freq-tui-all tui #'find-ucon2-coc-tui)) +#+(or scl) +(dolist (c '(ucon_freq ustr_freq usty_freq usrl_freq)) + (let ((cl #+cmu (pcl:find-class c) + #+scl (find-class c))) + #+cmu (pcl:finalize-inheritance cl) + #+scl (clos:finalize-inheritance cl)))