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