From 485544d4feb13d3f463f54a5605b3a480bc49046 Mon Sep 17 00:00:00 2001 From: tpapp <tkpapp@gmail.com> Date: Wed, 4 Jan 2012 12:28:39 +0100 Subject: [PATCH] generic MEAN and MEDIAN, new function DISPLACE-ARRAY Objects other than sequences have means and medians (eg probability distributions, arrays, sequences/arrays wrapped in another object, etc), so it makes sense to make these functions generic. DISPLACE-ARRAY is a small utility function that is used in the implementation of MEDIAN for arrays, but is also of general utility because it makes the creation of displaced arrays simpler, dispensing with the need to specify the element type, and offering sensible defaults when one wants vectors. Also added tests for all the new functions/methods. --- arrays.lisp | 11 +++++++++++ numbers.lisp | 55 +++++++++++++++++++++++++++++++++++++++++++--------- package.lisp | 1 + tests.lisp | 29 +++++++++++++++++++++++++++ 4 files changed, 87 insertions(+), 9 deletions(-) diff --git a/arrays.lisp b/arrays.lisp index 76c1879..1f30150 100644 --- a/arrays.lisp +++ b/arrays.lisp @@ -16,3 +16,14 @@ arguments." (setf (row-major-aref new-array i) (row-major-aref array i))) new-array)) + +(declaim (inline displace-array)) +(defun displace-array (array &key (offset 0) + (dimensions (- (array-total-size array) + offset))) + "Return an array displaced to ARRAY with the given OFFSET and DIMENSIONS. +Default arguments displace to a vector." + (make-array dimensions + :displaced-to array + :displaced-index-offset offset + :element-type (array-element-type array))) diff --git a/numbers.lisp b/numbers.lisp index 03430cc..7340f26 100644 --- a/numbers.lisp +++ b/numbers.lisp @@ -84,21 +84,58 @@ Examples: interpolation coefficient V." (+ a (* v (- b a)))) -(declaim (inline mean)) -(defun mean (sample) - "Returns the mean of SAMPLE. SAMPLE must be a sequence of numbers." - (/ (reduce #'+ sample) (length sample))) - -(declaim (inline median)) -(defun median (sample) - "Returns median of SAMPLE. SAMPLE must be a sequence of real numbers." - (let* ((vector (sort (copy-sequence 'vector sample) #'<)) +(defgeneric mean (object) + (:documentation "Returns the mean of OBJECT. +Predefined methods work on sequences and arrays of numbers. Users can +define new methods.") + (:method ((object list)) + (let ((sum 0) + (count 0)) + (declare (fixnum count)) + (dolist (elt object) + (incf sum elt) + (incf count)) + (/ sum count))) + (:method ((object vector)) + ;; Need a separate method for vectors, since + ;; they could have fill-pointers which we need to respect. + (let ((n (length object))) + (/ (loop for index below n + summing (aref object index)) + n))) + (:method ((object array)) + (let ((n (array-total-size object))) + (/ (loop for index below n + summing (row-major-aref object index)) + n))) + (:method ((object sequence)) + ;; For implementations supporting custom sequence types. + (/ (reduce #'+ object) (length object)))) + +(defun median-in-place (vector) + (declare (vector vector)) + (let* ((vector (sort vector #'<)) (length (length vector)) (middle (truncate length 2))) (if (oddp length) (aref vector middle) (/ (+ (aref vector middle) (aref vector (1- middle))) 2)))) +(defgeneric median (object) + (:documentation + "Returns median of OBJECT. +Predefined methods work on sequences and arrays of numbers. Users can +define new methods.") + (:method ((object list)) + (median-in-place (copy-sequence 'vector object))) + (:method ((object array)) + (median-in-place (copy-sequence 'vector (if (vectorp object) + object + (displace-array object))))) + (:method ((object sequence)) + ;; For implementations supporting custom sequence types. + (median-in-place (copy-sequence 'vector object)))) + (declaim (inline variance)) (defun variance (sample &key (biased t)) "Variance of SAMPLE. Returns the biased variance if BIASED is true (the default), diff --git a/package.lisp b/package.lisp index 673ed30..8bdf060 100644 --- a/package.lisp +++ b/package.lisp @@ -101,6 +101,7 @@ #:array-index #:array-length #:copy-array + #:displace-array ;; Sequences #:copy-sequence #:deletef diff --git a/tests.lisp b/tests.lisp index bd2725f..7d7d1ca 100644 --- a/tests.lisp +++ b/tests.lisp @@ -47,6 +47,24 @@ (typep copy 'simple-array))) t) +(deftest displace-array.1 + (displace-array #2A((1 2) + (3 4))) + #(1 2 3 4)) + +(deftest displace-array.2 + (displace-array #2A((1 2) + (3 4)) + :offset 1) + #(2 3 4)) + +(deftest displace-array.3 + (displace-array #2A((1 2) + (3 4)) + :offset 1 + :dimensions '(3 1)) + #2A((2) (3) (4))) + (deftest array-index.1 (typep 0 'array-index) t) @@ -958,6 +976,12 @@ (mean '(1 2 10)) 13/3) +(deftest mean.4 + (mean #2A((1 2 3) + (4 5 6) + (7 8 9))) + 5) + (deftest median.1 (median '(100 0 99 1 98 2 97)) 97) @@ -966,6 +990,11 @@ (median '(100 0 99 1 98 2 97 96)) 193/2) +(deftest median.3 + (median #2A((100 0 99 1) + (98 2 97 96))) + 193/2) + (deftest variance.1 (variance (list 1 2 3)) 2/3) -- GitLab