inst/doc/Anthropometry.R

In Anthropometry: Statistical Methods for Anthropometric Data

## ----paquete,eval=FALSE-------------------------------------------------------
#  library("Anthropometry")

## ----trimowa1,eval=FALSE,tidy=FALSE-------------------------------------------
#  dataTrimowa <- sampleSpanishSurvey
#  numVar <- dim(dataTrimowa)[2]
#  bust <- dataTrimowa$bust
#  bustSizes <- bustSizesStandard(seq(74, 102, 4), seq(107, 131, 6))

## ----trimowa2,eval=FALSE,tidy=FALSE-------------------------------------------
#  orness <- 0.7
#  weightsTrimowa <- weightsMixtureUB(orness, numVar)

## ----trimowa3,eval=FALSE,tidy=FALSE-------------------------------------------
#  numClust <- 3 ; alpha <- 0.01 ; niter <- 10 ; algSteps <- 7
#  ah <- c(23, 28, 20, 25, 25)
#  
#  #suppressWarnings(RNGversion("3.5.0"))
#  #set.seed(2014)
#  numSizes <- bustSizes$nsizes - 1
#  res_trimowa <- computSizesTrimowa(dataTrimowa, bust, bustSizes$bustCirc,
#                                    numSizes, weightsTrimowa, numClust,
#                                    alpha, niter, algSteps, ah, FALSE)

## ----trimowa4,eval=FALSE,tidy=FALSE-------------------------------------------
#  prototypes <- anthrCases(res_trimowa, numSizes)

## ----trimowa5,eval=FALSE,tidy=FALSE-------------------------------------------
#  bustVariable <- "bust"
#  xlim <- c(72, 132)
#  color <- c("black", "red", "green", "blue", "cyan", "brown", "gray",
#             "deeppink3", "orange", "springgreen4", "khaki3", "steelblue1")
#  variable <- "necktoground"
#  ylim <- c(116, 156)
#  title <- "Prototypes \n bust vs neck to ground"
#  plotPrototypes(dataTrimowa, prototypes, numSizes, bustVariable,
#                 variable, color, xlim, ylim, title, FALSE)
#  plotPrototypes(dataTrimowa, prototypes, numSizes, bustVariable,
#                 variable, color, xlim, ylim, title, TRUE)

## ----TDDclust,eval=FALSE,tidy=FALSE-------------------------------------------
#  dataTDDcl <- sampleSpanishSurvey[1 : 25, c(2, 3, 5)]
#  dataTDDcl_aux <- sampleSpanishSurvey[1 : 25, c(2, 3, 5)]

## ----TDDclust2,eval=FALSE,tidy=FALSE------------------------------------------
#  numClust <- 3 ; alpha <- 0.01 ; lambda <- 0.5 ; niter <- 5
#  Th <- 0 ; T0 <- 0 ; simAnn <- 0.9
#  
#  #suppressWarnings(RNGversion("3.5.0"))
#  #set.seed(2014)
#  res_TDDcl <- TDDclust(dataTDDcl, numClust, lambda, Th, niter, T0, simAnn,
#                        alpha, dataTDDcl_aux, verbose = FALSE)

## ----TDDclust3,eval=FALSE,tidy=FALSE------------------------------------------
#  table(res_TDDcl$NN[1,])
#  #1  2  3
#  #5 10  9
#  res_TDDcl$Cost
#  #[1] 0.3717631
#  res_TDDcl$klBest
#  #[1] 3

## ----TDDclust4,eval=FALSE,tidy=FALSE------------------------------------------
#  prototypes <- anthrCases(res_TDDcl)
#  trimmed <- trimmOutl(res_TDDcl)

## ----hipam,eval=FALSE,tidy=FALSE----------------------------------------------
#  dataHipam <- sampleSpanishSurvey
#  bust <- dataHipam$bust
#  bustSizes <- bustSizesStandard(seq(74, 102, 4), seq(107, 131, 6))

## ----hipam2,eval=FALSE,tidy=FALSE---------------------------------------------
#  type <- "IMO"
#  maxsplit <- 5 ; orness <- 0.7
#  ah <- c(23, 28, 20, 25, 25)
#  
#  #suppressWarnings(RNGversion("3.5.0"))
#  #set.seed(2013)
#  numSizes <- bustSizes$nsizes - 1
#  res_hipam <- computSizesHipamAnthropom(dataHipam, bust, bustSizes$bustCirc,
#                                         numSizes, maxsplit, orness, type,
#                                         ah, FALSE)

## ----hipam3,eval=FALSE,tidy=FALSE---------------------------------------------
#  fitmodels <- anthrCases(res_hipam, numSizes)
#  outliers <- trimmOutl(res_hipam, numSizes)

## ----hipam4,eval=FALSE,tidy=FALSE---------------------------------------------
#  bustVariable <- "bust"
#  xlim <- c(72, 132)
#  color <- c("black", "red", "green", "blue", "cyan", "brown", "gray",
#             "deeppink3", "orange", "springgreen4", "khaki3", "steelblue1")
#  variable <- "hip"
#  ylim <- c(83, 153)
#  title <- "Fit models HIPAM_IMO \n bust vs hip"
#  title_outl <- "Outlier women HIPAM_IMO \n bust vs hip"
#  plotPrototypes(dataHipam, fitmodels, numSizes, bustVariable,
#                 variable, color, xlim, ylim, title, FALSE)
#  plotTrimmOutl(dataHipam, outliers, numSizes, bustVariable,
#                variable, color, xlim, ylim, title_outl)

