;;; -*- Mode:Common-Lisp; Package:USER; Base:10 -*- ;;;; This is a UNIVERSAL TESTER that can be used to generate learning curve and leave-one-out testing ;;;; comparisons between multiple learning systems and generate a standard output file that can be used ;;;; to generate graphs (currently has facilities for generating input for UNIX X-GRAPH) and statistical ;;;; testing (see the file T-TEST which runs a t-test on all pairs of systems). ;;;; Standard data file: A standard example data file (possibly with a theory) sets a set of standard ;;;; global variables. The UNIVERSAL-TESTER only crucially relies on *RAW-EXAMPLES* but the rest are ;;;; standard for many systems. UNIVERSAL-TESTER makes use of *GOAL* and *THEORY* in some situations. ;;;; *** Learning systems should not alter the values of these variables or destructively modify them *** ;;;; *** Changes should only be made by using dynamic scoping to temporarily rebind them *** ;;;; *CATEGORIES*: A list of all categories (classes) present in the data. ;;;; *FEATURE-NAMES*: An ordered list of names for the features used to describe examples. ;;;; *DOMAINS*: An ordered list of domains for each feature where a domain is either a list ;;;; of possible values or the symbol LINEAR to indicate a real valued feature. ;;;; *RAW-EXAMPLES*: A list of examples where the first element of an example is its class. ;;;; The two standard formats for examples assumed by many systems are: ;;;; Ordered example: ( ) ;;;; e.g. (+ (big red square)) ;;;; Alist example: ( ( ) ... ) ;;;; e.g. (+ (size big) (color red) (shape square)) ;;;; ID3-ALL works with both where a sequence of feature values can be a list or an array. ;;;; UNIVERSAL-TESTER only assumes that the first element is the class and as long as ;;;; the learners are happy with the example format it is too. ;;;; Most learning systems should be written to handle both data formats by using ;;;; conversion routines in DATA-UTILITIES to convert to correct format if needed. ;;;; *THEORY*: For theory revision problems a list of rules suitable for DEDUCE. ;;;; *GOAL*: A goal to be proven for positive examples using deduce, e.g. (CUP) ;;;; Standard for systems: A standard learning system X should have a couple of interface functions ;;;; to be used by UNIVERSAL-TESTER ;;;; (TRAIN-X ): Takes a list of training examples (taken from *raw examples*) ;;;; and returns a data structure representing the learned definition. ;;;; It normally makes use of the information in the variables described above. ;;;; (TEST-X ;;;; ): Takes an example (with category) and the result returned by the trainer and ;;;; returns a category (i.e. if this is EQ to (first ) it is correct). ;;;; If the system is incremental and can incorporate new examples into an evolving definition, ;;;; then the INCREMENTAL property of the system name should be set (e.g. (get 'X 'incremental) -> T). ;;;; The TRAIN-X function for an incremental system should take the existing learned structure ;;;; (result of previous training) as a second arguement. A value of NIL is given as the initial ;;;; learned structure at the beginging of each trial. A normal incremental system is only given ;;;; the new training examples added since the last increment. If the INCREMENTAL property value is ;;;; the special symbol FULL-DATA, then it is given all of the training data at each increment. ;;;; Optionally one can define the following additional functions ;;;; (TRAIN-X-OUTPUT : Called after training X to print out any information desired. ;;;; ) ;;;; (TEST-X-OUTPUT : Called after testing X to print out any informtation desired. ;;;; ) ;;;; (X-CONCEPT-COMPLEXITY ;;;; ) :Returns a number representing the complexity of the training result ;;;; This data is also stored in the output file. ;;;; Properties that can be attached to a system name include: ;;;; ;;;; INCREMENTAL: Set to T if system is incremental (set to FULL-DATA if require all previous data). ;;;; EXPECT-TRAINING-ERROR: Set to T if system not guaranteed to fit training data even when there is no noise. ;;;; PARAMETERS: Set to a list of global parameter variable names whose values should be included ;;;; in the comments of an output file. ;;;; PARENT-SYSTEMS: Set to a list of systems upon which the current system relies. The parameters of ;;;; all "ancestor" systems are included in the comments ;;;; Standard for output file: UNIVERSAL-TESTER generates an output file in a standard format. ;;;; There are a number of comments at the beginning listing information about the run gathered ;;;; from the arguements to the testing function. After that the format is: ;;;; ;;;; ;;;; ;;;; ... ;;;; Where a trial result is a list of data items for each point along a single learning curve. ;;;; (( ...) ;;;; ( ...) ;;;; ...) ;;;; Where the system results are ordered as they appear in ;;;; and each result is of the form: ;;;; ( ) ;;;; The format of a result is kept in *data-format* to allow for easy change to the code to add more items. ;;;; MAKE-PLOT-FILE is used to generate a plot file for X-GRAPH from this output file. ;;;; T-TEST-FILE in the file T-TEST can be used to run statistical t-tests on the results in this file. ;;;; The standard function used to run tests are RUN-STANDARD-TESTS and RUN-LEAVE-ONE-OUT ;;;; In order to allow running different systems at different times, one can generate and save a set of ;;;; training-set/test-set splits of a given set of data in a file using MAKE-SAVED-TESTS. ;;;; After making such a file of stored train/test trials, RUN-SAVED-TESTS can be used to run a system on ;;;; these trials. The function COMBINE-TEST-RESULTS combines two results files for the same saved ;;;; tests into one result file. (sys:compile-load-if "wimberly:mooney.data;data-utilities") (sys:compile-load-if "wimberly:mooney.test;t-test") ;;;; Global parameters ;;;;------------------------------------------------------ (defparameter *failed-training-error* nil "Causes error if not get 100% correct on training data") ;; Will not cause error if either the *noise* flag is set or the EXPECT-TRAINING-ERROR property of ;; the system name is set for a particular system that does not insure training-set consistency. ;; If value of flag is 'DUMP-DATA then the training data with the error will be saved in a ;; -BUG file but no break break will occur. (defparameter *print-examples* nil "Print out full examples when used") (defparameter *print-test-results* nil "Print results for each example during tests (only when wrong if set to 'if-wrong") (defparameter *print-training-result* nil "Print item representing result of training") ;;;; Variables used in the processing of examples. (defvar *test-examples* nil) (defvar *training-examples* nil) (defvar *current-training-examples* nil) (defvar *current-system* nil) (defvar *previous-examples* nil) (defvar *remaining-examples* nil) (defvar *provable-pos* nil) (defvar *provable-neg* nil) (defvar *unprovable-pos* nil) (defvar *unprovable-neg* nil) (defvar *current-theory-and-example-file* nil) (defvar *output-file* nil) (defvar *output-data* nil) (defparameter *data-format* '(train-accuracy test-accuracy train-time test-time concept-complexity)) ;;; Global variables used in DEDUCE (defvar *facts* nil) (defvar *assumptions* nil) (defvar *frules* nil) ;;;;---------------------------------------------------------------------------- ;;;; Macros for Universal Tester ;;;;---------------------------------------------------------------------------- (defmacro update-globals (examples pos-parameter neg-parameter) `(progn (setf ,pos-parameter nil ,neg-parameter nil) (dolist (example ,examples) (if (prove *theory* example) (setf ,pos-parameter (cons example ,pos-parameter)) (setf ,neg-parameter (cons example ,neg-parameter)))))) (defmacro example-set (example-base number fraction &optional excluded-examples) "Computes the set of examples which are taken from example-base and are the fraction of the required number." `(let* ((input-examples (if ,excluded-examples (set-difference ,example-base ,excluded-examples) ,example-base)) (required (ceiling (* ,number ,fraction))) (output (random-subseq input-examples required))) (when (/= required (length output)) (break "~%Disparity between number of required (~A) and obtained (~A) examples of type ~A. Check example distibution if concerned. Otherwise hit resume." required (length output) ',example-base )) output)) (defmacro append-file (output-file &rest format-forms) `(when ,output-file (with-open-file (output ,output-file :direction :output :if-exists :append :if-does-not-exist :create) (format output ,@format-forms)))) (defmacro funcall-if-exist (function &rest args) `(let ((function ,function)) (if (fboundp function) (funcall function ,@args)))) ;;;;---------------------------------------------------------------------------- ;;;; Basic Testing Functions ;;;;---------------------------------------------------------------------------- (defun run-standard-tests (systems &optional (number-trials 1) number-training (training-increment 10) number-test theory-and-example-file output-file (initial-training 0) percent-pos percent-provable-pos percent-provable-neg (output-function #'make-plot-file)) "Run standard learning curves comparing a number of systems and generate universal data file. systems: List of system names. Each system should have functions (train- training-examples) and (test- test-example data-structure) where data-structure represents the learned definition returned by the trainer. number-of-trials: Number of runs to average over. number-training: Maximum number of training instances in curve (leave NIL to rerun last train/test split). training-increment: Number of examples between plotted points on curve. number-test: Number of examples kept aside for testing performance (leave NIL to get what's left). theory-and-example-file: Standard data file used for input (leave NIL to get already loaded data file). output-file: Name of output file for collected data (leave NIL if don't want an output file). initial-training: Number of training examples to start learning curve at. (the 3 following control distribution of examples, leave NIL to get natural distribution in data) percent-pos: Percentage of positive examples in training and test sets. percent-provable-pos: Percentage of provable positive examples. percent-provable-neg: Percentage of provable negative examples. output-function: Function to call on output file when completed all trials." (load-theory-and-examples theory-and-example-file) (run-all-tests systems number-trials (list 'example-generator number-training number-test percent-pos percent-provable-pos percent-provable-neg) training-increment output-file initial-training output-function (format nil "; Theory and example file: ~A~%; Percent positive ex's: ~A~ ~%; Percent provable pos ex's: ~A, Percent provable neg ex's: ~A" (namestring *current-theory-and-example-file*) percent-pos percent-provable-pos percent-provable-neg))) (defvar *saved-splits* nil "Stored saved splits for use by saved-example-generator") (defun run-saved-tests (systems saved-splits-file &optional output-file (start-trial 1) training-increment initial-training (output-function #'make-plot-file)) "Run standard learning curves comparing a number of systems and generate universal data file. Gets training/test splits from a special file generated by MAKE-SAVED-TESTS so that exact same splits can be saved and rerun later. systems: List of system names. Each system should have functions (train- training-examples) and (test- test-example data-structure) where data-structure represents the learned definition returned by the trainer. saved-test-file: Name of file storing the saved train/test splits (made by make-saved-tests) training-increment: Number of examples between plotted points on curve (uses one stored in split file if not given). output-file: Name of output file for collected data (leave NIL if don't want an output file). initial-training: Number of training examples to start learning curve at (uses one stored in split file if not given). output-function: Function to call on output file when completed all trials." (let (theory-and-example-file) (with-open-file (input saved-splits-file :direction :input) (setf theory-and-example-file (read input)) (if training-increment (read input) (setf training-increment (read input))) (if initial-training (read input) (setf initial-training (read input))) (setf *saved-splits* (nthcdr (1- start-trial) (read input)))) (load-theory-and-examples theory-and-example-file)) (run-all-tests systems (length *saved-splits*) (list 'saved-example-generator) training-increment output-file initial-training output-function (format nil "; Saved splits file: ~A" (namestring (probe-file saved-splits-file))) start-trial)) (defvar *random-category-select* nil) (defun run-selected-categories-tests (systems &optional (number-trials 10) number-training (training-increment 10) training-categories number-test test-categories output-file theory-and-example-file (initial-training 0) (output-function #'make-plot-file)) "Like run standard tests except select subset of categories represented in training and test data." (let ((*random-category-select* t)) (load-theory-and-examples theory-and-example-file) (run-all-tests systems number-trials (list 'category-example-generator number-training `(quote ,training-categories) number-test `(quote ,test-categories)) training-increment output-file initial-training output-function (format nil "; Theory and example file: ~A~%; Training categories: ~A~ ~%; Test categories: ~A" (namestring *current-theory-and-example-file*) training-categories test-categories)))) (defun run-leave-one-out (systems &optional theory-and-example-file output-file (start-number 1) (output-function #'make-plot-file)) "Runs a standard leave-one-out test on the data. See run-standard-test for arg descriptions Starts with leaving out example in *raw-examples*" (load-theory-and-examples theory-and-example-file) (let ((num-examples (length *raw-examples*))) (setf *previous-examples* (subseq *raw-examples* 0 (1- start-number))) (setf *remaining-examples* (subseq *raw-examples* (1- start-number))) (run-all-tests systems (- num-examples (1- start-number)) '(leave-one-out) 1 output-file (1- num-examples) output-function (format nil "; Theory and example file: ~A~%; Leave one out" (namestring *current-theory-and-example-file*))))) (defun run-one-point (systems &optional (number-trials 10) number-training number-test theory-and-example-file output-file) (run-standard-tests systems number-trials number-training 1 number-test theory-and-example-file output-file (or number-training (length *training-examples*)))) (defun load-theory-and-examples (theory-and-example-file &optional always-load prune-theory) (when theory-and-example-file (setf theory-and-example-file (probe-file theory-and-example-file)) (unless (and (not always-load) *current-theory-and-example-file* (equal theory-and-example-file *current-theory-and-example-file*)) (setf *feature-names* nil *domains* nil *raw-examples* nil *theory* nil *goal* nil) (setf *current-theory-and-example-file* theory-and-example-file) (setf *test-examples* nil) (setf *training-examples* nil) (setf *previous-examples* nil) (setf *remaining-examples* nil) (setf *provable-pos* nil) (setf *provable-neg* nil) (setf *unprovable-pos* nil) (setf *unprovable-neg* nil) (load theory-and-example-file) (if prune-theory (prune-theory *theory*)) nil))) ;;;;---------------------------------------------------------------------------- ;;;; Internal Testing stuff ;;;;---------------------------------------------------------------------------- (defun run-all-tests (systems number-trials example-generator-form training-increment &optional (output-file nil) (initial-training 0) (output-function #'make-plot-file) output-comment (start-trial 1)) (let* ((existing-file (probe-file output-file)) (*output-file* (if (and existing-file (not (pathname-version output-file)) (= start-trial 1) (not (y-or-n-p "Append data to existing file: ~A ?" existing-file))) (progn (setf existing-file nil) (make-new-pathname output-file ".LISP")) (or existing-file output-file)))) (dotimes (index number-trials) (multiple-value-bind (total-training-examples test-examples) (eval example-generator-form) ;; If first trial and new output file print out header information (when (and (zerop index) (not existing-file)) (if output-comment (append-file *output-file* "~A" output-comment)) (append-file *output-file* "~%~%; Number of trials: ~A,~%; Training increment: ~A,~%; Training start: ~A," number-trials training-increment initial-training) (append-file *output-file* "~%; Maximum training examples: ~A,~%; Number of test examples: ~A." (length total-training-examples) (length test-examples)) (mapc #'note-parameters (remove-duplicates (mapcan #'(lambda (system) (cons system (ancestor-systems system))) systems))) (append-file *output-file* "~%~%~A~%" systems)) ;; run-single-test is responsible for running the training and test functions on a single trial. It is also ;; responsible for writing the test results for a single trial to output-file. It is also assumed that all results ;; start with 0 training examples (the case where the theory has been unperturbed). (format t "~%~%~125~") (format t "~%Results for trial ~A:" (+ start-trial index)) (setf *output-data* nil) (run-one-trial total-training-examples training-increment test-examples systems initial-training) (append-file *output-file* "~%~A" (reverse *output-data*)))) (format t "~%~%~125~~%") (when *output-file* ;; output function is responsible for generating plot data or t-test data, or both, depending on its definition. It ;; should also be capable of comparing n different systems for output. (when output-function (funcall output-function *output-file*))))) (defun note-parameters (system) ;; Write to output file the parameters of this particular system (when (get system 'parameters) (append-file *output-file* "~%~%; ~A parameters:" system) (dolist (var (get system 'parameters)) (append-file *output-file* "~%; ~A = ~A" var (eval var))))) (defun print-parameters (system) "Printout parameters for system and all its parents" (when (get system 'parameters) (format t "~%~%~A parameters:" system) (dolist (var (get system 'parameters)) (format t "~%~A = ~A" var (eval var)))) (mapc #'print-parameters (get system 'parent-systems))) (defun ancestor-systems (system) "Return all parents of a system" (when (get system 'parent-systems) (mapcan #'(lambda (parent) (cons parent (ancestor-systems parent))) (get system 'parent-systems)))) (defun run-one-trial (total-training-examples training-increment test-examples systems initial-training) (dolist (system systems) (setf (get system 'result) nil)) (do* ((previous-training-length 0 training-length) (training-length initial-training (if (listp training-increment) (or (pop training-increment) (1+ (length total-training-examples))) (+ training-length training-increment))) (training-examples (subseq total-training-examples 0 training-length) (subseq total-training-examples 0 training-length)) (new-training-examples training-examples (subseq training-examples previous-training-length))) ((> training-length (length total-training-examples))) (setf *current-training-examples* training-examples) (format t "~%~%~125~") (format t "~%Test results for ~R training example~:P:" training-length) (dolist (system systems) (setf *current-system* system) (let ((training-function (append-symbols 'train- system)) (test-function (append-symbols 'test- system))) (init-system-output) (test system test-function (train system training-function test-function training-examples new-training-examples) test-examples))) (single-training-output training-length systems))) (defun init-system-output () (when *output-file* (push (make-list (length *data-format*)) *output-data*))) (defun add-output-datum (field-name value) (when *output-file* (set-field (first *output-data*) field-name value))) (defun single-training-output (training-length systems) (when *output-file* (let (output-results) (dotimes (i (length systems)) (push (pop *output-data*) output-results)) (push (cons training-length output-results) *output-data*)))) (defun train (system training-function test-function training-examples new-training-examples) (let ((training-time 0) percent-correct) (format t "~%~%Training ~A..." system) (trace-print *print-examples* "~%New training examples ~%~A" new-training-examples) (setf training-time (get-internal-run-time)) (let ((training-result (case (get system 'incremental) (nil (funcall training-function training-examples)) (full-data (funcall training-function training-examples (get system 'result))) (t (funcall training-function new-training-examples (get system 'result)))))) (setf training-time (- (get-internal-run-time) training-time)) (setf (get system 'result) training-result) (funcall-if-exist (append-symbols 'train- system '-output) training-result training-examples) (trace-print *print-training-result* "~%Training-result: ~%~A" training-result) (setf percent-correct (get-percent-correct test-function training-result training-examples)) (if (and *failed-training-error* (not *noise*) (not (= percent-correct 100)) (not (get system 'expect-training-error))) (if (and (eq *failed-training-error* T) (y-or-n-p "~%~A classified only ~,3F% of the training examples correctly. Break?" test-function percent-correct)) (break) (dump-data system training-examples training-result))) (add-output-datum 'train-accuracy percent-correct) (add-output-datum 'train-time (convert-time training-time)) (add-output-datum 'concept-complexity (funcall-if-exist (append-symbols system '-concept-complexity) training-result)) training-result))) (defun get-percent-correct (test-function training-result training-examples) (if training-examples (let ((number-right 0)) (dolist (example training-examples (* 100.0 (/ number-right (length training-examples))) ) (when (eq (funcall test-function example training-result) (first example)) (setf number-right (1+ number-right))))) 100)) (defun dump-data (&optional (system *current-system*) (training-examples *current-training-examples*) training-result) (with-open-file (bug-file (make-new-pathname (format nil "~A-BUG" (pathname-name (namestring *output-file*))) (namestring *output-file*)) :direction :output) (format bug-file ";;; -*- Mode:Common-Lisp; Package:USER -*-~%") (format bug-file ";;;Buggy examples for ~A~%~%(setf *buggy-examples* ~% '~A)" system training-examples) (if training-result (format bug-file ";;;Buggy training-result for ~A~%~%(setf *training-result* ~% '~A)" system training-result)) )) (defun test (system test-function training-result test-examples) (format t "~%~%Testing ~A..." system) (let ((number-right 0) (total-test-time 0) (percent-correct 100) test-time answer (length-test-examples (length test-examples))) (unless (zerop length-test-examples) (dolist (example test-examples) (setf test-time (get-internal-run-time)) (setf answer (funcall test-function example training-result)) (setf total-test-time (+ total-test-time (- (get-internal-run-time) test-time))) (when (or (eq *print-test-results* t) (and (eq *print-test-results* 'if-wrong) (not (eq answer (first example))))) (trace-print *print-examples* "~%~%~A" example) (format t "~%~AReal category: ~A; Classified as: ~A" (if (eq answer (first example)) " " "**") (first example) answer)) (when (eq answer (first example)) (incf number-right))) (setf percent-correct (* 100.0 (/ number-right length-test-examples))) (format t "~%~A classified ~,2F% of the ~D test cases correctly." test-function percent-correct length-test-examples)) (funcall-if-exist (append-symbols 'test- system '-output) training-result test-examples) (add-output-datum 'test-accuracy percent-correct) (add-output-datum 'test-time (convert-time total-test-time)))) ;;;;---------------------------------------------------------------------------- ;;;; Stuff for saving splits and combining seperate runs from saved splits ;;;;---------------------------------------------------------------------------- (defun make-saved-tests (output-file &optional number-trials number-training (training-increment 10) number-test theory-and-examples-file (initial-training 0) percent-pos percent-provable-pos percent-provable-neg) "Make a file that permanently stores a set of train/test splits for this data file. See RUN-STANDARD-TESTS for description of args" ;; File stores in order: theory-and-examples-file, training-increment, initial-training, and list ;; of splits each of form ( ) ;; Examples are simply stored as a number indicating their position in *raw-examples* (load-theory-and-examples theory-and-examples-file) (let (splits) (dotimes (i number-trials) (example-generator number-training number-test percent-pos percent-provable-pos percent-provable-neg) (push (list (use-position-number *training-examples*) (use-position-number *test-examples*)) splits)) (with-open-file (output output-file :direction :output) (format output ";;;; ~D stored data splits with ~D training-examples and ~D test examples" number-trials number-training (or number-test (length *test-examples*))) (print (namestring *current-theory-and-example-file*) output) (print training-increment output) (print initial-training output) (format output "~%~%(~:{ ~%(~A~% ~A) ~}~%)" splits)))) (defun use-position-number (examples) (mapcar #'(lambda (example) (position example *raw-examples*)) examples)) (defun combine-test-results (input-file1 input-file2 output-file) "Combines runs from two separate result files from same saved splits into a new result file as if they were run at the same time" (with-open-file (in1 input-file1 :direction :input) (with-open-file (in2 input-file2 :direction :input) (let ((comment1 (read-line in1))(comment2 (read-line in2))) (when (or (string-equal comment1 comment2) (y-or-n-p "~%Files not from same saved tests, combine anyway?")) (with-open-file (out output-file :direction :output) (loop (if (not (string-equal comment1 comment2)) (return nil)) (format out "~A~%" comment1) (cond ((equal (peek-char nil in1) #\() (setf comment1 "") (return nil)) (t (setf comment1 (read-line in1)))) (cond ((equal (peek-char nil in2) #\() (setf comment2 "") (return nil)) (t (setf comment2 (read-line in2))))) (loop (format out "~A~%" comment1) (if (equal (peek-char nil in1) #\() (return nil) (setf comment1 (read-line in1)))) (loop (format out "~A~%" comment2) (if (equal (peek-char nil in2) #\() (return nil) (setf comment2 (read-line in2)))) (format out "; Combined results of ~A and ~%; ~A~%" (pathname (probe-file input-file1)) (pathname (probe-file input-file2))) (format out "~%~A~%" (append (read in1) (read in2))) (let (run1 run2) (loop (setf run1 (read in1 nil nil) run2 (read in2 nil nil)) (cond ((and (null run1) (null run2)) (return nil)) ((or (null run1) (null run2)) (break "Unequal number of runs in two files") (return nil)) (t (format out "~%~A" (mapcar #'(lambda (set1 set2) (if (eql (first set1) (first set2)) (append set1 (rest set2)) (break "Unequal training set sizes"))) run1 run2)))))))))))) ;;;;---------------------------------------------------------------------------- ;;;; Sample Example Generators for Generating Training and Test sets ;;;;---------------------------------------------------------------------------- (defun leave-one-out () (if (null *remaining-examples*) (values nil nil) (progn (setf *test-examples* (list (pop *remaining-examples*))) (setf *training-examples* (append *previous-examples* *remaining-examples*)) (push (first *test-examples*) *previous-examples*) (values *training-examples* *test-examples*)))) (defun category-example-generator (number-training &optional train-categories number-test test-categories) (cond ((null train-categories) (if (null test-categories) (break "No train or test categories given") (setf train-categories (set-difference *categories* test-categories)))) ((null test-categories) (setf test-categories (set-difference *categories* train-categories)))) (let ((possible-train-examples (remove-if-not #'(lambda (ex) (member (first ex) train-categories)) *raw-examples*)) (possible-test-examples (remove-if-not #'(lambda (ex) (member (first ex) test-categories)) *raw-examples*))) (setf *training-examples* (random-subseq possible-train-examples number-training)) (setf *test-examples* (if (null number-test) (set-difference possible-test-examples *training-examples*) (random-subseq (set-difference possible-test-examples *training-examples*) number-test))) (values *training-examples* *test-examples*))) (defun example-generator (&optional number-training number-test percent-pos percent-provable-pos percent-provable-neg) "Cases: 1. To cause the system to generate provable and unprovable training and test examples from an input data file, submit theory-and-example-file and all input distribution parameters. 2. To cause the system to simply draw the required number of training and test samples from a raw data file, without causing the examples to fit any distribution parameters, specify the number of training and number of test only (number test defaults to remaining examples). 3. To use the examples used for the previous run, call example-generator with no arguments." (multiple-value-setq (*training-examples* *test-examples*) (cond ((and number-training number-test percent-pos percent-provable-pos percent-provable-neg) (or *provable-pos* *provable-neg* *unprovable-pos* *unprovable-neg* (separate-examples)) (generate-examples number-training number-test percent-pos percent-provable-pos percent-provable-neg)) (number-training (multiple-value-bind (training-examples test-examples) (random-subseq *raw-examples* number-training) (if number-test (setf test-examples (random-subseq test-examples number-test))) (values training-examples test-examples))) ((not (or number-training number-test )) (if *training-examples* (values *training-examples* *test-examples*) (error "There are no test or training examples from a previous run.") )) (t (error "There seems to be some parameters left out in your description of the desired examples.")))) (values *training-examples* *test-examples*)) (defun saved-example-generator () (let ((split (pop *saved-splits*))) (setf *training-examples* (mapcar #'(lambda (position) (elt *raw-examples* position)) (first split))) (setf *test-examples* (mapcar #'(lambda (position) (elt *raw-examples* position)) (second split))) (values *training-examples* *test-examples*))) (defun separate-examples () (let (pos-examples neg-examples) (setf pos-examples (get-positives *raw-examples*) neg-examples (get-negatives *raw-examples*)) (update-globals pos-examples *provable-pos* *unprovable-pos*) (update-globals neg-examples *provable-neg* *unprovable-neg*))) (defun generate-examples (number-training number-test percent-pos percent-provable-pos percent-provable-neg) (let* ((fraction-pos (/ percent-pos 100)) (fraction-neg (- 1 fraction-pos)) (fraction-provable-pos (* fraction-pos (/ percent-provable-pos 100))) (fraction-unprovable-pos (- fraction-pos fraction-provable-pos)) (fraction-provable-neg (* fraction-neg (/ percent-provable-neg 100))) (fraction-unprovable-neg (- fraction-neg fraction-provable-neg)) (training-provable-pos (example-set *provable-pos* number-training fraction-provable-pos)) (training-unprovable-pos (example-set *unprovable-pos* number-training fraction-unprovable-pos)) (training-provable-neg (example-set *provable-neg* number-training fraction-provable-neg)) (training-unprovable-neg (example-set *unprovable-neg* number-training fraction-unprovable-neg)) (test-provable-pos (example-set *provable-pos* number-test fraction-provable-pos training-provable-pos)) (test-unprovable-pos (example-set *unprovable-pos* number-test fraction-unprovable-pos training-unprovable-pos)) (test-provable-neg (example-set *provable-neg* number-test fraction-provable-neg training-provable-neg)) (test-unprovable-neg (example-set *unprovable-neg* number-test fraction-unprovable-neg training-provable-neg)) (returned-training (random-subseq (append training-provable-pos training-unprovable-pos training-provable-neg training-unprovable-neg) number-training)) (returned-test (random-subseq (append test-provable-pos test-unprovable-pos test-provable-neg test-unprovable-neg) number-test))) (when *print-examples* (let* ((returned-training-pos (get-positives returned-training)) (returned-training-neg (set-difference returned-training returned-training-pos)) (returned-test-pos (get-positives returned-test)) (returned-test-neg (set-difference returned-test returned-test-pos))) (format t "~%Returned examples:") (format t "~%Training: ~A provable positives and ~A provable negatives out of ~A positives and ~A negatives" (length (proven-examples *theory* returned-training-pos)) (length (proven-examples *theory* returned-training-neg)) (length returned-training-pos) (length returned-training-neg)) (format t "~%Test: ~A provable positives and ~A provable negatives out of ~A positives and ~A negatives" (length (proven-examples *theory* returned-test-pos)) (length (proven-examples *theory* returned-test-neg)) (length returned-test-pos) (length returned-test-neg)) )) (values returned-training returned-test))) (defvar *current-theory* nil) (defvar *current-facts* nil) (defun prove (theory example &optional (goal *goal*)) (unless (eq theory *current-theory*) (setf *current-theory* theory) (clear-rulebase) (index-brules theory)) (setf *facts* (cdr example) *frules* nil *assumptions* nil) (unless (eq (cdr example) *current-facts*) (setf *current-facts* (cdr example)) (clear-database) (index-facts (cdr example))) (let ((answer (retrieve goal))) (gfirst answer))) (defun get-positives (examples) (mapcan #'(lambda (example) (when (eq (first example) '+) (list example))) examples)) (defun get-negatives (examples) (mapcan #'(lambda (example) (when (eq (first example) '-) (list example))) examples)) (defun proven-examples ( theory examples) (let (proven-examples) (dolist (example examples (reverse proven-examples)) (when (prove theory example ) (setf proven-examples (cons example proven-examples)))))) (defun prune-theory (theory) (do ((current-theory theory ) (rule (car theory) (car current-theory)) output-theory) ((null current-theory) (reverse output-theory)) (setf current-theory (remove rule (cdr current-theory) :test #'(lambda (ignore elt2) (and (alphabetic-variant (second rule)(second elt2)) (if (subsetp (cddr rule)(cddr elt2) :test #'alphabetic-variant) (progn (format t "~%Deleting rule ~%~A from the theory, since it is subsumed by rule ~%~A." elt2 rule) t) (when (subsetp (cddr elt2) (cddr rule) :test #'alphabetic-variant) (format t "~%Deleting rule ~%~A from the theory, since it is subsumed by rule ~%~A." rule elt2) (setf rule elt2)))))) output-theory (cons rule output-theory)))) (defun equal-or-unify (e1 e2) (or (equal e1 e2) (unify e1 e2))) ;;;;---------------------------------------------------------------------------- ;;;; Accessory and Utility Functions ;;;;---------------------------------------------------------------------------- (defun convert-time (time) (float (/ time internal-time-units-per-second))) (defun random-subseq (list length) (unless (zerop length) (when list (do* ((point (random (length list)) (random (length remain))) (element (elt list point) (elt remain point)) (remain (delete element (copy-list list) :start point) (delete element remain :start point)) (outlist (list element) (cons element outlist)) (counter (1- length) (1- counter))) ((or (zerop counter) (null remain)) (values outlist remain)))))) (defun make-new-pathname (filename &optional defaults) (when filename (setf filename (merge-pathnames filename defaults nil)) (if (pathname-version filename) filename (let ((current-name (probe-file filename))) (if current-name (merge-pathnames filename defaults (1+ (PATHNAME-VERSION (namestring current-name)))) filename))))) (defun get-field (item field-name &optional (field-list *data-format*)) "Returns element of item in the position that field-name occupies in the field-list" (nth (position field-name field-list) item)) (defun set-field (item field-name value &optional (field-list *data-format*)) (setf (nth (position field-name field-list) item) value)) ;;;;---------------------------------------------------------------------------- ;;;; X-graph File Generator ;;;;---------------------------------------------------------------------------- (defun make-plot-file (input-file &optional (data-item 'test-accuracy)) "Create an X-GRAPH file from a universal data file. Puts output in fname.plot. Data-item can be train-accuracy, test-accuracy, train-time, or test-time" (let (assoc-list system-list) (with-open-file (stream input-file :direction :input) (setf system-list (read stream)) (let (run) (setf run (read stream)) (setf assoc-list (mapcar #'(lambda (point) (list (first point) (rest point))) run)) (loop (if (null (setf run (read stream nil nil))) (return nil) (progn (dolist (point run) (let ((point-list (assoc (first point) assoc-list))) (if point-list (push (rest point) (rest point-list)) (error "Unknown point: ~A" (first point)))))))))) (with-open-file (output (make-new-pathname (format nil ".~A-plot" data-item) input-file) :direction :output) (dolist (system system-list) (format output "\"~A" system) (dolist (point-list assoc-list) (format output "~%~D ~F" (first point-list) (let ((sum 0)) (dolist (set (rest point-list)) (incf sum (get-field (get-field set system system-list) data-item))) (/ sum (length (rest point-list)))))) (format output "~%~%")))))