home *** CD-ROM | disk | FTP | other *** search
/ Big Green CD 8 / BGCD_8_Dev.iso / NEXTSTEP / UNIX / Educational / R-0.49-MI / R-0.49-I / library / local < prev    next >
Encoding:
Text File  |  1997-09-14  |  2.7 KB  |  88 lines
  1. isoton <-
  2. function(x, wt = -1)
  3. {
  4. #++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  5. # Performs a monotone smoothing on vector x, optionally using weights
  6. # in parallel vector wt
  7. #----------------------------------------------------------------------
  8.         
  9.         if(!is.numeric(x) || length(x) < 2)
  10.                 stop("x must be numeric  of length > 1")
  11.         if(missing(wt)) {
  12.                 z <- .Fortran("monosm",
  13.                         ans = as.double(x),
  14.                         as.double(1),
  15.                         as.integer(length(x)),
  16.                         as.logical(FALSE),
  17.                         integer(length(x)))
  18.         }
  19.         else {
  20.                 if(!is.numeric(wt) || length(wt) != length(x))
  21.                         stop("wt must be numeric length same as x")
  22.                 z <- .Fortran("monosm",
  23.                         ans = as.double(x),
  24.                         as.double(wt),
  25.                         as.integer(length(x)),
  26.                         as.logical(TRUE),
  27.                         integer(length(x)))
  28.         }
  29.         return(z$ans)
  30. }
  31.  
  32.  
  33. stepfun <-
  34. function(datax, datay, type = "left")
  35. {
  36. # augment a set of points so that it plots as a left-continuous function
  37. # allow both (x,y) and (structure with $x $y)  input
  38.         if(missing(datay)) x <- datax$x else x <- datax
  39.         if(missing(datay))
  40.                 y <- datax$y
  41.         else y <- datay
  42.         n <- length(x)
  43.         type <- charmatch(type, c("left", "right"))
  44.         if(is.na(type))
  45.                 stop("The type must be 'left' or 'right' continuous")
  46.         if(any(diff(x) < 0))
  47.                 stop("The x vector must be sorted")
  48.         if(type == 2) {
  49.                 x <- rev(x)
  50.                 y <- rev(y)
  51.         }
  52.         if(n > 2) {
  53. # remove redundant points
  54.                 dupy <- c(T, diff(y[ - n]) != 0, T)
  55.                 dupx <- c(T, diff(x[ - n]) != 0, T)
  56.                 x <- x[dupx & dupy]
  57.                 y <- y[dupx & dupy]
  58.                 n <- length(x)
  59.         }
  60. #create the step function
  61.         xrep <- rep(x[2:n], rep(2, n - 1))
  62.         yrep <- rep(y[1:(n - 1)], rep(2, n - 1))
  63.         if(type == 1)
  64.                 list(x = c(x[1], xrep), y = c(yrep, y[n]))
  65.         else list(x = c(rev(xrep), x[1]), y = c(y[n], rev(yrep)))
  66. }
  67.  
  68.  
  69. dlwb <- 
  70. function(x, y, rw = c(rep(1, length(y))), f = 1/3)
  71. {
  72.         nk <- order(x)
  73.         y <- y[nk]
  74.         x <- x[nk]
  75.         n <- length(y)
  76.         fit <- .Fortran("dlwb",
  77.                 x = as.double(x),
  78.                 y = as.double(y),
  79.                 as.integer(n),
  80.                 as.double(f),
  81.                  ys = double(n),
  82.                 rw = as.double(rw),
  83.                 work = double(n))
  84.         list(x = fit$x, ys = fit$ys)
  85. }
  86.  
  87.  
  88.