~ubuntu-branches/ubuntu/vivid/r-cran-statmod/vivid

« back to all changes in this revision

Viewing changes to R/mscale.R

  • Committer: Package Import Robot
  • Author(s): Sébastien Villemot
  • Date: 2013-10-02 15:40:39 UTC
  • Revision ID: package-import@ubuntu.com-20131002154039-lee9ml5cj2tkgjga
Tags: upstream-1.4.18
Import upstream version 1.4.18

Show diffs side-by-side

added added

removed removed

Lines of Context:
 
1
mscale <- function(u, na.rm=FALSE)
 
2
#       Scale M-estimator with 50% breakdown
 
3
#       Yohai (1987) Annals, Stromberg (1993) JASA.
 
4
#
 
5
#       GKS  2 June 1999
 
6
#       Revised 17 April 2010
 
7
{
 
8
        isna <- is.na(u)
 
9
        if(any(isna)) {
 
10
                if(na.rm) {
 
11
                        if(any(!isna))
 
12
                                u <- u[!isna]
 
13
                        else
 
14
                                return(NA)
 
15
                } else {
 
16
                        return(NA)
 
17
                }       
 
18
        }
 
19
        if(mean(u==0) >= 0.5) return(0)
 
20
        U <- abs(u)
 
21
        s <- median(U)/0.6744898
 
22
        iter <- 0
 
23
        repeat {
 
24
                iter <- iter+1
 
25
                z <- u/0.212/s
 
26
                d1 <- mean(.rho.hampel(z))-3.75
 
27
                d2 <- mean(z*.psi.hampel(z))
 
28
                s <- s*(1+d1/d2)
 
29
                if(iter > 50) {
 
30
                        warning("Max iterations exceeded")
 
31
                        break
 
32
                }
 
33
                if(abs(d1/d2) < 1e-13) break
 
34
        }
 
35
        s       
 
36
}
 
37
 
 
38
.rho.hampel <- function(u, a = 1.5, b = 3.5, c = 8)
 
39
{
 
40
#       Integral of Hampel's redescending psi function (Hampel, Ronchetti,
 
41
#       Rousseeuw and Stahel, 1986, Robust Statistics, Wiley, page 150).
 
42
#       Default values are as in Stromberg (1993) JASA.
 
43
#
 
44
#       GKS  31 May 99
 
45
#
 
46
        U <- abs(u)
 
47
        A <- (U <= a)   #increasing
 
48
        B <- (U > a) & (U <= b) #flat
 
49
        C <- (U > b) & (U <= c) #descending
 
50
        D <- (U > c)    # zero
 
51
        rho <- U
 
52
        rho[A] <- (U[A] * U[A])/2
 
53
        rho[B] <- a * (U[B] - a/2)
 
54
        rho[C] <- a * (b - a/2) + a * (U[C] - b) * (1 - (U[C] - b)/(c - b)/2)
 
55
        rho[D] <- (a * (b - a + c))/2
 
56
        rho
 
57
}
 
58
 
 
59
.psi.hampel <- function(u, a = 1.5, b = 3.5, c = 8)
 
60
{
 
61
#       Hampel's redescending psi function (Hampel, Ronchetti,
 
62
#       Rousseeuw and Stahel, 1986, Robust Statistics, Wiley, page 150).
 
63
#       Default values are as in Stromberg (1993) JASA.
 
64
#
 
65
#       GKS  2 June 99
 
66
#
 
67
        U <- abs(u)
 
68
        B <- (U > a) & (U <= b) #flat
 
69
        C <- (U > b) & (U <= c) #descending
 
70
        D <- (U > c)    # zero
 
71
        psi <- u
 
72
        psi[B] <- sign(u[B]) * a
 
73
        psi[C] <- sign(u[C]) * a * (c - U[C])/(c - b)
 
74
        psi[D] <- 0
 
75
        psi
 
76
}
 
 
b'\\ No newline at end of file'