[R] Problem to transfer Splus functions

Michel ARNAUD michel.arnaud at cirad.fr
Mon Nov 5 08:15:18 CET 2001


Hello
I would like to transfer some Splus functions in R.
But I have a problem first about this assignation in Splus :
 xnom <- deparse(substitute(x))

I am a bad programmer : I don't understand the R help
How to modify these functions ?
Thank you very much for your help

Here are the four functions and a data test
####################################################################################

acp <- function(x, wt = rep(1/nrow(x), nrow(x)), d = rep(1, ncol(x)),
ctr = T,
 reduc = T, contav = F, method = "acp", tol = 10^(-8))
{
#============================================================
#       Methode d'analyse en composantes principales
#       avec des metriques diagonales:
#       wt vecteur des poids
#       d vecteurs des elements diagonaux de la metrique
#       si ctr=T l'acp est centree
#       si reduc=T l'acp est reduite
#             Method = "acp" or "afc" or "afcm"
#              method that produced the call to the function acp
#             tol values of the eigenvalues that are set to zero
#                to avoid zero "negative" values
#============================================================
 x <- as.matrix(x)
 wt <- wt/sum(wt) #Normalisation des poids
 x <- crenom(x)
 nam <- dimnames(x)
 y <- centre(x, wt)
 moy <- (x - y)[1,  ]
 names(moy) <- nam[[2]]
 if(ctr)
  x <- y
 y <- reduct(x, wt, ctr = ctr)
 sigm <- attr(y, "std")
 names(sigm) <- nam[[2]] #    ..si reduc=T..alors
 if(reduc) x <- y
 #------------------------------controle prealable: impression des
contributions (si contav=T)
 if(contav) {
  conta(x, d, wt)
  cat("\n")
  tex <- c("On continue ?", "Arret")
  ski <- menu(tex)
  switch(ski,
   ,
   stop())
 }
 y <- wt * x
 v <- t(x) %*% y #  Calcul de la matrice a diagonaliser
 d12 <- sqrt(d)
 v <- d12 * v
 v <- t(d12 * t(v))
 res <- eigen(v, symmetric = T)
 #  Recherche des elements propres de v
#------------------------------------------------------------------------

# Factors associated with very small eigenvalues removed
#------------------------------------------------------------------------

 nf <- length(res$values)
 cond <- res$values < tol * sum(res$values)
 nfmax <- if(sum(cond) > 0) min((1:length(res$values))[cond]) -
   1 else nf
 res$values <- res$values[1:nfmax]
 res$vectors <- res$vectors[, 1:nfmax]
 vecp <- res$vectors
 #   Reorientation des deux premiers vecteurs propres pour avoir un max
#   de saturations positives
 v12 <- rep(1, ncol(x)) %*% (vecp[, 1:2]/abs(vecp[, 1:2]))
 v12 <- 2 * (as.numeric(v12 >= 0) - 0.5)
 vecp[, 1:2] <- t(v12 * t(vecp[, 1:2]))
 #        calcul des vecteurs propres M normes
 res$vectors <- (1/sqrt(d)) * vecp
 # Generation des noms de facteurs
 nomf <- as.vector(outer("f", 1:nfmax, paste, sep = ""))
 dimnames(res$vectors) <- list(nam[[2]], nomf)
 #Affectation des noms
#         des vecteurs principaux
 res$cmpr <- x %*% (d12 * vecp)
 #Calcul des composantes principales

 xnom <- deparse(substitute(x))
 wtnom <- deparse(substitute(wt))
 wtequal <- F
 if(wtnom == paste("rep(1/nrow(", xnom, "), nrow(", xnom, "))",
  sep = ""))
  wtequal <- T
 dnom <- deparse(substitute(d))
 dusual <- F
 if(dnom == paste("rep(1, ncol(", xnom, "))", sep = ""))
  dusual <- T
 dimnames(res$cmpr)[[2]] <- nomf
 names(res$values) <- nomf
 res$d <- d
 res$pi <- wt
 res$reduc <- reduc
 res$ctr <- ctr
 res$moy <- moy
 res$sigma <- sigm
 attr(res, "class") <- "acp"
 res$xnom <- xnom
 res$wtequal <- wtequal
 if(!wtequal)
  res$wtnom <- wtnom
 res$dusual <- dusual
 if(!dusual)
  res$dnom <- dnom
 if(method == "acp")
  print(res)
 res
}

####################################################################################

crenom <- function(x, nl = "i", nv = "v")
{
#--------------------------------------------------------------------------

#  Cree des noms pour le tableau x si ces noms n'existent pas
#  Par defaut, les noms de ligne commencent par "i", ceux de colonnes
#  par "v"
#--------------------------------------------------------------------------

 nomi <- if((!is.null(dimnames(x)) && !is.null(dimnames(x)[[1]])
  ) && length(dimnames(x)[[1]]) != 0) dimnames(x)[[1]]
   else (paste(nl, 1:nrow(x), sep = ""))
 nomv <- if(!is.null(dimnames(x)) && !is.null(dimnames(x)[[2]]) &&
  length(dimnames(x)[[2]]) != 0) dimnames(x)[[2]] else (
   paste(nv, 1:ncol(x), sep = ""))
 dimnames(x) <- list(nomi, nomv)
 x
}
####################################################################################

