R Markdown
This is an R Markdown document. Markdown is a simple formatting
syntax for authoring HTML, PDF, and MS Word documents. For more details
on using R Markdown see http://rmarkdown.rstudio.com.
When you click the Knit button a document will be
generated that includes both content as well as the output of any
embedded R code chunks within the document. You can embed an R code
chunk like this:
#librerias
library(summarytools)
library("readxl")
file_path1 <- "C:/Users/PLOZANO/Desktop/RECURSOS DE SPA 2023 2024/tesis 2024/Tesis de 10 semestre PPA 2024 2024/ANAHI/ANAHI.xlsx"
datanahi<- read_excel(file_path1)
file_path2 <- "C:/Users/PLOZANO/Desktop/RECURSOS DE SPA 2023 2024/tesis 2024/Tesis de 10 semestre PPA 2024 2024/ANAHI/ANAHI2.xlsx"
datanahi1<- read_excel(file_path2)
data
## function (..., list = character(), package = NULL, lib.loc = NULL,
## verbose = getOption("verbose"), envir = .GlobalEnv, overwrite = TRUE)
## {
## fileExt <- function(x) {
## db <- grepl("\\.[^.]+\\.(gz|bz2|xz)$", x)
## ans <- sub(".*\\.", "", x)
## ans[db] <- sub(".*\\.([^.]+\\.)(gz|bz2|xz)$", "\\1\\2",
## x[db])
## ans
## }
## my_read_table <- function(...) {
## lcc <- Sys.getlocale("LC_COLLATE")
## on.exit(Sys.setlocale("LC_COLLATE", lcc))
## Sys.setlocale("LC_COLLATE", "C")
## read.table(...)
## }
## stopifnot(is.character(list))
## names <- c(as.character(substitute(list(...))[-1L]), list)
## if (!is.null(package)) {
## if (!is.character(package))
## stop("'package' must be a character vector or NULL")
## }
## paths <- find.package(package, lib.loc, verbose = verbose)
## if (is.null(lib.loc))
## paths <- c(path.package(package, TRUE), if (!length(package)) getwd(),
## paths)
## paths <- unique(normalizePath(paths[file.exists(paths)]))
## paths <- paths[dir.exists(file.path(paths, "data"))]
## dataExts <- tools:::.make_file_exts("data")
## if (length(names) == 0L) {
## db <- matrix(character(), nrow = 0L, ncol = 4L)
## for (path in paths) {
## entries <- NULL
## packageName <- if (file_test("-f", file.path(path,
## "DESCRIPTION")))
## basename(path)
## else "."
## if (file_test("-f", INDEX <- file.path(path, "Meta",
## "data.rds"))) {
## entries <- readRDS(INDEX)
## }
## else {
## dataDir <- file.path(path, "data")
## entries <- tools::list_files_with_type(dataDir,
## "data")
## if (length(entries)) {
## entries <- unique(tools::file_path_sans_ext(basename(entries)))
## entries <- cbind(entries, "")
## }
## }
## if (NROW(entries)) {
## if (is.matrix(entries) && ncol(entries) == 2L)
## db <- rbind(db, cbind(packageName, dirname(path),
## entries))
## else warning(gettextf("data index for package %s is invalid and will be ignored",
## sQuote(packageName)), domain = NA, call. = FALSE)
## }
## }
## colnames(db) <- c("Package", "LibPath", "Item", "Title")
## footer <- if (missing(package))
## paste0("Use ", sQuote(paste("data(package =", ".packages(all.available = TRUE))")),
## "\n", "to list the data sets in all *available* packages.")
## else NULL
## y <- list(title = "Data sets", header = NULL, results = db,
## footer = footer)
## class(y) <- "packageIQR"
## return(y)
## }
## paths <- file.path(paths, "data")
## for (name in names) {
## found <- FALSE
## for (p in paths) {
## tmp_env <- if (overwrite)
## envir
## else new.env()
## if (file_test("-f", file.path(p, "Rdata.rds"))) {
## rds <- readRDS(file.path(p, "Rdata.rds"))
## if (name %in% names(rds)) {
## found <- TRUE
## if (verbose)
## message(sprintf("name=%s:\t found in Rdata.rds",
## name), domain = NA)
## thispkg <- sub(".*/([^/]*)/data$", "\\1", p)
## thispkg <- sub("_.*$", "", thispkg)
## thispkg <- paste0("package:", thispkg)
## objs <- rds[[name]]
## lazyLoad(file.path(p, "Rdata"), envir = tmp_env,
## filter = function(x) x %in% objs)
## break
## }
## else if (verbose)
## message(sprintf("name=%s:\t NOT found in names() of Rdata.rds, i.e.,\n\t%s\n",
## name, paste(names(rds), collapse = ",")),
## domain = NA)
## }
## if (file_test("-f", file.path(p, "Rdata.zip"))) {
## warning("zipped data found for package ", sQuote(basename(dirname(p))),
## ".\nThat is defunct, so please re-install the package.",
## domain = NA)
## if (file_test("-f", fp <- file.path(p, "filelist")))
## files <- file.path(p, scan(fp, what = "", quiet = TRUE))
## else {
## warning(gettextf("file 'filelist' is missing for directory %s",
## sQuote(p)), domain = NA)
## next
## }
## }
## else {
## files <- list.files(p, full.names = TRUE)
## }
## files <- files[grep(name, files, fixed = TRUE)]
## if (length(files) > 1L) {
## o <- match(fileExt(files), dataExts, nomatch = 100L)
## paths0 <- dirname(files)
## paths0 <- factor(paths0, levels = unique(paths0))
## files <- files[order(paths0, o)]
## }
## if (length(files)) {
## for (file in files) {
## if (verbose)
## message("name=", name, ":\t file= ...", .Platform$file.sep,
## basename(file), "::\t", appendLF = FALSE,
## domain = NA)
## ext <- fileExt(file)
## if (basename(file) != paste0(name, ".", ext))
## found <- FALSE
## else {
## found <- TRUE
## zfile <- file
## zipname <- file.path(dirname(file), "Rdata.zip")
## if (file.exists(zipname)) {
## Rdatadir <- tempfile("Rdata")
## dir.create(Rdatadir, showWarnings = FALSE)
## topic <- basename(file)
## rc <- .External(C_unzip, zipname, topic,
## Rdatadir, FALSE, TRUE, FALSE, FALSE)
## if (rc == 0L)
## zfile <- file.path(Rdatadir, topic)
## }
## if (zfile != file)
## on.exit(unlink(zfile))
## switch(ext, R = , r = {
## library("utils")
## sys.source(zfile, chdir = TRUE, envir = tmp_env)
## }, RData = , rdata = , rda = load(zfile,
## envir = tmp_env), TXT = , txt = , tab = ,
## tab.gz = , tab.bz2 = , tab.xz = , txt.gz = ,
## txt.bz2 = , txt.xz = assign(name, my_read_table(zfile,
## header = TRUE, as.is = FALSE), envir = tmp_env),
## CSV = , csv = , csv.gz = , csv.bz2 = ,
## csv.xz = assign(name, my_read_table(zfile,
## header = TRUE, sep = ";", as.is = FALSE),
## envir = tmp_env), found <- FALSE)
## }
## if (found)
## break
## }
## if (verbose)
## message(if (!found)
## "*NOT* ", "found", domain = NA)
## }
## if (found)
## break
## }
## if (!found) {
## warning(gettextf("data set %s not found", sQuote(name)),
## domain = NA)
## }
## else if (!overwrite) {
## for (o in ls(envir = tmp_env, all.names = TRUE)) {
## if (exists(o, envir = envir, inherits = FALSE))
## warning(gettextf("an object named %s already exists and will not be overwritten",
## sQuote(o)))
## else assign(o, get(o, envir = tmp_env, inherits = FALSE),
## envir = envir)
## }
## rm(tmp_env)
## }
## }
## invisible(names)
## }
## <bytecode: 0x000001c2525891b8>
## <environment: namespace:utils>
datanahi1
## # A tibble: 15 × 20
## P1 P2 P3 P4 P5 P6 P7 P8 P9 P10 P11 P12 P13
## <chr> <chr> <chr> <chr> <chr> <chr> <chr> <chr> <chr> <chr> <chr> <chr> <chr>
## 1 Cont… Diar… No Uso … Si Insp… Sà Refr… Comp… Si si si Sepa…
## 2 Bols… Diar… Si Inst… Si Insp… No Refr… Dura… Si si si Sepa…
## 3 Cont… Diar… No Uso … Ocas… Insp… Sà Refr… Toda… Si No si Sepa…
## 4 Bols… Diar… Si Uso … Si Sist… No e… Refr… Toda… No No ocas… No s…
## 5 Bols… Diar… No No No Sist… No Refr… Comp… Si No si Sepa…
## 6 Bols… Diar… No No No Sist… No No s… Toda… A ve… No e… si Sepa…
## 7 Bols… Diar… Si Uso … Ocas… Equi… No e… Refr… Dura… No si si Sepa…
## 8 Cont… Sema… Si Uso … No Insp… no e… Refr… Dura… A ve… No si No s…
## 9 Bols… Diar… Si Uso … No Sist… No Dese… Toda… No No si Sepa…
## 10 Cont… Sema… Si Uso … No Insp… No Refr… Toda… A ve… A ve… ocas… No s…
## 11 Bols… Diar… No Uso … No Sist… Sà Refr… Toda… No No ocas… No s…
## 12 Bols… Diar… No No No Insp… No e… Mezc… Toda… No No si Sepa…
## 13 Bols… Diar… No No Ocas… Insp… No Refr… costo No si ocas… No s…
## 14 Bols… Sema… No No Ocas… Insp… No Mezc… Toda… No No si No s…
## 15 Bols… Diar… No No Ocas… Insp… No Mezc… costo A ve… No si No s…
## # ℹ 7 more variables: P14 <chr>, P15 <chr>, P16 <chr>, P17 <chr>, P18 <chr>,
## # P19 <chr>, P20 <chr>
#proporcion tabla
print(dfSummary(datanahi, graph.magnif = 0.75), method = 'render')
Distribución separada para casos y controles. Para ello necesitamos
crear una base de datos distinta para cada grupo (esto es una desventaja
de usar funciones básicas de R, pero tampoco es tan grave). Podemos usar
las funciones que ya conocemos para tratar datos. Crearemos la densidad
para uno de los grupos y luego añadiremos la del otro con la función
lines (). Finalmente, podemos añadir una leyenda con la
función legend ().
# Tablas Cruzadas AnahÃ
ctable(datanahi1$P1, datanahi1$P2, prop="r")
## Cross-Tabulation, Row Proportions
## P1 * P2
## Data Frame: datanahi1
##
## ----------------------- ---- ------------- -------------- -------------
## P2 Diariamente Semanalmente Total
## P1
## Bolsas de plasticos 10 (90.9%) 1 ( 9.1%) 11 (100.0%)
## Contenedores cerrados 2 (50.0%) 2 (50.0%) 4 (100.0%)
## Total 12 (80.0%) 3 (20.0%) 15 (100.0%)
## ----------------------- ---- ------------- -------------- -------------
ctable(datanahi1$P3, datanahi1$P4, prop="r")
## Cross-Tabulation, Row Proportions
## P3 * P4
## Data Frame: datanahi1
##
## ------- ---- ------------------- ----------- ----------------- ------------------ -------------
## P4 Instalado señales No Uso de carteles Uso de etiquetas Total
## P3
## No 0 ( 0.0%) 6 (66.7%) 1 (11.1%) 2 (22.2%) 9 (100.0%)
## Si 1 (16.7%) 0 ( 0.0%) 0 ( 0.0%) 5 (83.3%) 6 (100.0%)
## Total 1 ( 6.7%) 6 (40.0%) 1 ( 6.7%) 7 (46.7%) 15 (100.0%)
## ------- ---- ------------------- ----------- ----------------- ------------------ -------------
ctable(datanahi1$P5, datanahi1$P6, prop="r")
## Cross-Tabulation, Row Proportions
## P5 * P6
## Data Frame: datanahi1
##
## ---------------- ---- ----------------------- ------------------------- ------------------------- -------------
## P6 Equipos de protección Inspecciones periódicas Sistemas de ventilación Total
## P5
## No 0 ( 0.0%) 3 (42.9%) 4 (57.1%) 7 (100.0%)
## Ocasionalmente 1 (20.0%) 4 (80.0%) 0 ( 0.0%) 5 (100.0%)
## Si 0 ( 0.0%) 2 (66.7%) 1 (33.3%) 3 (100.0%)
## Total 1 ( 6.7%) 9 (60.0%) 5 (33.3%) 15 (100.0%)
## ---------------- ---- ----------------------- ------------------------- ------------------------- -------------
ctable(datanahi1$P7, datanahi1$P8, prop="r")
## Cross-Tabulation, Row Proportions
## P7 * P8
## Data Frame: datanahi1
##
## ----------------- ---- ----------- ----------- --------------- ---------------- -------------
## P8 Desechan Mezclan No se generan Refrigeradores Total
## P7
## No 1 (12.5%) 2 (25.0%) 1 (12.5%) 4 ( 50.0%) 8 (100.0%)
## No es necesario 0 ( 0.0%) 0 ( 0.0%) 0 ( 0.0%) 1 (100.0%) 1 (100.0%)
## no estoy seguro 0 ( 0.0%) 0 ( 0.0%) 0 ( 0.0%) 1 (100.0%) 1 (100.0%)
## No estoy seguro 0 ( 0.0%) 1 (50.0%) 0 ( 0.0%) 1 ( 50.0%) 2 (100.0%)
## SÃ 0 ( 0.0%) 0 ( 0.0%) 0 ( 0.0%) 3 (100.0%) 3 (100.0%)
## Total 1 ( 6.7%) 3 (20.0%) 1 ( 6.7%) 10 ( 66.7%) 15 (100.0%)
## ----------------- ---- ----------- ----------- --------------- ---------------- -------------
ctable(datanahi1$P9, datanahi1$P15, prop="r")
## Cross-Tabulation, Row Proportions
## P9 * P15
## Data Frame: datanahi1
##
## --------------------------- ----- ----------- ------------- ------------ -------------
## P15 A veces No Si Total
## P9
## Compatibilidad 0 ( 0.0%) 0 ( 0.0%) 2 (100.0%) 2 (100.0%)
## costo 0 ( 0.0%) 2 (100.0%) 0 ( 0.0%) 2 (100.0%)
## Durabilidad y resistencia 0 ( 0.0%) 2 ( 66.7%) 1 ( 33.3%) 3 (100.0%)
## Todas las anteriores 1 (12.5%) 6 ( 75.0%) 1 ( 12.5%) 8 (100.0%)
## Total 1 ( 6.7%) 10 ( 66.7%) 4 ( 26.7%) 15 (100.0%)
## --------------------------- ----- ----------- ------------- ------------ -------------
ctable(datanahi1$P16, datanahi1$P17, prop="r")
## Cross-Tabulation, Row Proportions
## P16 * P17
## Data Frame: datanahi1
##
## --------------------- ----- ------------- ---------------- ----------- -------------
## P17 No Ocasionalmente Si Total
## P16
## administrador 2 (100.0%) 0 ( 0.0%) 0 ( 0.0%) 2 (100.0%)
## personal limpieza 0 ( 0.0%) 2 (100.0%) 0 ( 0.0%) 2 (100.0%)
## todos los empleados 8 ( 72.7%) 1 ( 9.1%) 2 (18.2%) 11 (100.0%)
## Total 10 ( 66.7%) 3 ( 20.0%) 2 (13.3%) 15 (100.0%)
## --------------------- ----- ------------- ---------------- ----------- -------------
CORRELACION
#componente principales
file_path2 <- "C:/Users/PLOZANO/Desktop/RECURSOS DE SPA 2023 2024/tesis 2024/Tesis de 10 semestre PPA 2024 2024/ANAHI/ANAHI3.xlsx"
datanahi2<- read_excel(file_path2)
data
## function (..., list = character(), package = NULL, lib.loc = NULL,
## verbose = getOption("verbose"), envir = .GlobalEnv, overwrite = TRUE)
## {
## fileExt <- function(x) {
## db <- grepl("\\.[^.]+\\.(gz|bz2|xz)$", x)
## ans <- sub(".*\\.", "", x)
## ans[db] <- sub(".*\\.([^.]+\\.)(gz|bz2|xz)$", "\\1\\2",
## x[db])
## ans
## }
## my_read_table <- function(...) {
## lcc <- Sys.getlocale("LC_COLLATE")
## on.exit(Sys.setlocale("LC_COLLATE", lcc))
## Sys.setlocale("LC_COLLATE", "C")
## read.table(...)
## }
## stopifnot(is.character(list))
## names <- c(as.character(substitute(list(...))[-1L]), list)
## if (!is.null(package)) {
## if (!is.character(package))
## stop("'package' must be a character vector or NULL")
## }
## paths <- find.package(package, lib.loc, verbose = verbose)
## if (is.null(lib.loc))
## paths <- c(path.package(package, TRUE), if (!length(package)) getwd(),
## paths)
## paths <- unique(normalizePath(paths[file.exists(paths)]))
## paths <- paths[dir.exists(file.path(paths, "data"))]
## dataExts <- tools:::.make_file_exts("data")
## if (length(names) == 0L) {
## db <- matrix(character(), nrow = 0L, ncol = 4L)
## for (path in paths) {
## entries <- NULL
## packageName <- if (file_test("-f", file.path(path,
## "DESCRIPTION")))
## basename(path)
## else "."
## if (file_test("-f", INDEX <- file.path(path, "Meta",
## "data.rds"))) {
## entries <- readRDS(INDEX)
## }
## else {
## dataDir <- file.path(path, "data")
## entries <- tools::list_files_with_type(dataDir,
## "data")
## if (length(entries)) {
## entries <- unique(tools::file_path_sans_ext(basename(entries)))
## entries <- cbind(entries, "")
## }
## }
## if (NROW(entries)) {
## if (is.matrix(entries) && ncol(entries) == 2L)
## db <- rbind(db, cbind(packageName, dirname(path),
## entries))
## else warning(gettextf("data index for package %s is invalid and will be ignored",
## sQuote(packageName)), domain = NA, call. = FALSE)
## }
## }
## colnames(db) <- c("Package", "LibPath", "Item", "Title")
## footer <- if (missing(package))
## paste0("Use ", sQuote(paste("data(package =", ".packages(all.available = TRUE))")),
## "\n", "to list the data sets in all *available* packages.")
## else NULL
## y <- list(title = "Data sets", header = NULL, results = db,
## footer = footer)
## class(y) <- "packageIQR"
## return(y)
## }
## paths <- file.path(paths, "data")
## for (name in names) {
## found <- FALSE
## for (p in paths) {
## tmp_env <- if (overwrite)
## envir
## else new.env()
## if (file_test("-f", file.path(p, "Rdata.rds"))) {
## rds <- readRDS(file.path(p, "Rdata.rds"))
## if (name %in% names(rds)) {
## found <- TRUE
## if (verbose)
## message(sprintf("name=%s:\t found in Rdata.rds",
## name), domain = NA)
## thispkg <- sub(".*/([^/]*)/data$", "\\1", p)
## thispkg <- sub("_.*$", "", thispkg)
## thispkg <- paste0("package:", thispkg)
## objs <- rds[[name]]
## lazyLoad(file.path(p, "Rdata"), envir = tmp_env,
## filter = function(x) x %in% objs)
## break
## }
## else if (verbose)
## message(sprintf("name=%s:\t NOT found in names() of Rdata.rds, i.e.,\n\t%s\n",
## name, paste(names(rds), collapse = ",")),
## domain = NA)
## }
## if (file_test("-f", file.path(p, "Rdata.zip"))) {
## warning("zipped data found for package ", sQuote(basename(dirname(p))),
## ".\nThat is defunct, so please re-install the package.",
## domain = NA)
## if (file_test("-f", fp <- file.path(p, "filelist")))
## files <- file.path(p, scan(fp, what = "", quiet = TRUE))
## else {
## warning(gettextf("file 'filelist' is missing for directory %s",
## sQuote(p)), domain = NA)
## next
## }
## }
## else {
## files <- list.files(p, full.names = TRUE)
## }
## files <- files[grep(name, files, fixed = TRUE)]
## if (length(files) > 1L) {
## o <- match(fileExt(files), dataExts, nomatch = 100L)
## paths0 <- dirname(files)
## paths0 <- factor(paths0, levels = unique(paths0))
## files <- files[order(paths0, o)]
## }
## if (length(files)) {
## for (file in files) {
## if (verbose)
## message("name=", name, ":\t file= ...", .Platform$file.sep,
## basename(file), "::\t", appendLF = FALSE,
## domain = NA)
## ext <- fileExt(file)
## if (basename(file) != paste0(name, ".", ext))
## found <- FALSE
## else {
## found <- TRUE
## zfile <- file
## zipname <- file.path(dirname(file), "Rdata.zip")
## if (file.exists(zipname)) {
## Rdatadir <- tempfile("Rdata")
## dir.create(Rdatadir, showWarnings = FALSE)
## topic <- basename(file)
## rc <- .External(C_unzip, zipname, topic,
## Rdatadir, FALSE, TRUE, FALSE, FALSE)
## if (rc == 0L)
## zfile <- file.path(Rdatadir, topic)
## }
## if (zfile != file)
## on.exit(unlink(zfile))
## switch(ext, R = , r = {
## library("utils")
## sys.source(zfile, chdir = TRUE, envir = tmp_env)
## }, RData = , rdata = , rda = load(zfile,
## envir = tmp_env), TXT = , txt = , tab = ,
## tab.gz = , tab.bz2 = , tab.xz = , txt.gz = ,
## txt.bz2 = , txt.xz = assign(name, my_read_table(zfile,
## header = TRUE, as.is = FALSE), envir = tmp_env),
## CSV = , csv = , csv.gz = , csv.bz2 = ,
## csv.xz = assign(name, my_read_table(zfile,
## header = TRUE, sep = ";", as.is = FALSE),
## envir = tmp_env), found <- FALSE)
## }
## if (found)
## break
## }
## if (verbose)
## message(if (!found)
## "*NOT* ", "found", domain = NA)
## }
## if (found)
## break
## }
## if (!found) {
## warning(gettextf("data set %s not found", sQuote(name)),
## domain = NA)
## }
## else if (!overwrite) {
## for (o in ls(envir = tmp_env, all.names = TRUE)) {
## if (exists(o, envir = envir, inherits = FALSE))
## warning(gettextf("an object named %s already exists and will not be overwritten",
## sQuote(o)))
## else assign(o, get(o, envir = tmp_env, inherits = FALSE),
## envir = envir)
## }
## rm(tmp_env)
## }
## }
## invisible(names)
## }
## <bytecode: 0x000001c2525891b8>
## <environment: namespace:utils>
datanahi2
## # A tibble: 15 × 20
## `1` `2` `3` `4` `5` `6` `7` `8` `9` `10` `11` `12` `13`
## <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 1 1 2 1 1 1 1 1 1 1 1 1 2
## 2 2 1 1 2 1 1 2 1 2 1 1 1 2
## 3 1 1 2 1 2 1 1 1 4 1 2 1 2
## 4 2 1 1 1 1 3 4 1 4 3 2 2 3
## 5 2 1 2 3 3 3 2 1 1 1 2 1 2
## 6 2 1 2 3 3 3 2 4 4 2 4 1 2
## 7 2 1 1 1 2 2 3 1 2 3 1 1 2
## 8 1 2 1 1 3 1 3 1 2 2 2 1 3
## 9 2 1 1 1 3 3 2 3 4 3 2 1 2
## 10 1 2 1 1 3 1 2 1 4 2 3 2 3
## 11 2 1 2 4 3 3 1 1 4 3 2 2 3
## 12 2 1 2 3 3 1 3 2 4 3 2 1 2
## 13 2 1 2 3 2 1 2 1 3 3 1 2 3
## 14 2 2 2 3 2 1 2 2 4 3 2 1 3
## 15 2 1 2 3 2 1 2 2 3 2 2 1 3
## # ℹ 7 more variables: `14` <dbl>, `15` <dbl>, `16` <dbl>, `17` <dbl>,
## # `18` <dbl>, `19` <dbl>, `20` <dbl>
# Establecer el modelo PCA
pca_result1 <- prcomp(datanahi2, center = TRUE, scale = TRUE, npc = 2)
# Extraer las coordenadas de los primeros dos componentes principales
cp1<- as.data.frame(pca_result1$x)
cp1
## PC1 PC2 PC3 PC4 PC5 PC6
## 1 3.27256234 2.35182902 -1.0336129 1.25812154 -0.53662063 0.46181294
## 2 2.54803498 2.27957652 -0.5100676 -1.27815163 0.13663055 -0.49081145
## 3 3.94715820 -2.08003853 0.3588871 1.14176377 2.38104473 1.21946578
## 4 -1.44062370 0.96397084 2.4986535 -3.20454941 1.72314272 -0.19624965
## 5 1.58194725 -0.23297853 -1.6209668 -0.06721062 -0.43199949 -2.99014487
## 6 -0.35514608 -3.97084399 -0.6805903 -1.21052960 -1.03816301 -0.43462472
## 7 -0.22790576 2.09435401 -0.1294989 -2.34308861 -0.42512554 0.79787191
## 8 -0.05502645 1.30022823 2.9235494 0.88969830 -1.75830577 -0.76679049
## 9 0.73090911 -3.05199589 0.3050780 -1.36038676 0.04651451 0.65510129
## 10 -0.60148320 -0.64220507 3.4256216 2.33767499 -0.08092986 -0.13896237
## 11 -2.78122558 -0.81065465 -1.2999722 0.86692207 1.03886515 -1.18285999
## 12 -1.30600161 0.05525273 -1.8217729 -0.30283840 -1.78480571 1.91538831
## 13 -2.82098352 1.63426827 -1.4152936 1.44355961 2.58107900 0.32761724
## 14 -1.29860111 -0.03656207 0.2308390 1.15280866 -1.52570239 0.81195842
## 15 -1.19361485 0.14579910 -1.2308535 0.67620608 -0.32562425 0.01122764
## PC7 PC8 PC9 PC10 PC11 PC12
## 1 -0.37682172 0.39196260 0.41390751 -1.60732952 0.6688801 -0.21644219
## 2 -0.53559676 -0.59641328 0.67330015 0.66325364 -0.4105272 1.13673817
## 3 -0.47451264 0.32571965 -0.68261471 0.79964595 -0.1219589 -0.43757316
## 4 -1.31655927 0.18753320 0.14594227 -0.35934081 -0.1255217 -0.40189582
## 5 0.51330559 0.06398006 -0.14737094 0.19434557 -0.7773154 -0.53733978
## 6 -1.11848740 -0.86458789 -0.80800539 -0.98178475 0.1585224 0.29138008
## 7 1.12652375 0.71661609 -0.61459134 0.18964451 0.4016332 -0.13264543
## 8 0.82385404 -0.56388544 -0.82091071 0.34633060 0.3465958 -0.42390732
## 9 2.22674261 -0.37338402 1.22807550 -0.04503865 0.3694343 0.07840567
## 10 0.19009475 0.70485047 0.02748707 -0.43426158 -0.5419436 0.83453712
## 11 -0.14910467 1.79418360 0.63089944 0.14013325 0.4607162 0.02445313
## 12 0.06917941 0.83938918 -0.54429538 0.04197274 -1.1721741 0.04314679
## 13 0.90337260 -1.54188849 -0.30944133 -0.51608199 -0.3568739 -0.02834604
## 14 -1.25257090 -0.80971945 1.43601358 0.62044650 -0.1486205 -0.70425823
## 15 -0.62941940 -0.27435628 -0.62839571 0.94806455 1.2491531 0.47374700
## PC13 PC14 PC15
## 1 0.1753260 -0.069734684 -2.498002e-16
## 2 -0.3647945 -0.190764647 8.326673e-17
## 3 -0.1766034 -0.016825822 0.000000e+00
## 4 0.4772541 -0.135116275 -8.326673e-17
## 5 0.3955795 0.233302568 8.326673e-17
## 6 -0.4585024 0.057426642 -1.110223e-16
## 7 -0.5034518 0.582299289 -1.387779e-16
## 8 -0.3029753 -0.492487014 1.387779e-16
## 9 0.3147252 -0.135571894 -2.220446e-16
## 10 0.1952978 0.371200159 -9.714451e-16
## 11 -0.5313068 -0.272649931 -1.110223e-16
## 12 0.3111694 -0.317149097 -2.775558e-16
## 13 -0.1061267 0.009878022 -4.440892e-16
## 14 -0.2163590 0.288240441 -1.942890e-16
## 15 0.7907680 0.087952244 -1.665335e-16
library(lattice)
## Warning: package 'lattice' was built under R version 4.2.3
xyplot(`¿Cuál es el método principal utilizado para almacenar los residuos en su farmacia?` ~ `¿Con qué frecuencia se vacÃan los contenedores de residuos en su farmacia?` | `¿Se implementan medidas de seguridad especÃficas para el almacenamiento de residuos peligrosos?`, data=datanahi)
## Warning in order(as.numeric(x)): NAs introducidos por coerción
## Warning in diff(as.numeric(x[ord])): NAs introducidos por coerción
## Warning in diff(as.numeric(y[ord])): NAs introducidos por coerción
## Warning in order(as.numeric(x)): NAs introducidos por coerción
## Warning in diff(as.numeric(x[ord])): NAs introducidos por coerción
## Warning in diff(as.numeric(y[ord])): NAs introducidos por coerción
## Warning in (function (x, y, type = "p", groups = NULL, pch = if
## (is.null(groups)) plot.symbol$pch else superpose.symbol$pch, : NAs introducidos
## por coerción
## Warning in (function (x, y, type = "p", groups = NULL, pch = if
## (is.null(groups)) plot.symbol$pch else superpose.symbol$pch, : NAs introducidos
## por coerción
## Warning in (function (x, y, type = "p", groups = NULL, pch = if
## (is.null(groups)) plot.symbol$pch else superpose.symbol$pch, : NAs introducidos
## por coerción
## Warning in (function (x, y, type = "p", groups = NULL, pch = if
## (is.null(groups)) plot.symbol$pch else superpose.symbol$pch, : NAs introducidos
## por coerción
#esplorar datos
library(DataExplorer)
## Warning: package 'DataExplorer' was built under R version 4.2.3
#create_report(datanahi1)
posibles cluster
library(dplyr)
## Warning: package 'dplyr' was built under R version 4.2.3
##
## Attaching package: 'dplyr'
## The following objects are masked from 'package:stats':
##
## filter, lag
## The following objects are masked from 'package:base':
##
## intersect, setdiff, setequal, union
library(heatmaply)
## Warning: package 'heatmaply' was built under R version 4.2.3
## Loading required package: plotly
## Warning: package 'plotly' was built under R version 4.2.3
## Loading required package: ggplot2
## Warning: package 'ggplot2' was built under R version 4.2.3
##
## Attaching package: 'plotly'
## The following object is masked from 'package:ggplot2':
##
## last_plot
## The following object is masked from 'package:stats':
##
## filter
## The following object is masked from 'package:graphics':
##
## layout
## Loading required package: viridis
## Warning: package 'viridis' was built under R version 4.2.3
## Loading required package: viridisLite
## Warning: package 'viridisLite' was built under R version 4.2.3
##
## ======================
## Welcome to heatmaply version 1.5.0
##
## Type citation('heatmaply') for how to cite the package.
## Type ?heatmaply for the main documentation.
##
## The github page is: https://github.com/talgalili/heatmaply/
## Please submit your suggestions and bug-reports at: https://github.com/talgalili/heatmaply/issues
## You may ask questions at stackoverflow, use the r and heatmaply tags:
## https://stackoverflow.com/questions/tagged/heatmaply
## ======================
heatmaply(datanahi2,
seriate = "OLO",
row_dend_left = TRUE,
plot_method = "plotly")
#distancias eulidiana
library("FactoMineR")
## Warning: package 'FactoMineR' was built under R version 4.2.3
library("factoextra")
## Warning: package 'factoextra' was built under R version 4.2.3
## Welcome! Want to learn more? See two factoextra-related books at https://goo.gl/ve3WBa
d1 <- dist(datanahi2,
method = "euclidean")
d1
## 1 2 3 4 5 6 7 8
## 2 3.000000
## 3 5.291503 5.000000
## 4 6.403124 5.099020 6.244998
## 5 4.472136 3.872983 5.656854 6.082763
## 6 7.000000 6.324555 5.916080 5.656854 5.385165
## 7 4.242641 3.605551 6.000000 3.605551 4.690416 5.916080
## 8 4.472136 4.123106 5.830952 4.582576 4.472136 5.744563 3.162278
## 9 6.164414 5.744563 4.690416 5.196152 5.291503 3.872983 4.898979 5.099020
## 10 5.385165 5.291503 4.582576 4.898979 5.385165 5.099020 4.795832 3.316625
## 11 6.324555 5.744563 6.164414 5.385165 4.690416 4.582576 5.099020 5.291503
## 12 5.477226 5.000000 6.000000 5.196152 5.291503 4.582576 4.000000 4.472136
## 13 5.656854 5.196152 6.324555 5.567764 5.477226 6.244998 4.690416 4.898979
## 14 5.099020 4.582576 5.477226 4.795832 5.099020 4.358899 4.242641 4.000000
## 15 4.582576 4.000000 5.196152 4.898979 4.123106 4.242641 3.872983 3.605551
## 9 10 11 12 13 14
## 2
## 3
## 4
## 5
## 6
## 7
## 8
## 9
## 10 4.358899
## 11 4.898979 4.582576
## 12 4.690416 4.358899 4.000000
## 13 5.830952 5.000000 4.242641 4.472136
## 14 4.472136 3.605551 3.464102 2.449490 4.000000
## 15 4.582576 3.741657 3.316625 3.000000 3.605551 2.236068
fviz_dist(d1, show_labels = TRUE) +
labs(title = "Matriz de distancias (estandarizadas)")
single_clust1 <- hclust(d1, method = "single")
# Dendograma
# Clustering (complete
complete_clust <- hclust(d1, method = "complete")
# k = 3
fviz_dend(complete_clust, k = 4,
cex = 0.5,
k_colors =
c("#2E9FDF", "#00AFBB", "#E7B800"),
# Diferentes colores a los clusters
color_labels_by_k = TRUE,
#añade un rectángulo alrededor
rect = TRUE) +
labs(title = "Dendograma (complete)")
## Warning in get_col(col, k): Length of color vector was shorter than the number
## of clusters - color vector was recycled
## Warning: The `<scale>` argument of `guides()` cannot be `FALSE`. Use "none" instead as
## of ggplot2 3.3.4.
## ℹ The deprecated feature was likely used in the factoextra package.
## Please report the issue at <https://github.com/kassambara/factoextra/issues>.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.
dendograma centroide
# Clustering (centroid)
centroid_clust <-
hclust(d1, method = "centroid")
# k = 3
fviz_dend(centroid_clust, k = 3,
cex = 0.5,
k_colors =
c("#2E9FDF", "#00AFBB", "#E7B800"),
# Diferentes colores a los clusters
color_labels_by_k = TRUE,
#añade un rectángulo alrededor
rect = TRUE) +
labs(title = "Dendograma (centroid)")
## Warning in get_col(col, k): Length of color vector was shorter than the number
## of clusters - color vector was recycled
## Warning in data.frame(xmin = unlist(xleft), ymin = unlist(ybottom), xmax =
## unlist(xright), : row names were found from a short variable and have been
## discarded
ward_clust <-
hclust(d1, method = "ward.D2")
# k = 3
fviz_dend(ward_clust, k = 3,
cex = 0.5,
k_colors =
c("#2E9FDF", "#00AFBB", "#E7B800"),
# Diferentes colores a los clusters
color_labels_by_k = TRUE,
#añade un rectángulo alrededor
rect = TRUE) +
labs(title = "Dendograma (Ward)")
library(cluster)
library(factoextra)
res.dist <- get_dist(d1, stand = TRUE, method = "pearson")
fviz_dist(res.dist,
gradient = list(low = "#00AFBB", mid = "white", high = "#FC4E07"))
km.res <- kmeans(d1, 3, nstart = 25)
fviz_cluster(km.res, data = datanahi2, frame.type = "convex")
## Warning: argument frame is deprecated; please use ellipse instead.
## Warning: argument frame.type is deprecated; please use ellipse.type instead.
d1
## 1 2 3 4 5 6 7 8
## 2 3.000000
## 3 5.291503 5.000000
## 4 6.403124 5.099020 6.244998
## 5 4.472136 3.872983 5.656854 6.082763
## 6 7.000000 6.324555 5.916080 5.656854 5.385165
## 7 4.242641 3.605551 6.000000 3.605551 4.690416 5.916080
## 8 4.472136 4.123106 5.830952 4.582576 4.472136 5.744563 3.162278
## 9 6.164414 5.744563 4.690416 5.196152 5.291503 3.872983 4.898979 5.099020
## 10 5.385165 5.291503 4.582576 4.898979 5.385165 5.099020 4.795832 3.316625
## 11 6.324555 5.744563 6.164414 5.385165 4.690416 4.582576 5.099020 5.291503
## 12 5.477226 5.000000 6.000000 5.196152 5.291503 4.582576 4.000000 4.472136
## 13 5.656854 5.196152 6.324555 5.567764 5.477226 6.244998 4.690416 4.898979
## 14 5.099020 4.582576 5.477226 4.795832 5.099020 4.358899 4.242641 4.000000
## 15 4.582576 4.000000 5.196152 4.898979 4.123106 4.242641 3.872983 3.605551
## 9 10 11 12 13 14
## 2
## 3
## 4
## 5
## 6
## 7
## 8
## 9
## 10 4.358899
## 11 4.898979 4.582576
## 12 4.690416 4.358899 4.000000
## 13 5.830952 5.000000 4.242641 4.472136
## 14 4.472136 3.605551 3.464102 2.449490 4.000000
## 15 4.582576 3.741657 3.316625 3.000000 3.605551 2.236068
