Mercurial > emacs
view lisp/calc/calc-stat.el @ 110523:a5ad4f188e19
Synch Semantic to CEDET 1.0.
Move CEDET ChangeLog entries to new file lisp/cedet/ChangeLog.
* semantic.el (semantic-version): Update to 2.0.
(semantic-mode-map): Add "," and "m" bindings.
(navigate-menu): Update.
* semantic/symref.el (semantic-symref-calculate-rootdir):
New function.
(semantic-symref-detect-symref-tool): Use it.
* semantic/symref/grep.el (semantic-symref-grep-shell): New var.
(semantic-symref-perform-search): Use it. Calculate root dir with
semantic-symref-calculate-rootdir.
(semantic-symref-derive-find-filepatterns): Improve error message.
* semantic/symref/list.el
(semantic-symref-results-mode-map): New bindings.
(semantic-symref-auto-expand-results): New option.
(semantic-symref-results-dump): Obey auto-expand.
(semantic-symref-list-expand-all, semantic-symref-regexp)
(semantic-symref-list-contract-all)
(semantic-symref-list-map-open-hits)
(semantic-symref-list-update-open-hits)
(semantic-symref-list-create-macro-on-open-hit)
(semantic-symref-list-call-macro-on-open-hits): New functions.
(semantic-symref-list-menu-entries)
(semantic-symref-list-menu): New vars.
(semantic-symref-list-map-open-hits): Move cursor to beginning of
match before calling the mapped function.
* semantic/doc.el
(semantic-documentation-comment-preceeding-tag): Do nothing if the
mode doesn't provide comment-start-skip.
* semantic/scope.el
(semantic-analyze-scope-nested-tags-default): Strip duplicates.
(semantic-analyze-scoped-inherited-tag-map): Take the tag we are
looking for as part of the scoped tags list.
* semantic/html.el (semantic-default-html-setup): Add
senator-step-at-tag-classes.
* semantic/decorate/include.el
(semantic-decoration-on-unknown-includes): Change light bgcolor.
(semantic-decoration-on-includes-highlight-default): Check that
the include tag has a postion.
* semantic/complete.el (semantic-collector-local-members):
(semantic-complete-read-tag-local-members)
(semantic-complete-jump-local-members): New class and functions.
(semantic-complete-self-insert): Save excursion before completing.
* semantic/analyze/complete.el
(semantic-analyze-possible-completions-default): If no completions
are found, return the raw by-name-only completion list. Add FLAGS
arguments. Add support for 'no-tc (type constraint) and
'no-unique, or no stripping duplicates.
(semantic-analyze-possible-completions-default): Add FLAGS arg.
* semantic/util-modes.el
(semantic-stickyfunc-show-only-functions-p): New option.
(semantic-stickyfunc-fetch-stickyline): Don't show stickytext for
the very first line in a buffer.
* semantic/util.el (semantic-hack-search)
(semantic-recursive-find-nonterminal-by-name)
(semantic-current-tag-interactive): Deleted.
(semantic-describe-buffer): Fix expand-nonterminal. Add
lex-syntax-mods, type relation separator char, and command
separation char.
(semantic-sanity-check): Only message if called interactively.
* semantic/tag.el (semantic-tag-deep-copy-one-tag): Copy the
:filename property and the tag position.
* semantic/lex-spp.el (semantic-lex-spp-lex-text-string):
Add recursion limit.
* semantic/imenu.el (semantic-imenu-bucketize-type-members):
Make this buffer local, not the obsoleted variable.
* semantic/idle.el: Add breadcrumbs support.
(semantic-idle-summary-current-symbol-info-default)
(semantic-idle-tag-highlight)
(semantic-idle-completion-list-default): Use
semanticdb-without-unloaded-file-searches for speed, and to
conform to the controls that specify if the idle timer is supposed
to be parsing unparsed includes.
(semantic-idle-symbol-highlight-face)
(semantic-idle-symbol-maybe-highlight): Rename from *-summary-*.
Callers changed.
(semantic-idle-work-parse-neighboring-files-flag): Default to nil.
(semantic-idle-work-update-headers-flag): New var.
(semantic-idle-work-for-one-buffer): Use it.
(semantic-idle-local-symbol-highlight): Rename from
semantic-idle-tag-highlight.
(semantic-idle-truncate-long-summaries): New option.
* semantic/ia.el (semantic-ia-cache)
(semantic-ia-get-completions): Deleted. Callers changed.
(semantic-ia-show-variants): New command.
(semantic-ia-show-doc): If doc is empty, don't make a temp buffer.
(semantic-ia-show-summary): If there isn't anything to show, say so.
* semantic/grammar.el (semantic-grammar-create-package):
Save the buffer even in batch mode.
* semantic/fw.el
(semanticdb-without-unloaded-file-searches): New macro.
* semantic/dep.el (semantic-dependency-find-file-on-path):
Fix case dereferencing ede-object when it is a list.
* semantic/db-typecache.el (semanticdb-expand-nested-tag)
(semanticdb-typecache-faux-namespace): New functions.
(semanticdb-typecache-file-tags)
(semanticdb-typecache-merge-streams): Use them.
(semanticdb-typecache-file-tags): When deriving tags from a file,
give the mode a chance to monkey with the tag copy.
(semanticdb-typecache-find-default): Wrap find in save-excursion.
(semanticdb-typecache-find-by-name-helper): Merge found names down.
* semantic/db-global.el
(semanticdb-enable-gnu-global-in-buffer): Don't show messages if
GNU Global is not available and we don't want to throw an error.
* semantic/db-find.el (semanticdb-find-result-nth-in-buffer):
When trying to normalize the tag to a buffer, don't error if
set-buffer method doesn't exist.
* semantic/db-file.el (semanticdb-save-db): Simplify msg.
* semantic/db.el (semanticdb-refresh-table): If forcing a
refresh on a file not in a buffer, use semantic-find-file-noselect
and delete the buffer after use.
(semanticdb-current-database-list): When calculating root via
hooks, force it through true-filename and skip the list of
possible roots.
* semantic/ctxt.el (semantic-ctxt-imported-packages): New.
* semantic/analyze/debug.el
(semantic-analyzer-debug-insert-tag): Reset standard output to
current buffer.
(semantic-analyzer-debug-global-symbol)
(semantic-analyzer-debug-missing-innertype): Change "prefix" to
"symbol" in messages.
* semantic/analyze/refs.el: (semantic-analyze-refs-impl)
(semantic-analyze-refs-proto): When calculating value, make sure
the found tag is 'similar' to the originating tag.
(semantic--analyze-refs-find-tags-with-parent): Attempt to
identify matches via imported symbols of parents.
(semantic--analyze-refs-full-lookup-with-parents): Do a deep
search during the brute search.
* semantic/analyze.el
(semantic-analyze-find-tag-sequence-default): Be robust to
calculated scopes being nil.
* semantic/bovine/c.el (semantic-c-describe-environment): Add
project macro symbol array.
(semantic-c-parse-lexical-token): Add recursion limit.
(semantic-ctxt-imported-packages, semanticdb-expand-nested-tag):
New overrides.
(semantic-expand-c-tag-namelist): Split a full type from a typedef
out to its own tag.
(semantic-expand-c-tag-namelist): Do not split out a typedef'd
inline type if it is an anonymous type.
(semantic-c-reconstitute-token): Use the optional initializers as
a clue that some function is probably a constructor. When
defining the type of these constructors, split the parent name,
and use only the class part, if applicable.
* semantic/bovine/c-by.el:
* semantic/wisent/python-wy.el: Regenerate.
author | Chong Yidong <cyd@stupidchicken.com> |
---|---|
date | Sat, 18 Sep 2010 22:49:54 -0400 |
parents | 1d1d5d9bd884 |
children | 376148b31b5e |
line wrap: on
line source
;;; calc-stat.el --- statistical functions for Calc ;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ;; Author: David Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> ;; This file is part of GNU Emacs. ;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: ;;; Code: ;; This file is autoloaded from calc-ext.el. (require 'calc-ext) (require 'calc-macs) ;;; Statistical operations on vectors. (defun calc-vector-count (arg) (interactive "P") (calc-slow-wrapper (calc-vector-op "coun" 'calcFunc-vcount arg))) (defun calc-vector-sum (arg) (interactive "P") (calc-slow-wrapper (if (calc-is-hyperbolic) (calc-vector-op "vprd" 'calcFunc-vprod arg) (calc-vector-op "vsum" 'calcFunc-vsum arg)))) (defun calc-vector-product (arg) (interactive "P") (calc-hyperbolic-func) (calc-vector-sum arg)) (defun calc-vector-max (arg) (interactive "P") (calc-slow-wrapper (if (calc-is-inverse) (calc-vector-op "vmin" 'calcFunc-vmin arg) (calc-vector-op "vmax" 'calcFunc-vmax arg)))) (defun calc-vector-min (arg) (interactive "P") (calc-invert-func) (calc-vector-max arg)) (defun calc-vector-mean (arg) (interactive "P") (calc-slow-wrapper (if (calc-is-hyperbolic) (if (calc-is-inverse) (calc-vector-op "harm" 'calcFunc-vhmean arg) (calc-vector-op "medn" 'calcFunc-vmedian arg)) (if (calc-is-inverse) (calc-vector-op "meae" 'calcFunc-vmeane arg) (calc-vector-op "mean" 'calcFunc-vmean arg))))) (defun calc-vector-mean-error (arg) (interactive "P") (calc-invert-func) (calc-vector-mean arg)) (defun calc-vector-median (arg) (interactive "P") (calc-hyperbolic-func) (calc-vector-mean arg)) (defun calc-vector-harmonic-mean (arg) (interactive "P") (calc-invert-func) (calc-hyperbolic-func) (calc-vector-mean arg)) (defun calc-vector-geometric-mean (arg) (interactive "P") (calc-slow-wrapper (if (calc-is-hyperbolic) (calc-binary-op "geom" 'calcFunc-agmean arg) (calc-vector-op "geom" 'calcFunc-vgmean arg)))) (defun calc-vector-sdev (arg) (interactive "P") (calc-slow-wrapper (if (calc-is-hyperbolic) (if (calc-is-inverse) (calc-vector-op "pvar" 'calcFunc-vpvar arg) (calc-vector-op "var" 'calcFunc-vvar arg)) (if (calc-is-inverse) (calc-vector-op "psdv" 'calcFunc-vpsdev arg) (calc-vector-op "sdev" 'calcFunc-vsdev arg))))) (defun calc-vector-pop-sdev (arg) (interactive "P") (calc-invert-func) (calc-vector-sdev arg)) (defun calc-vector-variance (arg) (interactive "P") (calc-hyperbolic-func) (calc-vector-sdev arg)) (defun calc-vector-pop-variance (arg) (interactive "P") (calc-invert-func) (calc-hyperbolic-func) (calc-vector-sdev arg)) (defun calc-vector-covariance (arg) (interactive "P") (calc-slow-wrapper (let ((n (if (eq arg 1) 1 2))) (if (calc-is-hyperbolic) (calc-enter-result n "corr" (cons 'calcFunc-vcorr (calc-top-list-n n))) (if (calc-is-inverse) (calc-enter-result n "pcov" (cons 'calcFunc-vpcov (calc-top-list-n n))) (calc-enter-result n "cov" (cons 'calcFunc-vcov (calc-top-list-n n)))))))) (defun calc-vector-pop-covariance (arg) (interactive "P") (calc-invert-func) (calc-vector-covariance arg)) (defun calc-vector-correlation (arg) (interactive "P") (calc-hyperbolic-func) (calc-vector-covariance arg)) (defun calc-vector-op (name func arg) (setq calc-aborted-prefix name arg (prefix-numeric-value arg)) (if (< arg 0) (error "Negative arguments not allowed")) (calc-enter-result arg name (cons func (calc-top-list-n arg)))) ;;; Useful statistical functions ;;; Sum, product, etc., of one or more values or vectors. ;;; Each argument must be either a number or a vector. Vectors ;;; are flattened, but variables inside are assumed to represent ;;; non-vectors. (defun calcFunc-vsum (&rest vecs) (math-reduce-many-vecs 'calcFunc-add 'calcFunc-vsum vecs 0)) (defun calcFunc-vprod (&rest vecs) (math-reduce-many-vecs 'calcFunc-mul 'calcFunc-vprod vecs 1)) (defun calcFunc-vmax (&rest vecs) (if (eq (car-safe (car vecs)) 'sdev) '(var inf var-inf) (if (eq (car-safe (car vecs)) 'intv) (nth 3 (math-fix-int-intv (car vecs))) (math-reduce-many-vecs 'calcFunc-max 'calcFunc-vmax vecs '(neg (var inf var-inf)))))) (defun calcFunc-vmin (&rest vecs) (if (eq (car-safe (car vecs)) 'sdev) '(neg (var inf var-inf)) (if (eq (car-safe (car vecs)) 'intv) (nth 2 (math-fix-int-intv (car vecs))) (math-reduce-many-vecs 'calcFunc-min 'calcFunc-vmin vecs '(var inf var-inf))))) (defun math-reduce-many-vecs (func whole-func vecs ident) (let ((const-part nil) (symb-part nil) val vec) (let ((calc-internal-prec (+ calc-internal-prec 2))) (while vecs (setq val (car vecs)) (and (eq (car-safe val) 'var) (eq (car-safe (calc-var-value (nth 2 val))) 'vec) (setq val (symbol-value (nth 2 val)))) (cond ((Math-vectorp val) (setq vec (append (and const-part (list const-part)) (math-flatten-vector val))) (setq const-part (if vec (calcFunc-reducer (math-calcFunc-to-var func) (cons 'vec vec)) ident))) ((or (Math-objectp val) (math-infinitep val)) (setq const-part (if const-part (funcall func const-part val) val))) (t (setq symb-part (nconc symb-part (list val))))) (setq vecs (cdr vecs)))) (if const-part (progn (setq const-part (math-normalize const-part)) (if symb-part (funcall func const-part (cons whole-func symb-part)) const-part)) (if symb-part (cons whole-func symb-part) ident)))) ;;; Return the number of data elements among the arguments. (defun calcFunc-vcount (&rest vecs) (let ((count 0)) (while vecs (setq count (if (Math-vectorp (car vecs)) (+ count (math-count-elements (car vecs))) (if (Math-objectp (car vecs)) (1+ count) (if (and (eq (car-safe (car vecs)) 'var) (eq (car-safe (calc-var-value (nth 2 (car vecs)))) 'vec)) (+ count (math-count-elements (symbol-value (nth 2 (car vecs))))) (math-reject-arg (car vecs) 'numvecp)))) vecs (cdr vecs))) count)) (defun math-count-elements (vec) (let ((count 0)) (while (setq vec (cdr vec)) (setq count (if (Math-vectorp (car vec)) (+ count (math-count-elements (car vec))) (1+ count)))) count)) (defun math-flatten-many-vecs (vecs) (let ((p vecs) (vec (list 'vec))) (while p (setq vec (nconc vec (if (Math-vectorp (car p)) (math-flatten-vector (car p)) (if (Math-objectp (car p)) (list (car p)) (if (and (eq (car-safe (car p)) 'var) (eq (car-safe (calc-var-value (nth 2 (car p)))) 'vec)) (math-flatten-vector (symbol-value (nth 2 (car p)))) (math-reject-arg (car p) 'numvecp))))) p (cdr p))) vec)) (defun calcFunc-vflat (&rest vecs) (math-flatten-many-vecs vecs)) (defun math-split-sdev-vec (vec zero-ok) (let ((means (list 'vec)) (wts (list 'vec)) (exact nil) (p vec)) (while (and (setq p (cdr p)) (not (and (consp (car p)) (eq (car (car p)) 'sdev))))) (if (null p) (list vec nil) (while (setq vec (cdr vec)) (if (and (consp (setq p (car vec))) (eq (car p) 'sdev)) (or exact (setq means (cons (nth 1 p) means) wts (cons (nth 2 p) wts))) (if zero-ok (setq means (cons (nth 1 p) means) wts (cons 0 wts)) (or exact (setq means (list 'vec) wts nil exact t)) (setq means (cons p means))))) (list (nreverse means) (and wts (nreverse wts)))))) ;;; Return the arithmetic mean of the argument numbers or vectors. ;;; (If numbers are error forms, computes the weighted mean.) (defun calcFunc-vmean (&rest vecs) (let* ((split (math-split-sdev-vec (math-flatten-many-vecs vecs) nil)) (means (car split)) (wts (nth 1 split)) (len (1- (length means)))) (if (= len 0) (math-reject-arg nil "*Must be at least 1 argument") (if (and (= len 1) (eq (car-safe (nth 1 means)) 'intv)) (let ((x (math-fix-int-intv (nth 1 means)))) (calcFunc-vmean (nth 2 x) (nth 3 x))) (math-with-extra-prec 2 (if (and wts (> len 1)) (let* ((sqrwts (calcFunc-map '(var mul var-mul) wts wts)) (suminvsqrwts (calcFunc-reduce '(var add var-add) (calcFunc-map '(var div var-div) 1 sqrwts)))) (math-div (calcFunc-reduce '(var add var-add) (calcFunc-map '(var div var-div) means sqrwts)) suminvsqrwts)) (math-div (calcFunc-reduce '(var add var-add) means) len))))))) (defun math-fix-int-intv (x) (if (math-floatp x) x (list 'intv 3 (if (memq (nth 1 x) '(2 3)) (nth 2 x) (math-add (nth 2 x) 1)) (if (memq (nth 1 x) '(1 3)) (nth 3 x) (math-sub (nth 3 x) 1))))) ;;; Compute the mean with an error estimate. (defun calcFunc-vmeane (&rest vecs) (let* ((split (math-split-sdev-vec (math-flatten-many-vecs vecs) nil)) (means (car split)) (wts (nth 1 split)) (len (1- (length means)))) (if (= len 0) (math-reject-arg nil "*Must be at least 1 argument") (math-with-extra-prec 2 (if wts (let* ((sqrwts (calcFunc-map '(var mul var-mul) wts wts)) (suminvsqrwts (calcFunc-reduce '(var add var-add) (calcFunc-map '(var div var-div) 1 sqrwts)))) (math-make-sdev (math-div (calcFunc-reduce '(var add var-add) (calcFunc-map '(var div var-div) means sqrwts)) suminvsqrwts) (list 'calcFunc-sqrt (math-div 1 suminvsqrwts)))) (let ((mean (math-div (calcFunc-reduce '(var add var-add) means) len))) (math-make-sdev mean (list 'calcFunc-sqrt (math-div (calcFunc-reducer '(var add var-add) (calcFunc-map '(var pow var-pow) (calcFunc-map '(var abs var-abs) (calcFunc-map '(var add var-add) means (math-neg mean))) 2)) (math-mul len (1- len))))))))))) ;;; Compute the median of a list of values. (defun calcFunc-vmedian (&rest vecs) (let* ((flat (copy-sequence (cdr (math-flatten-many-vecs vecs)))) (p flat) (len (length flat)) (hlen (/ len 2))) (if (= len 0) (math-reject-arg nil "*Must be at least 1 argument") (if (and (= len 1) (memq (car-safe (car flat)) '(sdev intv))) (calcFunc-vmean (car flat)) (while p (if (eq (car-safe (car p)) 'sdev) (setcar p (nth 1 (car p)))) (or (Math-anglep (car p)) (math-reject-arg (car p) 'anglep)) (setq p (cdr p))) (setq flat (sort flat 'math-lessp)) (if (= (% len 2) 0) (math-div (math-add (nth (1- hlen) flat) (nth hlen flat)) 2) (nth hlen flat)))))) (defun calcFunc-vgmean (&rest vecs) (let* ((flat (math-flatten-many-vecs vecs)) (len (1- (length flat)))) (if (= len 0) (math-reject-arg nil "*Must be at least 1 argument") (math-with-extra-prec 2 (let ((x (calcFunc-reduce '(var mul math-mul) flat))) (if (= len 2) (math-sqrt x) (math-pow x (list 'frac 1 len)))))))) (defun calcFunc-agmean (a b) (cond ((Math-equal a b) a) ((math-zerop a) a) ((math-zerop b) b) (calc-symbolic-mode (math-inexact-result)) ((not (Math-realp a)) (math-reject-arg a 'realp)) ((not (Math-realp b)) (math-reject-arg b 'realp)) (t (math-with-extra-prec 2 (setq a (math-float (math-abs a)) b (math-float (math-abs b))) (let (mean) (while (not (math-nearly-equal-float a b)) (setq mean (math-mul-float (math-add-float a b) '(float 5 -1)) b (math-sqrt-float (math-mul-float a b)) a mean)) a))))) (defun calcFunc-vhmean (&rest vecs) (let* ((flat (math-flatten-many-vecs vecs)) (len (1- (length flat)))) (if (= len 0) (math-reject-arg nil "*Must be at least 1 argument") (math-with-extra-prec 2 (math-div len (calcFunc-reduce '(var add math-add) (calcFunc-map '(var inv var-inv) flat))))))) ;;; Compute the sample variance or standard deviation of numbers or vectors. ;;; (If the numbers are error forms, only the mean part of them is used.) (defun calcFunc-vvar (&rest vecs) (if (and (= (length vecs) 1) (memq (car-safe (car vecs)) '(sdev intv))) (if (eq (car-safe (car vecs)) 'intv) (math-intv-variance (car vecs) nil) (math-sqr (nth 2 (car vecs)))) (math-covariance vecs nil nil 0))) (defun calcFunc-vsdev (&rest vecs) (if (and (= (length vecs) 1) (memq (car-safe (car vecs)) '(sdev intv))) (if (eq (car-safe (car vecs)) 'intv) (if (math-floatp (car vecs)) (math-div (math-sub (nth 3 (car vecs)) (nth 2 (car vecs))) (math-sqrt-12)) (math-sqrt (calcFunc-vvar (car vecs)))) (nth 2 (car vecs))) (math-sqrt (math-covariance vecs nil nil 0)))) ;;; Compute the population variance or std deviation of numbers or vectors. (defun calcFunc-vpvar (&rest vecs) (if (and (= (length vecs) 1) (memq (car-safe (car vecs)) '(sdev intv))) (if (eq (car-safe (car vecs)) 'intv) (math-intv-variance (car vecs) t) (math-sqr (nth 2 (car vecs)))) (math-covariance vecs nil t 0))) (defun calcFunc-vpsdev (&rest vecs) (if (and (= (length vecs) 1) (memq (car-safe (car vecs)) '(sdev intv))) (if (eq (car-safe (car vecs)) 'intv) (if (math-floatp (car vecs)) (math-div (math-sub (nth 3 (car vecs)) (nth 2 (car vecs))) (math-sqrt-12)) (math-sqrt (calcFunc-vpvar (car vecs)))) (nth 2 (car vecs))) (math-sqrt (math-covariance vecs nil t 0)))) (defun math-intv-variance (x pop) (or (math-constp x) (math-reject-arg x 'constp)) (if (math-floatp x) (math-div (math-sqr (math-sub (nth 3 x) (nth 2 x))) 12) (let* ((x (math-fix-int-intv x)) (len (math-sub (nth 3 x) (nth 2 x))) (hlen (math-quotient len 2))) (math-div (if (math-evenp len) (calcFunc-sum '(^ (var X var-X) 2) '(var X var-X) (math-neg hlen) hlen) (calcFunc-sum '(^ (- (var X var-X) (/ 1 2)) 2) '(var X var-X) (math-neg hlen) (math-add hlen 1))) (if pop (math-add len 1) len))))) ;;; Compute the covariance and linear correlation coefficient. (defun calcFunc-vcov (vec1 &optional vec2) (math-covariance (list vec1) (list vec2) nil 1)) (defun calcFunc-vpcov (vec1 &optional vec2) (math-covariance (list vec1) (list vec2) t 1)) (defun calcFunc-vcorr (vec1 &optional vec2) (math-covariance (list vec1) (list vec2) nil 2)) (defun math-covariance (vec1 vec2 pop mode) (or (car vec2) (= mode 0) (progn (if (and (eq (car-safe (car vec1)) 'var) (eq (car-safe (calc-var-value (nth 2 (car vec1)))) 'vec)) (setq vec1 (symbol-value (nth 2 (car vec1)))) (setq vec1 (car vec1))) (or (math-matrixp vec1) (math-dimension-error)) (or (= (length (nth 1 vec1)) 3) (math-dimension-error)) (setq vec2 (list (math-mat-col vec1 2)) vec1 (list (math-mat-col vec1 1))))) (math-with-extra-prec 2 (let* ((split1 (math-split-sdev-vec (math-flatten-many-vecs vec1) nil)) (means1 (car split1)) (wts1 (nth 1 split1)) split2 means2 (wts2 nil) (sqrwts nil) suminvsqrwts (len (1- (length means1)))) (if (< len (if pop 1 2)) (math-reject-arg nil (if pop "*Must be at least 1 argument" "*Must be at least 2 arguments"))) (if (or wts1 wts2) (setq sqrwts (math-add (if wts1 (calcFunc-map '(var mul var-mul) wts1 wts1) 0) (if wts2 (calcFunc-map '(var mul var-mul) wts2 wts2) 0)) suminvsqrwts (calcFunc-reduce '(var add var-add) (calcFunc-map '(var div var-div) 1 sqrwts)))) (or (= mode 0) (progn (setq split2 (math-split-sdev-vec (math-flatten-many-vecs vec2) nil) means2 (car split2) wts2 (nth 2 split1)) (or (= len (1- (length means2))) (math-dimension-error)))) (let* ((diff1 (calcFunc-map '(var add var-add) means1 (if sqrwts (math-div (calcFunc-reduce '(var add var-add) (calcFunc-map '(var div var-div) means1 sqrwts)) (math-neg suminvsqrwts)) (math-div (calcFunc-reducer '(var add var-add) means1) (- len))))) (diff2 (if (= mode 0) diff1 (calcFunc-map '(var add var-add) means2 (if sqrwts (math-div (calcFunc-reduce '(var add var-add) (calcFunc-map '(var div var-div) means2 sqrwts)) (math-neg suminvsqrwts)) (math-div (calcFunc-reducer '(var add var-add) means2) (- len)))))) (covar (calcFunc-map '(var mul var-mul) diff1 diff2))) (if sqrwts (setq covar (calcFunc-map '(var div var-div) covar sqrwts))) (math-div (calcFunc-reducer '(var add var-add) covar) (if (= mode 2) (let ((var1 (calcFunc-map '(var mul var-mul) diff1 diff1)) (var2 (calcFunc-map '(var mul var-mul) diff2 diff2))) (if sqrwts (setq var1 (calcFunc-map '(var div var-div) var1 sqrwts) var2 (calcFunc-map '(var div var-div) var2 sqrwts))) (math-sqrt (math-mul (calcFunc-reducer '(var add var-add) var1) (calcFunc-reducer '(var add var-add) var2)))) (if sqrwts (if pop suminvsqrwts (math-div (math-mul suminvsqrwts (1- len)) len)) (if pop len (1- len))))))))) (provide 'calc-stat) ;; arch-tag: 423858e9-8513-489c-9f35-710cd9d9c307 ;;; calc-stat.el ends here