## ----ssa,eval=FALSE,tidy=FALSE------------------------------------------------
#  landmarksNoNa <- na.exclude(landmarksSampleSpaSurv)
#  numLandmarks <- (dim(landmarksNoNa)[2]) / 3
#  landmarksNoNa_First50 <- landmarksNoNa[1 : 50, ]
#  numIndiv <- dim(landmarksNoNa_First50)[1]

## ----ssa1,eval=FALSE,tidy=FALSE-----------------------------------------------
#  array3D <- array3Dlandm(numLandmarks, numIndiv, landmarksNoNa_First50)

## ----ssa2,eval=FALSE,tidy=FALSE-----------------------------------------------
#  numClust <- 3 ; alpha <- 0.01 ; algSteps <- 5
#  niter <- 5 ; stopCr <- 0.0001

## ----ssa22,eval=FALSE,tidy=FALSE----------------------------------------------
#  #suppressWarnings(RNGversion("3.5.0"))
#  #set.seed(2013)
#  res_kmProc <- trimmedLloydShapes(array3D, numIndiv, alpha, numClust,
#                                       algSteps, niter, stopCr,
#                                       verbose = FALSE)

## ----ssa3,eval=FALSE,tidy=FALSE-----------------------------------------------
#  clust_kmProc <- res_kmProc$asig
#  table(clust_kmProc)
#  #1  2  3
#  #19 18 12

## ----ssa4,eval=FALSE,tidy=FALSE-----------------------------------------------
#  prototypes <- anthrCases(res_kmProc)
#  trimmed <- trimmOutl(res_kmProc)

## ----ssa5,eval=FALSE,tidy=FALSE-----------------------------------------------
#  data_First50 <- sampleSpanishSurvey[1 : 50, ]
#  data_First50_notrimm <- data_First50[-trimmed, ]
#  boxplot(data_First50_notrimm$necktoground ~ as.factor(clust_kmProc),
#          main = "Neck to ground")

## ----ssa6,eval=FALSE,tidy=FALSE-----------------------------------------------
#  projShapes(1, array3D, clust_kmProc, prototypes)
#  legend("topleft", c("Registrated data", "Mean shape"),
#                  pch = 1, col = 1:2, text.col = 1:2)
#  title("Procrustes registrated data for cluster 1 \n
#                  with its mean shape superimposed", sub = "Plane xy")

## ----AA,eval=FALSE,tidy=FALSE-------------------------------------------------
#  USAFSurvey_First50 <- USAFSurvey[1 : 50, ]
#  variabl_sel <- c(48, 40, 39, 33, 34, 36)
#  USAFSurvey_First50_inch <- USAFSurvey_First50[,variabl_sel] / (10 * 2.54)
#  USAFSurvey_preproc <- preprocessing(data = USAFSurvey_First50_inch,
#                                      stand = TRUE, percAccomm = 0.95,
#                                      mahal= TRUE)

## ----AA3,eval=FALSE,tidy=FALSE------------------------------------------------
#  #suppressWarnings(RNGversion("3.5.0"))
#  #set.seed(2010)
#  numArch <- 10 ; numRep <- 20
#  oldw <- getOption("warn")
#  options(warn = -1)
#  lass <- stepArchetypesRawData(data = USAFSurvey_preproc$data,
#                                numArch=1:numArch, numRep = numRep,
#                                verbose = FALSE)
#  options(warn = oldw)
#  screeplot(lass)

## ----AA4,eval=FALSE,tidy=FALSE------------------------------------------------
#  numArchoid <- 3
#  res_archoids_ns <- archetypoids(numArchoid, USAFSurvey_preproc$data,
#                                  huge = 200, step = FALSE, ArchObj = lass,
#                                  nearest = "cand_ns" , sequ = TRUE)
#  res_archoids_alpha <- archetypoids(numArchoid, USAFSurvey_preproc$data,
#                                     huge = 200, step = FALSE, ArchObj = lass,
#                                     nearest = "cand_alpha", sequ = TRUE)
#  res_archoids_beta <- archetypoids(numArchoid, USAFSurvey_preproc$data,
#                                    huge = 200, step = FALSE, ArchObj = lass,
#                                    nearest = "cand_beta", sequ = TRUE)
#  
#  boundaries_ns <- anthrCases(res_archoids_ns)
#  boundaries_alpha <- anthrCases(res_archoids_alpha)
#  boundaries_beta <- anthrCases(res_archoids_beta)

## ----AA5,eval=FALSE,tidy=FALSE------------------------------------------------
#  df <- USAFSurvey_preproc$data
#  matPer <- t(sapply(1:dim(df)[2], percentilsArchetypoid, boundaries_ns, df, 0))

## ----AA6,eval=FALSE,tidy=FALSE------------------------------------------------
#  barplot(matPer, beside = TRUE, main = paste(numArchoid,
#                                              " archetypoids", sep = ""),
#          ylim = c(0, 100), ylab = "Percentile",
#          xlab = "Each bar is related to each anthropometric
#                 variable selected")