Muchas gracias Javier,
Lo que yo quiero es cambiar el título de la leyenda que dice "Pearson
residuals" a español "Residuales de Pearson", pero no me doy
cuenta como.
También en lugar de "p-value", que diga "Valor de P". Es
posible?
Manuel
2013/7/4 Marcuzzi, Javier Rubén <javier.ruben.marcuzzi@gmail.com>
> Estimado Manuel Spíndola
>
> Del repositorio r descargo el paquete, me refiero a:
> Package source: vcd_1.2-13.tar.gz
>
> Descomprimo y busco el archivo que creo conveniente, en este caso copio y
> pego el código de mosaicplot
>
> A partir de ahí el trabajo es interpretar el código, copiar la parte útil,
> modificar lo conveniente, en fin, lleva tiempo pero se aprende mucho de esa
> forma, yo lo realice con otra librería y luego de mucho trabajo obtuve lo
> que adecuado a mis necesidades, pero no lo pase a un paquete, lo guarde en
> archivos R que llamo desde el archivo donde coloco los datos, los acomodo,
> etc.
>
> Javier Marcuzzi
>
>
> ##############################**#############################
> ## mosaicplot
>
> mosaic <- function(x, ...)
> UseMethod("mosaic")
>
> mosaic.formula <-
> function(formula, data = NULL, highlighting = NULL,
> ..., main = NULL, sub = NULL, subset = NULL, na.action = NULL)
> {
> if (is.logical(main) && main)
> main <- deparse(substitute(data))
> else if (is.logical(sub) && sub)
> sub <- deparse(substitute(data))
>
> m <- match.call(expand.dots = FALSE)
> edata <- eval(m$data, parent.frame())
>
> fstr <- strsplit(paste(deparse(**formula), collapse = ""),
"~")
> vars <- strsplit(strsplit(gsub(" ", "",
fstr[[1]][2]), "\\|")[[1]], "\\+")
> varnames <- vars[[1]]
>
> condnames <- if (length(vars) > 1) vars[[2]] else NULL
>
> dep <- gsub(" ", "", fstr[[1]][1])
> if (is.null(highlighting) && (!dep %in%
c("","Freq"))) {
> if (all(varnames == ".")) {
> varnames <- if (is.data.frame(data))
> colnames(data)
> else
> names(dimnames(as.table(data))**)
> varnames <- varnames[-which(varnames %in% dep)]
> }
>
> varnames <- c(varnames, dep)
> highlighting <- length(varnames) + length(condnames)
> }
>
>
> if (inherits(edata, "ftable") || inherits(edata,
"table") ||
> length(dim(edata)) > 2) {
> condind <- NULL
> dat <- as.table(data)
> if(all(varnames != ".")) {
> ind <- match(varnames, names(dimnames(dat)))
> if (any(is.na(ind)))
> stop(paste("Can't find", paste(varnames[is.na(ind)],
collapse=" /
> "), "in", deparse(substitute(data))))
>
> if (!is.null(condnames)) {
> condind <- match(condnames, names(dimnames(dat)))
> if (any(is.na(condind)))
> stop(paste("Can't find",
paste(condnames[is.na(condind)**],
> collapse=" / "), "in", deparse(substitute(data))))
> ind <- c(condind, ind)
> }
> dat <- margin.table(dat, ind)
> }
> mosaic.default(dat, main = main, sub = sub, highlighting = highlighting,
> condvars = if (is.null(condind)) NULL else
> match(condnames, names(dimnames(dat))), ...)
> } else {
> m <- m[c(1, match(c("formula", "data",
"subset", "na.action"),
> names(m), 0))]
> m[[1]] <- as.name("xtabs")
> m$formula <-
> formula(paste(if("Freq" %in% colnames(data))
"Freq",
> "~",
> paste(c(condnames, varnames), collapse =
"+")))
> tab <- eval(m, parent.frame())
> mosaic.default(tab, main = main, sub = sub, highlighting >
highlighting, ...)
> }
> }
>
> mosaic.default <- function(x, condvars = NULL,
> split_vertical = NULL, direction = NULL,
> spacing = NULL, spacing_args = list(),
> gp = NULL, expected = NULL, shade = NULL,
> highlighting = NULL,
> highlighting_fill = grey.colors,
> highlighting_direction = NULL,
> zero_size = 0.5,
> zero_split = FALSE,
> zero_shade = NULL,
> zero_gp = gpar(col = 0),
> panel = NULL,
> main = NULL, sub = NULL, ...) {
> zero_shade <- !is.null(shade) && shade || !is.null(expected) ||
> !is.null(gp)
> if (!is.null(shade) && !shade) zero_shade = FALSE
>
> if (is.logical(main) && main)
> main <- deparse(substitute(x))
> else if (is.logical(sub) && sub)
> sub <- deparse(substitute(x))
>
> if (is.structable(x)) {
> if (is.null(direction) && is.null(split_vertical))
> split_vertical <- attr(x, "split_vertical")
> x <- as.table(x)
> }
> if (is.null(split_vertical))
> split_vertical <- FALSE
>
> dl <- length(dim(x))
>
> ## splitting argument
> if (!is.null(direction))
> split_vertical <- direction == "v"
> if (length(split_vertical) == 1)
> split_vertical <- rep(c(split_vertical, !split_vertical), length.out
> dl)
> if (length(split_vertical) < dl)
> split_vertical <- rep(split_vertical, length.out = dl)
>
> ## highlighting
> if (!is.null(highlighting)) {
> if (is.character(highlighting))
> highlighting <- match(highlighting, names(dimnames(x)))
> if (length(highlighting) > 0) {
> if (is.character(condvars))
> condvars <- match(condvars, names(dimnames(x)))
> x <- if (length(condvars) > 0)
> aperm(x, c(condvars, seq(dl)[-c(condvars,**highlighting)],
> highlighting))
> else
> aperm(x, c(seq(dl)[-highlighting], highlighting))
> if (is.null(spacing))
> spacing <- spacing_highlighting
> if (is.function(highlighting_**fill))
> highlighting_fill <- rev(highlighting_fill(dim(x)[**dl]))
> if (is.null(gp))
> gp <- gpar(fill = highlighting_fill)
> if (!is.null(highlighting_**direction)) {
> split_vertical[dl] <- highlighting_direction %in%
c("left", "right")
> if (highlighting_direction %in% c("left",
"top")) {
> ## ugly:
> tmp <- as.data.frame.table(x)
> tmp[,dl] <- factor(tmp[,dl], rev(levels(tmp[,dl])))
> x <- xtabs(Freq ~ ., data = tmp)
> gp <- gpar(fill = rev(highlighting_fill))
> }
> }
> }
> }
>
> ## Conditioning only
> if (!is.null(condvars)) {
> if (is.character(condvars))
> condvars <- match(condvars, names(dimnames(x)))
> if (length(condvars) > 0)
> x <- aperm(x, c(condvars, seq(dl)[-condvars]))
>
> if (is.null(spacing))
> spacing <- spacing_conditional
> }
>
> ## spacing argument
> if (is.null(spacing))
> spacing <- if (dl < 3) spacing_equal else spacing_increase
>
> strucplot(x,
> condvars = if (is.null(condvars)) NULL else length(condvars),
> core = struc_mosaic(zero_size = zero_size, zero_split >
zero_split,
> zero_shade = zero_shade, zero_gp = zero_gp, panel = panel),
> split_vertical = split_vertical,
> spacing = spacing,
> spacing_args = spacing_args,
> gp = gp,
> expected = expected,
> shade = shade,
> main = main,
> sub = sub,
> ...)
> }
>
> ## old code: more elegant, but less performant
> ##
> ## struc_mosaic2 <- function(zero_size = 0.5, zero_split = FALSE,
> ## zero_shade = TRUE, zero_gp = gpar(col = 0))
> ## function(residuals, observed, expected = NULL, spacing, gp,
> split_vertical, prefix = "") {
> ## dn <- dimnames(observed)
> ## dnn <- names(dn)
> ## dx <- dim(observed)
> ## dl <- length(dx)
>
> ## ## split workhorse
> ## zerostack <- character(0)
> ## split <- function(x, i, name, row, col, zero) {
> ## cotab <- co_table(x, 1)
> ## margin <- sapply(cotab, sum)
> ## v <- split_vertical[i]
> ## d <- dx[i]
>
> ## ## compute total cols/rows and build split layout
> ## dist <- unit.c(unit(margin, "null"), spacing[[i]])
> ## idx <- matrix(1:(2 * d), nrow = 2, byrow = TRUE)[-2 * d]
> ## layout <- if (v)
> ## grid.layout(ncol = 2 * d - 1, widths = dist[idx])
> ## else
> ## grid.layout(nrow = 2 * d - 1, heights = dist[idx])
> ## vproot <- viewport(layout.pos.col = col, layout.pos.row = row,
> ## layout = layout, name >
remove_trailing_comma(name))
>
> ## ## next level: either create further splits, or final viewports
> ## name <- paste(name, dnn[i], "=", dn[[i]],
",", sep = "")
> ## row <- col <- rep.int(1, d)
> ## if (v) col <- 2 * 1:d - 1 else row <- 2 * 1:d - 1
> ## f <- if (i < dl)
> ## function(m) {
> ## co <- cotab[[m]]
> ## z <- mean(co) <= .Machine$double.eps
> ## if (z && !zero && !zero_split) zerostack
<<- c(zerostack,
> name[m])
> ## split(co, i + 1, name[m], row[m], col[m], z &&
!zero_split)
> ## }
> ## else
> ## function(m) {
> ## if (cotab[[m]] <= .Machine$double.eps && !zero)
> ## zerostack <<- c(zerostack, name[m])
> ## viewport(layout.pos.col = col[m], layout.pos.row = row[m],
> ## name = remove_trailing_comma(name[m])**)
> ## }
> ## vpleaves <- structure(lapply(1:d, f), class =
c("vpList",
> "viewport"))
>
> ## vpTree(vproot, vpleaves)
> ## }
>
> ## ## start spltting on top, creates viewport-tree
> ## pushViewport(split(observed + .Machine$double.eps,
> ## i = 1, name = paste(prefix, "cell:",
sep = ""),
> ## row = 1, col = 1, zero = FALSE))
>
> ## ## draw rectangles
> ## mnames <- apply(expand.grid(dn), 1,
> ## function(i) paste(dnn, i, collapse=",",
sep = "=")
> ## )
> ## zeros <- observed <= .Machine$double.eps
>
> ## ## draw zero cell lines
> ## for (i in remove_trailing_comma(**zerostack)) {
> ## seekViewport(i)
> ## grid.lines(x = 0.5)
> ## grid.lines(y = 0.5)
> ## if (!zero_shade && zero_size > 0) {
> ## grid.points(0.5, 0.5, pch = 19, size = unit(zero_size,
"char"),
> ## gp = zero_gp,
> ## name = paste(prefix, "disc:", mnames[i],
sep = ""))
> ## grid.points(0.5, 0.5, pch = 1, size = unit(zero_size,
"char"),
> ## name = paste(prefix, "circle:", mnames[i],
sep > ""))
> ## }
> ## }
>
> ## # draw boxes
> ## for (i in seq_along(mnames)) {
> ## seekViewport(paste(prefix, "cell:", mnames[i], sep =
""))
> ## gpobj <- structure(lapply(gp, function(x) x[i]), class =
"gpar")
> ## if (!zeros[i]) {
> ## grid.rect(gp = gpobj, name = paste(prefix, "rect:",
mnames[i],
> sep = ""))
> ## } else {
> ## if (zero_shade && zero_size > 0) {
> ## grid.points(0.5, 0.5, pch = 19, size = unit(zero_size,
> "char"),
> ## gp = gpar(col = gp$fill[i]),
> ## name = paste(prefix, "disc:", mnames[i],
sep > ""))
> ## grid.points(0.5, 0.5, pch = 1, size = unit(zero_size,
"char"),
> ## name = paste(prefix, "circle:",
mnames[i], sep > ""))
> ## }
> ## }
> ## }
> ## }
> ## class(struc_mosaic2) <- "grapcon_generator"
>
> struc_mosaic <- function(zero_size = 0.5, zero_split = FALSE,
> zero_shade = TRUE, zero_gp = gpar(col = 0),
> panel = NULL)
> function(residuals, observed, expected = NULL,
> spacing, gp, split_vertical, prefix = "") {
> dn <- dimnames(observed)
> dnn <- names(dn)
> dx <- dim(observed)
> dl <- length(dx)
>
> zeros <- function(gp, name) {
> grid.lines(x = 0.5)
> grid.lines(y = 0.5)
> if (zero_size > 0) {
> grid.points(0.5, 0.5, pch = 19, size = unit(zero_size,
"char"),
> gp = gp, name = paste(prefix, "disc:", name,
sep = ""))
> grid.points(0.5, 0.5, pch = 1, size = unit(zero_size,
"char"),
> name = paste(prefix, "circle:", name, sep =
""))
> }
> }
>
> ## split workhorse
> zerostack <- character(0)
> split <- function(x, i, name, row, col, zero, index) {
> cotab <- co_table(x, 1)
> margin <- sapply(cotab, sum)
> margin[margin == 0] <- .Machine$double.eps
> # margin <- margin + .Machine$double.eps
> v <- split_vertical[i]
> d <- dx[i]
>
> ## compute total cols/rows and build split layout
> dist <- if (d > 1)
> unit.c(unit(margin, "null"), spacing[[i]])
> else
> unit(margin, "null")
> idx <- matrix(1:(2 * d), nrow = 2, byrow = TRUE)[-2 * d]
> layout <- if (v)
> grid.layout(ncol = 2 * d - 1, widths = dist[idx])
> else
> grid.layout(nrow = 2 * d - 1, heights = dist[idx])
> pushViewport(viewport(layout.**pos.col = col, layout.pos.row = row,
> layout = layout, name = paste(prefix,
"cell:",
> remove_trailing_comma(name),
> sep = "")))
>
> ## next level: either create further splits, or final viewports
> row <- col <- rep.int(1, d)
> if (v) col <- 2 * 1:d - 1 else row <- 2 * 1:d - 1
> for (m in 1:d) {
> nametmp <- paste(name, dnn[i], "=", dn[[i]][m],
",", sep = "")
> if (i < dl) {
> co <- cotab[[m]]
>
> ## zeros
> z <- mean(co) <= .Machine$double.eps
> split(co, i + 1, nametmp, row[m], col[m],
> z && !zero_split, cbind(index, m))
> if (z && !zero && !zero_split &&
!zero_shade && (zero_size > 0))
> zeros(zero_gp, nametmp)
> } else {
> pushViewport(viewport(layout.**pos.col = col[m],
> layout.pos.row = row[m],
> name = paste(prefix, "cell:",
> remove_trailing_comma(nametmp)**, sep >
"")))
>
> ## zeros
> if (cotab[[m]] <= .Machine$double.eps && !zero) {
> zeros(if (!zero_shade) zero_gp else gpar(col >
gp$fill[cbind(index,m)]), nametmp)
> } else {
> ## rectangles
> gpobj <- structure(lapply(gp, function(x) x[cbind(index,
m)]),
> class = "gpar")
> nam <- paste(prefix, "rect:",
> remove_trailing_comma(nametmp)**, sep =
"")
> if (!is.null(panel))
> panel(residuals, observed, expected, c(cbind(index, m)),
> gpobj, nam)
> else
> grid.rect(gp = gpobj, name = nam)
> }
> }
> upViewport(1)
> }
> }
>
> ## start splitting on top, creates viewport-tree
> split(observed, i = 1, name = "", row = 1, col = 1,
> zero = FALSE, index = cbind())
> }
> class(struc_mosaic) <- "grapcon_generator"
>
> -----Original Message----- From: Manuel Spínola
> Sent: Thursday, July 04, 2013 7:01 PM
> To: R
> Subject: [R-es] Modificar una función de un paquete
>
>
> Estimados miembros de la lista.
>
> Estoy trabajando con la función mosaic del paquete vcd. Cómo puedo hacer
> para ver el contenido fe la función y modificar algunos de sus argumentos?
>
> Muchas gracias,
>
> Manuel
>
> --
> *Manuel Spínola, Ph.D.*
>
> Instituto Internacional en Conservación y Manejo de Vida Silvestre
> Universidad Nacional
> Apartado 1350-3000
> Heredia
> COSTA RICA
> mspinola@una.ac.cr
> mspinola10@gmail.com
> Teléfono: (506) 2277-3598
> Fax: (506) 2237-7036
> Personal website: Lobito de río <https://sites.google.com/**
> site/lobitoderio/ <https://sites.google.com/site/lobitoderio/>>
> Institutional website: ICOMVIS <http://www.icomvis.una.ac.cr/**>
>
> [[alternative HTML version deleted]]
>
>
>
>
>
>
>
> ______________________________**_________________
> R-help-es mailing list
> R-help-es@r-project.org
>
https://stat.ethz.ch/mailman/**listinfo/r-help-es<https://stat.ethz.ch/mailman/listinfo/r-help-es>
>
--
*Manuel Spínola, Ph.D.*
Instituto Internacional en Conservación y Manejo de Vida Silvestre
Universidad Nacional
Apartado 1350-3000
Heredia
COSTA RICA
mspinola@una.ac.cr
mspinola10@gmail.com
Teléfono: (506) 2277-3598
Fax: (506) 2237-7036
Personal website: Lobito de río
<https://sites.google.com/site/lobitoderio/>
Institutional website: ICOMVIS <http://www.icomvis.una.ac.cr/>
[[alternative HTML version deleted]]