calc-vec.el (calc-histogram):

(calcFunc-histogram):  Allow vectors as inputs.
(math-vector-avg): New function.

calc.texi (Manipulating Vectors): Mention that vectors can be used to
determine bins for `calc-histogram'.

5 files changed, 78 insertions, 20 deletions

diff --git a/doc/misc/ChangeLog b/doc/misc/ChangeLog
index c6d3c1be498..4c857c45a32 100644
--- a/doc/misc/ChangeLog
+++ b/doc/misc/ChangeLog
@@ -1,6 +1,11 @@
+2010-05-16  Jay Belanger  <jay.p.belanger@gmail.com>
+
+        * calc.texi (Manipulating Vectors): Mention that vectors can
+        be used to determine bins for `calc-histogram'.
+
 2010-05-13  Jay Belanger  <jay.p.belanger@gmail.com>
 
-        * calc.texi: Remove "\turnoffactive" commands througout.
+        * calc.texi: Remove "\turnoffactive" commands throughout.
 
 2010-05-08  Štěpán Němec  <stepnem@gmail.com>  (tiny change)
 
diff --git a/doc/misc/calc.texi b/doc/misc/calc.texi
index c578e919612..12b8d8e162d 100644
--- a/doc/misc/calc.texi
+++ b/doc/misc/calc.texi
@@ -20030,6 +20030,20 @@ range are ignored.  (You can tell if elements have been ignored by noting
 that the counts in the result vector don't add up to the length of the
 input vector.)
 
+If no prefix is given, then you will be prompted for a vector which
+will be used to determine the bins. (If a positive integer is given at
+this prompt, it will be still treated as if it were given as a
+prefix.)  Each bin will consist of the interval of numbers closest to
+the corresponding number of this new vector; if the vector 
+@expr{[a, b, c, ...]} is entered at the prompt, the bins will be 
+@expr{(-inf, (a+b)/2]}, @expr{((a+b)/2, (b+c)/2]}, etc.  The result of 
+this command will be a vector counting how many elements of the
+original vector are in each bin.
+
+The result will then be a vector with the same length as this new vector;
+each element of the new vector will be replaced by the number of
+elements of the original vector which are closest to it.
+
 @kindex H v H
 @kindex H V H
 With the Hyperbolic flag, @kbd{H V H} pulls two vectors from the stack.
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 27574c31d55..23338834d63 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,5 +1,9 @@
 2010-05-16  Jay Belanger  <jay.p.belanger@gmail.com>
 
+        * calc/calc-vec.el (calc-histogram):
+        (calcFunc-histogram):  Allow vectors as inputs.
+        (math-vector-avg): New function.
+
         * calc/calc-ext.el (math-group-float):  Have the number of digits
         being grouped depend on the radix (Bug#6189).
 
diff --git a/lisp/calc/README b/lisp/calc/README
index 3e3acaebb27..4b32ada63ad 100644
--- a/lisp/calc/README
+++ b/lisp/calc/README
@@ -74,6 +74,8 @@ Summary of changes to "Calc"
 
 Emacs 24.1
 
+* Gave `calc-histogram' the option of using a vector to determine the bins.
+
 * Added "O" option prefix.
 
 * Used "O" prefix to "d r" (`calc-radix') to turn on twos-complement mode.
diff --git a/lisp/calc/calc-vec.el b/lisp/calc/calc-vec.el
index c4de362ab36..5f426942e2f 100644
--- a/lisp/calc/calc-vec.el
+++ b/lisp/calc/calc-vec.el
@@ -451,16 +451,18 @@
      (calc-enter-result 1 "grad" (list 'calcFunc-grade (calc-top-n 1))))))
 
 (defun calc-histogram (n)
-  (interactive "NNumber of bins: ")
+  (interactive "P")
+  (unless (natnump n)
+    (setq n (math-read-expr (read-string "Centers of bins: "))))
   (calc-slow-wrapper
    (if calc-hyperbolic-flag
        (calc-enter-result 2 "hist" (list 'calcFunc-histogram
                                          (calc-top-n 2)
                                          (calc-top-n 1)
-                                         (prefix-numeric-value n)))
+                                         n))
      (calc-enter-result 1 "hist" (list 'calcFunc-histogram
                                        (calc-top-n 1)
-                                       (prefix-numeric-value n))))))
+                                       n)))))
 
 (defun calc-transpose (arg)
   (interactive "P")
@@ -1135,22 +1137,53 @@
   (if (Math-vectorp wts)
       (or (= (length vec) (length wts))
           (math-dimension-error)))
-  (or (natnump n)
-      (math-reject-arg n 'fixnatnump))
-  (let ((res (make-vector n 0))
-        (vp vec)
-        (wvec (Math-vectorp wts))
-        (wp wts)
-        bin)
-    (while (setq vp (cdr vp))
-      (setq bin (car vp))
-      (or (natnump bin)
-          (setq bin (math-floor bin)))
-      (and (natnump bin)
-           (< bin n)
-           (aset res bin (math-add (aref res bin)
-                                   (if wvec (car (setq wp (cdr wp))) wts)))))
-    (cons 'vec (append res nil))))
+  (cond ((natnump n)
+         (let ((res (make-vector n 0))
+               (vp vec)
+               (wvec (Math-vectorp wts))
+               (wp wts)
+               bin)
+           (while (setq vp (cdr vp))
+             (setq bin (car vp))
+             (or (natnump bin)
+                 (setq bin (math-floor bin)))
+            (and (natnump bin)
+                 (< bin n)
+                 (aset res bin 
+                       (math-add (aref res bin)
+                                 (if wvec (car (setq wp (cdr wp))) wts)))))
+           (cons 'vec (append res nil))))
+        ((Math-vectorp n) ;; n is a vector of midpoints
+         (let* ((bds (math-vector-avg n))
+                (res (make-vector (1- (length n)) 0))
+                (vp (cdr vec))
+                (wvec (Math-vectorp wts))
+                (wp wts)
+                num)
+           (while vp
+             (setq num (car vp))
+             (let ((tbds (cdr bds))
+                   (i 0))
+               (while (and tbds (Math-lessp (car tbds) num))
+                 (setq i (1+ i))
+                 (setq tbds (cdr tbds)))
+               (aset res i 
+                     (math-add (aref res i)
+                               (if wvec (car (setq wp (cdr wp))) wts))))
+             (setq vp (cdr vp)))
+           (cons 'vec (append res nil))))
+        (t
+         (math-reject-arg n "*Expecting an integer or vector"))))
+
+;;; Replace a vector [a b c ...] with a vector of averages
+;;; [(a+b)/2 (b+c)/2 ...]
+(defun math-vector-avg (vec)
+  (let ((vp (cdr vec))
+        (res nil))
+    (while (and vp (cdr vp))
+      (setq res (cons (math-div (math-add (car vp) (cadr vp)) 2) res)
+            vp (cdr vp)))
+    (cons 'vec (reverse res))))
 
 
 ;;; Set operations.