thr3ads.net - R help es - [R-es] Modificar una función de un paquete [Jul 2013]

If this information is useful, please help other people find it:
Share via:

Manuel Spínola

2013-Jul-04 22:01 UTC

[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/>
Institutional website: ICOMVIS <http://www.icomvis.una.ac.cr/>

	[[alternative HTML version deleted]]

Marcuzzi, Javier Rubén

2013-Jul-04 22:32 UTC

head link

[R-es] Modificar una función de un paquete

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 en una.ac.cr
mspinola10 en 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 en r-project.org
https://stat.ethz.ch/mailman/listinfo/r-help-es

Manuel Spínola

2013-Jul-04 22:45 UTC

head link

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

Reasonably Related Threads

Search for more maybe matching threads

R help es - Jul 2013 - Modificar una función de un paquete

[R-es] Modificar una función de un paquete

[R-es] Modificar una función de un paquete

[R-es] Modificar una función de un paquete

Reasonably Related Threads