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 / acepack next >
Encoding:
Text File  |  1997-09-14  |  5.7 KB  |  306 lines
  1.  
  2. "ace"<- function(x, y, wt = rep(1, nrow(x)), cat=NULL, mon=NULL, lin=NULL, circ=NULL, delrsq = 0.01)
  3. {
  4.     x <- as.matrix(x)
  5.     if(delrsq <= 0) {
  6.         cat("delrsq must be positive")
  7.         return()
  8.     }
  9.     iy <- ncol(x) + 1
  10.     l <- matrix(1, ncol = iy)
  11.     if(!is.null(circ)) {
  12.         for(i in 1:length(circ)) {
  13.             if(circ[i] < 0 || circ[i] > nrow(x)) {
  14.                 cat("bad circ= specification")
  15.                 return()
  16.             }
  17.             if(circ[i] == 0) {
  18.                 cat(
  19.                     "response spec can only be lin or ordered (default)"
  20.                     )
  21.                 return()
  22.             }
  23.             else {
  24.                 nncol <- circ[i]
  25.                 if(l[nncol]!=2 & l[nncol]!=1) {
  26.                     cat(
  27.                         "conflicting transformation specifications"
  28.                         )
  29.                     return()
  30.                 }
  31.                 l[nncol] <- 2
  32.             }
  33.         }
  34.     }
  35.     if(!is.null(mon)) {
  36.         for(i in 1:length(mon)) {
  37.             if(mon[i] < 0 || mon[i] > nrow(x)) {
  38.                 cat("bad mon= specification")
  39.                 return()
  40.             }
  41.             if(mon[i] == 0) {
  42.                 cat(
  43.                     "response spec can only be lin or ordered (default)"
  44.                     )
  45.                 return()
  46.             }
  47.             else {
  48.                 nncol <- mon[i]
  49.                 if(l[nncol]!=3 && l[nncol]!=1) {
  50.                     cat(
  51.                         "conflicting transformation specifications"
  52.                         )
  53.                     return()
  54.                 }
  55.                 l[nncol] <- 3
  56.             }
  57.         }
  58.     }
  59.     if(!is.null(lin)) {
  60.         for(i in 1:length(lin)) {
  61.             if(lin[i] < 0 || lin[i] > nrow(x)) {
  62.                 cat("bad lin= specification")
  63.                 return()
  64.             }
  65.             if(lin[i] == 0) {
  66.                 nncol <- iy
  67.             }
  68.             else {
  69.                 nncol <- lin[i]
  70.             }
  71.             if(l[nncol]!=4 && l[nncol]!=1) {
  72.                 cat("conflicting transformation specifications"
  73.                     )
  74.                 return()
  75.             }
  76.             l[nncol] <- 4
  77.         }
  78.     }
  79.     if(!is.null(cat)) {
  80.         for(i in 1:length(cat)) {
  81.             if(cat[i] < 0 || cat[i] > nrow(x)) {
  82.                 cat("bad cat= specification")
  83.                 return()
  84.             }
  85.             if(cat[i] == 0) {
  86.                 cat(
  87.                     "response spec can only be lin or ordered (default)"
  88.                     )
  89.                 return()
  90.             }
  91.             else {
  92.                 nncol <- cat[i]
  93.                 if(l[nncol]!=4 && l[nncol]!=1) {
  94.                     cat(
  95.                         "conflicting transformation specifications"
  96.                         )
  97.                     return()
  98.                 }
  99.                 l[nncol] <- 4
  100.             }
  101.         }
  102.     }
  103.     tx <- x
  104.     ty <- y
  105.     m <- matrix(0, nrow = nrow(x), ncol =  iy+1)
  106.     z <- matrix(0, nrow = nrow(x), ncol = 12)
  107.     z <- as.matrix(z)
  108.     ns<-1
  109.     mode(ns)<-"integer"
  110.     mode(x) <- "double"
  111.     mode(y) <- "double"
  112.     mode(tx) <- "double"
  113.     mode(ty) <- "double"
  114.     mode(wt) <- "double"
  115.     mode(m) <- "integer"
  116.     mode(l) <- "integer"
  117.     mode(delrsq) <- "double"
  118.     mode(z) <- "double"
  119.     junk <- .Fortran("mace",
  120.              p=ncol(x),
  121.              n=nrow(x),
  122.              x=t(x),
  123.              y=y,
  124.              w=wt,
  125.              l=l,
  126.              delrsq=delrsq,
  127.              ns=ns,
  128.              tx = tx,
  129.              ty = ty,
  130.              rsq = double(1),
  131.              ierr = integer(1),
  132.              m=m,
  133.              z=z
  134.              )
  135. #    return(list(x=x, y=y, tx = junk$tx, ty = junk$ty, rsq = junk$rsq, l, m))
  136. return(junk)
  137. }
  138.  
  139.  
  140. avas.formula <-function(formula, data=sys.frame(sys.parent()) ,subset=NULL,weights=NULL,cat=NULL,mon=NULL,lin=NULL,circ=NULL,delrsq=0.01,yspan=0){
  141.   mf<-match.call()
  142.   mf$cat<-mf$mon<-lin<-mf$circ<-mf$delrsq<-mf$span<-NULL
  143.   mf[[1]]<-as.name("model.frame")
  144.   mf$use.data<-TRUE
  145.   mf<-eval(mf,sys.frame(sys.parent()))
  146.   y<-model.response(mf)
  147.   mm<-model.matrix(formula,mf)[,-1,drop=F]
  148.   w<-if (is.null(weights)) rep(1,nrow(mm)) else model.extract(mf,"weights")
  149.   avas(mm,y,w,cat,mon,lin,circ,delrsq,yspan)
  150. }
  151.  
  152. "avas"<- function(x, y, wt = rep(1, nrow(x)), cat=NULL, mon=NULL, lin=NULL, circ=NULL, delrsq = 0.01, yspan
  153.      = 0)
  154. {
  155.     x <- as.matrix(x)
  156.     if(delrsq <= 0) {
  157.         cat("delrsq must be positive")
  158.         return()
  159.     }
  160.     iy <- ncol(x) + 1
  161.     l <- matrix(1, ncol = iy)
  162.     if(!is.null(circ)) {
  163.         for(i in 1:length(circ)) {
  164.             if(circ[i] < 0 || circ[i] > nrow(x)) {
  165.                 cat("bad circ= specification")
  166.                 return()
  167.             }
  168.             if(circ[i] == 0) {
  169.                 cat(
  170.                     "response spec can only be lin or ordered (default)"
  171.                     )
  172.                 return()
  173.             }
  174.             else {
  175.                 nncol <- circ[i]
  176.                 if(l[nncol]!=2 & l[nncol]!=1) {
  177.                     cat(
  178.                         "conflicting transformation specifications"
  179.                         )
  180.                     return()
  181.                 }
  182.                 l[nncol] <- 2
  183.             }
  184.         }
  185.     }
  186.     if(!is.null(mon)) {
  187.         for(i in 1:length(mon)) {
  188.             if(mon[i] < 0 || mon[i] > nrow(x)) {
  189.                 cat("bad mon= specification")
  190.                 return()
  191.             }
  192.             if(mon[i] == 0) {
  193.                 cat(
  194.                     "response spec can only be lin or ordered (default)"
  195.                     )
  196.                 return()
  197.             }
  198.             else {
  199.                 nncol <- mon[i]
  200.                 if(l[nncol]!=3 && l[nncol]!=1) {
  201.                     cat(
  202.                         "conflicting transformation specifications"
  203.                         )
  204.                     return()
  205.                 }
  206.                 l[nncol] <- 3
  207.             }
  208.         }
  209.     }
  210.     if(!is.null(lin)) {
  211.         for(i in 1:length(lin)) {
  212.             if(lin[i] < 0 || lin[i] > nrow(x)) {
  213.                 cat("bad lin= specification")
  214.                 return()
  215.             }
  216.             if(lin[i] == 0) {
  217.                 nncol <- iy
  218.             }
  219.             else {
  220.                 nncol <- lin[i]
  221.             }
  222.             if(l[nncol]!=4 && l[nncol]!=1) {
  223.                 cat("conflicting transformation specifications"
  224.                     )
  225.                 return()
  226.             }
  227.             l[nncol] <- 4
  228.         }
  229.     }
  230.     if(!is.null(cat)) {
  231.         for(i in 1:length(cat)) {
  232.             if(cat[i] < 0 || cat[i] > nrow(x)) {
  233.                 cat("bad cat= specification")
  234.                 return()
  235.             }
  236.             if(cat[i] == 0) {
  237.                 cat(
  238.                     "response spec can only be lin or ordered (default)"
  239.                     )
  240.                 return()
  241.             }
  242.             else {
  243.                 nncol <- cat[i]
  244.                 if(l[nncol]!=4 && l[nncol]!=1) {
  245.                     cat(
  246.                         "conflicting transformation specifications"
  247.                         )
  248.                     return()
  249.                 }
  250.                 l[nncol] <- 4
  251.             }
  252.         }
  253.     }
  254.     tx <- x
  255.     ty <- y
  256.     m <- matrix(0, nrow = nrow(x), ncol = ncol(x) + 2)
  257.     z <- matrix(0, nrow = nrow(x), ncol = 17)
  258.     z <- as.matrix(z)
  259.     iters <- matrix(0, nrow = 100, ncol = 2)
  260.     mode(x) <- "double"
  261.     mode(y) <- "double"
  262.     mode(tx) <- "double"
  263.     mode(ty) <- "double"
  264.     mode(wt) <- "double"
  265.     mode(m) <- "integer"
  266.     mode(l) <- "integer"
  267.     mode(delrsq) <- "double"
  268.     mode(z) <- "double"
  269.     mode(yspan) <- "double"
  270.     mode(iters) <- "double"
  271.     junk <- .Fortran("avas",
  272.         ncol(x),
  273.         nrow(x),
  274.         x,
  275.         y,
  276.         wt,
  277.         l,
  278.         delrsq,
  279.         tx = tx,
  280.         ty = ty,
  281.         rsq = double(1),
  282.         ierr = integer(1),
  283.         m,
  284.         z,
  285.         yspan = yspan,
  286.         niter = integer(1),
  287.         iters = iters)
  288.     junk$iters <- junk$iters[1:junk$niter,  ]
  289.     return(list(x=x, y=y, tx = junk$tx, ty = junk$ty, rsq = junk$rsq, l, m, yspan = 
  290.         junk$yspan, iters = junk$iters, niters = junk$niter))
  291. }
  292.  
  293.  
  294.  
  295.  
  296.  
  297.  
  298.  
  299.  
  300.  
  301.  
  302.  
  303.  
  304.  
  305.  
  306.