(FILECREATED "16-Jun-86 21:51:32" {QV}<PEDERSEN>LISP>MEDIANSMOOTHER.;2 9092
changes to: (FNS MEDIANSMOOTH ENDPTS HANN MEDOF3 S3 S3R S3RSSH SPLIT)
(VARS MEDIANSMOOTHERCOMS)
(MACROS MEDOF3)
previous date: "16-Jun-86 21:38:02" {QV}<PEDERSEN>LISP>MEDIANSMOOTHER.;1)
(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT MEDIANSMOOTHERCOMS)
(RPAQQ MEDIANSMOOTHERCOMS ((FNS S3RSSH SPLIT S3R ENDPTS S3 HANN MEDIANSMOOTH)
(MACROS MEDOF3)))
(DEFINEQ
(S3RSSH
[LAMBDA (VECTOR) (* jop: "16-Jun-86 20:41")
(* * SMOOTH CMLARRAY VECTOR BY 3RSSH.)
(S3R VECTOR)
(if (SPLIT VECTOR)
then (S3R VECTOR)
(if (SPLIT VECTOR)
then (S3R VECTOR)))
(HANN VECTOR])
(SPLIT
[LAMBDA (VECTOR) (* jop: "16-Jun-86 20:51")
(* * FIND 2-FLATS IN VECTOR AND APPLY SPLITTING ALGORITHM.)
(* W IS A WINDOW 6 WIDE WHICH SLIDES ALONG Y.)
(LET ((VECTORBASE (ARRAYBASE VECTOR)))
(bind W0 (W1 ←(\GETBASEFLOATP VECTORBASE 4))
(W2 ←(\GETBASEFLOATP VECTORBASE 0))
(W3 ←(\GETBASEFLOATP VECTORBASE 2))
(W4 ←(\GETBASEFLOATP VECTORBASE 4))
(W5 ←(\GETBASEFLOATP VECTORBASE 6))
(N ←(SUB1 (ARRAY-TOTAL-SIZE VECTOR)))
(NM2 ←(IDIFFERENCE (ARRAY-TOTAL-SIZE VECTOR)
3))
CHANGE Y1 ANS declare (TYPE FLOATP W0 W1 W2 W3 W4 W5 Y1 ANS) for I from 0
to (IDIFFERENCE (ARRAY-TOTAL-SIZE VECTOR)
2)
do
(* * IF VECTOR (0) =VECTER (1) .NE. VECTOR (2), TREAT FIRST 2 LIKE A 2-FLAT WITH END PT RULE)
[if (UFEQP W2 W3)
then (if (OR (AND (UFLESSP W2 W1)
(UFLESSP W3 W4))
(AND (UFGREATERP W2 W1)
(UFGREATERP W3 W4)))
then
(* * W (2) AND W (3) FORM A 2-FLAT)
[if (IGEQ I 2)
then
(* * APPLY RIGHT END PT RULE AT I)
(SETQ Y1 (FDIFFERENCE (FTIMES 3.0 W1)
(FTIMES 2.0 W0)))
(SETQ ANS (MEDOF3 Y1 W2 W1))
(\PUTBASEFLOATP VECTORBASE (MUL2 I)
ANS)
(SETQ CHANGE (NOT (UFEQP ANS W2]
(if (ILESSP I NM2)
then
(* * APPLY LEFT END PT RULE AT I+1)
(SETQ Y1 (FDIFFERENCE (FTIMES 3.0 W4)
(FTIMES 2.0 W5)))
(SETQ ANS (MEDOF3 Y1 W3 W4))
(\PUTBASEFLOATP VECTORBASE (MUL2 (ADD1 I))
ANS)
(SETQ CHANGE (NOT (UFEQP ANS W3]
(* * SLIDE WINDOW)
(SETQ W0 W1)
(SETQ W1 W2)
(SETQ W2 W3)
(SETQ W3 W4)
(SETQ W4 W5)
(if (ILESSP I (IDIFFERENCE N 3))
then [SETQ W5 (\GETBASEFLOATP VECTORBASE (MUL2 (IPLUS I 4]
else
(* * APPLY RULE TO LAST 2 POINTS IF NEEDED.)
(SETQ W5 W2))
finally (RETURN CHANGE])
(S3R
[LAMBDA (Y) (* jop: "16-Jun-86 20:26")
(* * COMPUTE REPEATED RUNNING MEDIANS OF 3.0)
(repeatwhile (S3 Y))
(ENDPTS Y])
(ENDPTS
[LAMBDA (VECTOR) (* jop: "16-Jun-86 21:48")
(* * ESTIMATE SMOOTHED VALUES FOR BOTH END POINTS OF THE SEQUENCE IN VECTOR USING THE END POINT EXTRAPOLATION RULE.
ALL THE OTHER VALUES IN VECTOR HAVE ALREADY BEEN SMOOTHED.)
(LET ((VECTORBASE (ARRAYBASE VECTOR))
(N (ARRAY-TOTAL-SIZE VECTOR))
Y0 Y1 Y2)
(DECLARE (TYPE FLOATP Y0 Y1 Y2))
(* * LEFT END)
[SETQ Y0 (FDIFFERENCE (FTIMES 3.0 (\GETBASEFLOATP VECTORBASE 1))
(FTIMES 2.0 (\GETBASEFLOATP VECTORBASE 4]
(SETQ Y1 (\GETBASEFLOATP VECTORBASE 0))
(SETQ Y2 (\GETBASEFLOATP VECTORBASE 2))
(\PUTBASEFLOATP VECTORBASE 0 (MEDOF3 Y0 Y1 Y2))
(* * RIGHT END)
[SETQ Y0 (FDIFFERENCE [FTIMES 3.0 (\GETBASEFLOATP VECTORBASE
(MUL2 (IDIFFERENCE N 2]
(FTIMES 2.0 (\GETBASEFLOATP VECTORBASE
(MUL2 (IDIFFERENCE N 3]
[SETQ Y1 (\GETBASEFLOATP VECTORBASE (MUL2 (SUB1 N]
[SETQ Y2 (\GETBASEFLOATP VECTORBASE (MUL2 (IDIFFERENCE N 2]
(\PUTBASEFLOATP VECTORBASE (MUL2 (SUB1 N))
(MEDOF3 Y0 Y1 Y2])
(S3
[LAMBDA (VECTOR) (* jop: "16-Jun-86 20:37")
(* * COMPUTE RUNNING MEDIAN OF 3 ON CMLARRAY Y. -
RETURNS T IF ANY CHANGE IS MADE.)
(LET ((VECTORBASE (ARRAYBASE VECTOR)))
(bind (CHANGED ← NIL)
(Y2 ←(\GETBASEFLOATP VECTORBASE 0))
(Y3 ←(\GETBASEFLOATP VECTORBASE 2))
ANS Y1 declare (TYPE FLOATP ANS Y1 Y2 Y3) for I from 1
to (IDIFFERENCE (ARRAY-TOTAL-SIZE VECTOR)
2)
do (SETQ Y1 Y2)
(SETQ Y2 Y3)
[SETQ Y3 (\GETBASEFLOATP VECTORBASE (MUL2 (ADD1 I]
(SETQ ANS (MEDOF3 Y1 Y2 Y3))
(if (NOT (UFEQP ANS Y2))
then (SETQ CHANGED T)
(\PUTBASEFLOATP VECTORBASE (MUL2 I)
ANS))
finally (RETURN CHANGED])
(HANN
[LAMBDA (VECTOR) (* jop: "16-Jun-86 20:54")
(* * 3-POINT SMOOTH BY MOVING AVERAGES WEIGHTED 1/4, 1/2, 1/4. -
THIS IS CALLED HANNING.)
(LET ((VECTORBASE (ARRAYBASE VECTOR)))
(bind Y1 (Y2 ←(\GETBASEFLOATP VECTORBASE 0))
(Y3 ←(\GETBASEFLOATP VECTORBASE 2)) declare (TYPE FLOATP Y1 Y2 Y3) for I
from 1 to (IDIFFERENCE (ARRAY-TOTAL-SIZE VECTOR)
2)
do (SETQ Y1 Y2)
(SETQ Y2 Y3)
[SETQ Y3 (\GETBASEFLOATP VECTORBASE (MUL2 (ADD1 I]
(\PUTBASEFLOATP VECTORBASE (MUL2 I)
(FTIMES (FPLUS Y1 Y2 Y2 Y3)
.25])
(MEDIANSMOOTH
[LAMBDA (VECTOR SMOOTHEDVECTOR SMOOTHER TWICEFLG) (* jop: "16-Jun-86 21:45")
(* * Nonlinear smoothers. Reference: Hoaglin and Velleman, "the ABCs of EDA")
(* * VECTOR is a rank 1 FLOATP CMLArray to be smoothed.)
(* * SMOOTHER specifies the smoother to be used: currently one of S3, S3R, S4, S5, HANN, and two compound smoothers
S3RSSH and Default is S3RSSH)
(* * TWICEFLG if present indicates that the smooth should be "reroughed" in the sense that the rough is also
smoothed and the result added back into the original smooth.)
(* * Returns a new CMLArray containing the smoothed values of VECTOR)
(SETQ SMOOTHER (OR SMOOTHER (QUOTE S3RSSH)))
(LET ((N (ARRAY-TOTAL-SIZE VECTOR)))
(* * Error checking on the incoming arrays.)
(if (NOT (EQ (ARRAY-RANK VECTOR)
1))
then (ERROR "Array not 1-Dimensional:" VECTOR))
(if (NOT (EQ (ARRAY-ELEMENT-TYPE VECTOR)
(QUOTE SINGLE-FLOAT)))
then (ERROR "Array not FLONUM:" VECTOR))
(if (ILEQ N 6)
then (ERROR "Total size must be > 6" VECTOR))
(if (NULL SMOOTHEDVECTOR)
then (SETQ SMOOTHEDVECTOR (MAKE-ARRAY N (QUOTE :ELEMENT-TYPE)
(QUOTE FLOAT)
(QUOTE :INITIAL-CONTENTS)
VECTOR))
elseif [NOT (AND (EQ (ARRAY-RANK SMOOTHEDVECTOR)
1)
(EQ (ARRAY-ELEMENT-TYPE SMOOTHEDVECTOR)
(QUOTE SINGLE-FLOAT]
then (ERROR "Invalid smoothedvector" SMOOTHEDVECTOR))
(EARRAY-BLT VECTOR NIL SMOOTHEDVECTOR)
(* * Now compute the appropriate smooth.)
(APPLY* SMOOTHER SMOOTHEDVECTOR)
(* * Rerough if twicing is requested.)
(if TWICEFLG
then (LET [(ROUGHVECTOR (MAKE-ARRAY N (QUOTE :ELEMENT-TYPE)
(QUOTE FLOAT]
(EARRAY-DIFFERENCE VECTOR SMOOTHEDVECTOR ROUGHVECTOR)
(* * Having computed the ROUGHVECTOR from the smooth.)
(APPLY* SMOOTHER ROUGHVECTOR)
(EARRAY-PLUS SMOOTHEDVECTOR ROUGHVECTOR SMOOTHEDVECTOR)))
(* * Finally return the smooth)
SMOOTHEDVECTOR])
)
(DECLARE: EVAL@COMPILE
(PUTPROPS MEDOF3 DMACRO ((X1 X2 X3)
(if (UFGREATERP X2 X1)
then
(if (UFGREATERP X3 X2)
then X2 elseif (UFGREATERP X3 X1)
then X3 else X1)
elseif
(UFLESSP X3 X2)
then X2 elseif (UFLESSP X3 X1)
then X3 else X1)))
)
(PUTPROPS MEDIANSMOOTHER COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (510 8708 (S3RSSH 520 . 851) (SPLIT 853 . 3228) (S3R 3230 . 3446) (ENDPTS 3448 . 4746) (
S3 4748 . 5596) (HANN 5598 . 6308) (MEDIANSMOOTH 6310 . 8706)))))
STOP