Hola, Manuel:

Si descomprimes el tar.gz indicado por Marcuzzi, y accedes a la subcarpeta R, en el archivo legends.R buscas la cadena p-value, y en el archivo strucplot.R es donde creo que modificas el "Pearson residuals" (busca por "Pearson\nresiduals").

Saludos.
Eva




________________________________
 De: Manuel Spínola <mspinola10@gmail.com>
Para: "Marcuzzi, Javier Rubén" <javier.ruben.marcuzzi@gmail.com> 
CC: R <r-help-es@r-project.org> 
Enviado: Viernes 5 de julio de 2013 0:45
Asunto: Re: [R-es] ﻿Modificar una función de un paquete


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]]

_______________________________________________
R-help-es mailing list
R-help-es@r-project.org
https://stat.ethz.ch/mailman/listinfo/r-help-es
	[[alternative HTML version deleted]]