centre <- function(x, wt = rep(1, nrow(as.matrix(x))))
{
# centre le nuage des lignes de x ponderees par wt
 x <- as.matrix(x)
 g <- as.vector((wt %*% x)/sum(wt))
 t(t(x) - g)
}
####################################################################################

reduct <- function(x, wt = rep(1/nrow(x), nrow(x)), ctr = T)
{
# Calcul d'une matrice reduite (avec poids)
#
#               wt vecteur des poids
#============================================================
 nc <- ncol(x)
 nr <- nrow(x)
 nam <- dimnames(x)
 wt <- wt/sum(wt)
 mx <- wt %*% x
 xx <- t(t(x) - as.vector(mx))
 rwt <- sqrt(wt)
 y <- rwt * xx #.. integration des poids..
 stdx <- sqrt(diag(t(y) %*% y))
 if(ctr)
  x <- xx
 x <- t(t(x)/stdx)
 dimnames(x) <- nam
 attr(x, "std") <- stdx
 x
}
   ca  mg   cl  so4 hco3  co2   c    te   deb
 62.8 3.5 1.75 27.5  173 2.93 300 10.40 0.092
 62.8 4.0 1.65 27.0  177 2.92 300 10.40 0.490
 64.5 3.6 1.65 28.5  179 3.10 303 10.40 0.560
 64.0 5.0 1.70 26.0  184 3.33 308 10.40 0.605
 61.6 5.0 1.90 28.0  178 3.08 303 10.40 0.690
 63.5 4.4 1.75 27.5  179 2.76 302 10.50 0.740
 66.8 4.4 1.65 31.5  183 2.82 311 10.50 0.760
 69.3 4.4 1.85 37.0  188 3.02 330 10.45 0.810
 66.3 5.5 1.80 35.5  186 2.92 327 10.45 0.830
 66.5 4.7 1.75 32.5  182 2.86 317 10.45 0.860
 66.1 3.3 1.80 28.5  181 2.78 307 10.45 0.890
 62.8 3.2 1.70 23.0  177 2.79 293 10.40 0.950
 62.3 3.8 1.60 23.0  177 1.92 294 10.40 1.050
 69.0 3.9 1.85 35.5  185 3.44 324 10.35 1.190
 71.5 5.0 1.95 38.5  195 3.94 344 10.35 1.220
 73.2 5.5 2.25 40.5  208 4.38 352 10.35 1.220
 71.7 5.7 2.20 35.0  204 4.94 347 10.35 1.240
 73.0 4.9 2.30 36.5  200 4.64 348 10.35 1.260
 69.3 4.5 2.25 29.5  193 4.38 333 10.35 1.350
 64.5 3.3 2.00 18.5  187 4.25 306 10.35 1.630
 60.8 3.9 2.00 14.0  183 4.08 292 10.30 1.830
 62.5 3.8 2.45 12.5  190 4.81 296 10.10 1.580
 61.7 3.4 2.25 11.0  187 4.77 288 10.05 2.210
 62.9 3.0 2.20 10.5  189 4.61 291 10.05 1.930
 66.0 2.7 2.30  9.5  198 3.49 301 10.10 1.200
 66.5 2.3 2.25  9.5  198 3.65 303 10.05 1.050
 65.5 3.0 2.40 11.0  198 3.82 304 10.05 0.905
 65.5 2.5 2.30 11.0  195 3.61 298 10.05 0.490
 64.7 3.0 2.25  9.5  195 3.69 297 10.05 0.495
 66.5 3.4 2.25 13.0  198 3.91 308 10.10 0.830
 66.9 3.5 2.50 14.0  199 4.21 309 10.05 1.010
 64.5 3.4 2.20 11.5  192 3.79 298 10.00 0.920
 63.7 3.3 2.20 11.5  189 3.92 297 10.00 0.650
 63.7 3.4 2.30 13.0  190 3.95 297 10.10 0.560


--
Michel ARNAUD
CIRAD
TA60/15
73, av. Jean François Breton
34938 MONTPELLIER CEDEX 5
tel   04 67 59 38 34 - Fax 04 67 59 38 27

-------------- next part --------------
A non-text attachment was scrubbed...
Name: michel.arnaud.vcf
Type: text/x-vcard
Size: 204 bytes
Desc: Carte pour Michel ARNAUD
Url : https://stat.ethz.ch/pipermail/r-help/attachments/20011105/522667a4/michel.arnaud.vcf


More information about the R-help mailing list