R/ADEg.S2.R

setClass(
    Class = "ADEg.S2",
    contains = c("ADEg", "VIRTUAL"),
    slots = c(data = "list")
    )


setMethod(
    f = "initialize",
    signature = "ADEg.S2",
    definition = function(.Object, data = list(dfxy = NULL, xax = 1, yax = 2, frame = 0, storeData = TRUE), ...) {
        .Object <- callNextMethod(.Object, ...) ## ADEg initialize
        .Object@data <- data
        return(.Object)
    })


setMethod(
    f = "prepare",
    signature = "ADEg.S2",
    definition = function(object) {
        ## TODO: factorise les if
        name_obj <- deparse(substitute(object))
        if(object@data$storeData)
            dfxy <- object@data$dfxy
        else
            dfxy <- eval(object@data$dfxy, envir = sys.frame(object@data$frame))
        
        ## axes limits
        if(class(object) == "S2.corcircle") {
            object@trellis.par$panel.background$col <- "transparent"
            if(object@g.args$fullcircle) {
                if(is.null(object@g.args$xlim) || !identical(object@s.misc$xfullcircle.update, object@g.args$fullcircle)) {
                    minX <- -1
                    maxX <- 1
                } else {
                    minX <- object@g.args$xlim[1]
                    maxX <- object@g.args$xlim[2]
                }
                if(is.null(object@g.args$ylim) || !identical(object@s.misc$yfullcircle.update, object@g.args$fullcircle)) {
                    minY <- -1
                    maxY <- 1
                } else {
                    minY <- object@g.args$ylim[1]
                    maxY <- object@g.args$ylim[2]
                }
            } else {
                if(is.null(object@g.args$xlim) || !identical(object@s.misc$xfullcircle.update, object@g.args$fullcircle)) {
                    minX <- min(dfxy[, object@data$xax])
                    maxX <- max(dfxy[, object@data$xax])
                } else {
                    minX <- object@g.args$xlim[1]
                    maxX <- object@g.args$xlim[2]
                }
                if(is.null(object@g.args$ylim) || !identical(object@s.misc$yfullcircle.update, object@g.args$fullcircle)) {
                    minY <- min(dfxy[, object@data$yax])
                    maxY <- max(dfxy[, object@data$yax])
                } else {
                    minY <- object@g.args$ylim[1]
                    maxY <- object@g.args$ylim[2]
                }
            }
        } else {
            if(is.null(object@g.args$xlim)) {
                minX <- min(dfxy[, object@data$xax])
                maxX <- max(dfxy[, object@data$xax])
            } else {
                minX <- object@g.args$xlim[1]
                maxX <- object@g.args$xlim[2]
            }
            if(is.null(object@g.args$ylim)) {
                minY <- min(dfxy[, object@data$yax])
                maxY <- max(dfxy[, object@data$yax])
            } else {
                minY <- object@g.args$ylim[1]
                maxY <- object@g.args$ylim[2]
            }
        }
        
        limits <- setlimits2D(minX = minX, maxX = maxX, minY = minY, maxY = maxY, origin = rep(object@adeg.par$porigin$origin, le = 2),
                             aspect.ratio = object@adeg.par$paxes$aspectratio, includeOr = object@adeg.par$porigin$include)
        
        if(is.null(object@g.args$xlim) || !identical(object@s.misc$xfullcircle.update, object@g.args$fullcircle))
            object@g.args$xlim <- limits$xlim
        if(is.null(object@g.args$ylim) || !identical(object@s.misc$yfullcircle.update, object@g.args$fullcircle))
            object@g.args$ylim <- limits$ylim
        
        if(class(object) == "S2.corcircle") {
            object@s.misc$xfullcircle.update <- object@g.args$fullcircle
            object@s.misc$yfullcircle.update <- object@g.args$fullcircle
        }
        
        ## grid locations and axes 
        if(object@adeg.par$pgrid$draw || object@adeg.par$paxes$draw) {
            ## axes division
            if(class(object) != "S2.corcircle") {
                if(object@adeg.par$porigin$include)
                    object@s.misc$backgrid <- .getgrid(xlim = object@g.args$xlim, ylim = object@g.args$ylim, object@adeg.par$pgrid$nint, rep(object@adeg.par$porigin$origin, le = 2), asp = object@adeg.par$paxes$aspectratio)
                else
                    object@s.misc$backgrid <- .getgrid(xlim = object@g.args$xlim, ylim = object@g.args$ylim, object@adeg.par$pgrid$nint, asp = object@adeg.par$paxes$aspectratio)
            }
            
            if(object@adeg.par$paxes$draw) {
                ## parameters to plot axes
                scalesandlab <- list(x = object@adeg.par$paxes$x, y = object@adeg.par$paxes$y)
                if(is.null(scalesandlab$y$at)) {
                    scalesandlab$y$at <- object@s.misc$backgrid[[3L]][!is.na(object@s.misc$backgrid[[3L]])]
                    if(class(object) == "S2.corcircle")
                        scalesandlab$y$at <- scalesandlab$y$at[(length(scalesandlab$y$at) / 2 + 1):length(scalesandlab$y$at)]
                }
                if(is.null(scalesandlab$x$at)) {
                    scalesandlab$x$at <- object@s.misc$backgrid[[1L]][!is.na(object@s.misc$backgrid[[1L]])]
                    if(class(object) == "S2.corcircle")
                        scalesandlab$x$at <- scalesandlab$x$at[1:(length(scalesandlab$x$at) / 2)]
                }
            } else 
                scalesandlab <- list(draw = FALSE) ## no axes
        }
        else
            scalesandlab <- list(draw = FALSE) ## no axes
        
        if(object@adeg.par$paxes$aspectratio != "iso")
            object@adeg.par$pgrid$text$cex <- 0 ## grid cell size has no meaning
        
        ## if grid and axes are drawn, no text indication
        if(object@adeg.par$pgrid$draw && object@adeg.par$paxes$draw)
            object@adeg.par$pgrid$text$cex <- 0
        object@g.args$scales <- scalesandlab
        assign(name_obj, object, envir = parent.frame())
    })


setMethod(
    f = "panelbase",
    signature = "ADEg.S2",
    definition = function(object, x, y) {
        ## draw grid
        lims <- current.panel.limits(unit = "native")
        porigin <- object@adeg.par$porigin
        porigin$origin <- rep(porigin$origin, length.out = 2)

        if(class(object) == "S2.corcircle") 
            grid.circle(x = 0, y = 0, r = 1, default.units = "native", gp = gpar(col = "black", fill = object@adeg.par$pbackground$col), draw = TRUE, name = "circleGrid")
        
        if(object@adeg.par$pgrid$draw) { ## if grid to draw
            grid <- object@adeg.par$pgrid
            locations <- object@s.misc$backgrid ## coordinates for the grid 
            panel.segments(
                x0 = c(locations$x0[!is.na(locations$x0)], rep(lims$xlim[1], sum(is.na(locations$x0)))),
                x1 = c(locations$x1[!is.na(locations$x1)], rep(lims$xlim[2], sum(is.na(locations$x1)))),
                y0 = c(rep(lims$ylim[1], sum(is.na(locations$y0))), locations$y0[!is.na(locations$y0)]),
                y1 = c(rep(lims$ylim[2], sum(is.na(locations$y1))), locations$y1[!is.na(locations$y1)]),
                col = grid$col, lty = grid$lty, lwd = grid$lwd)
            
            if(grid$text$cex > 0) {
                text.pos <- .setposition(grid$text$pos)
                textgrid <- textGrob(label = paste("d =", locations$d), x = text.pos$posi[1], y = text.pos$posi[2], just = text.pos$just, gp = gpar(cex = grid$text$cex, col = grid$text$col), name = "gridtext")
                grid.rect(x = text.pos$posi[1], y = text.pos$posi[2], width = grobWidth(textgrid), height = grobHeight(textgrid),
                          just = text.pos$just, gp = gpar(fill = ifelse(class(object) == "S2.corcircle", "transparent", object@adeg.par$pbackground$col), alpha = 1, col = "transparent"))
                grid.draw(textgrid)
            }
        }
        
        if(porigin$draw && porigin$include & class(object) == "S2.corcircle") {
            panel.segments(x0 = c(-1, porigin$origin[1]), x1 = c(1, porigin$origin[1]), y0 = c(porigin$origin[2], -1), y1 = c(porigin$origin[2], 1), col = porigin$col, lwd = porigin$lwd, lty = porigin$lty, alpha = porigin$alpha)
            ## TODO: check last parameters valididy     
        }
        
        if(porigin$draw && porigin$include & !class(object) == "S2.corcircle") {
            panel.abline(h = porigin$origin[2], v = porigin$origin[1], col = porigin$col, lwd = porigin$lwd, lty = porigin$lty, alpha = porigin$alpha)
            ## TODO: check last parameters valididy
        }
        
        ## spatial object management
        if(any(names(object@g.args) == "Sp")) {
            do.call("adeg.panel.Spatial", args = c(list(SpObject = object@g.args$Sp, sp.layout = object@g.args$sp.layout), object@adeg.par$pSp))
        }
        else  ## no Sp but sp.layout
            if(any(names(object@g.args) == "sp.layout"))
              sppanel(lst = object@g.args$sp.layout)
        
        ## neighbouring object management
        if(any(names(object@g.args) == "nbobject")) {
            nbobj <- object@g.args$nbobject
            if(class(nbobj) != "nb")
                stop("wrong class for the nb object")
            pnb <- object@adeg.par$pnb
            do.call("adeg.panel.nb", args = list(nbobject = nbobj, coords = cbind(x, y), col.edge = pnb$edge$col, lwd = pnb$edge$lwd, lty = pnb$edge$lty, pch = pnb$node$pch, cex = pnb$node$cex, col.node = pnb$node$col, alpha = pnb$node$alpha))
        }
        callNextMethod()
    })


setMethod(
    f = "setlatticecall",
    signature = "ADEg.S2",
    definition =  function(object) {
        ## arguments recurrents de la liste, pas les limites car elles seront definis ensuite
        name_obj <- deparse(substitute(object))

        ## background and box
        if(!inherits(object, "S2.corcircle"))
            object@trellis.par$panel.background$col <- object@adeg.par$pbackground$col
        if(!object@adeg.par$pbackground$box)
            object@trellis.par$axis.line$col <- "transparent"
        
        arguments <- list(
            par.settings = object@trellis.par,
            scales = object@g.args$scales,
            aspect = object@adeg.par$paxes$aspectratio,
            key = createkey(object),
            legend = createcolorkey(object),
            axis = axis.L, ## see utils.R
            panel = function(...) {
                panelbase(object,...) ## grid,
                panel(object,...) ## call to S2.panel function, for slabel and ADEg.S2 class of graphs
            })

        object@lattice.call$arguments <- arguments          
        object@lattice.call$graphictype <- "xyplot"

        ## get lattice arguments (set unspecified to NULL)
        argnames <- c("main", "sub", "xlab", "ylab")
        largs <- object@g.args[argnames]
        names(largs) <- argnames
        ## add xlim and ylim if not NULL
        if("xlim" %in% names(object@g.args))
            largs["xlim"] <- object@g.args["xlim"]
        if("ylim" %in% names(object@g.args))
            largs["ylim"] <- object@g.args["ylim"]
        
        object@lattice.call$arguments <- c(object@lattice.call$arguments, largs, list(strip = FALSE))
        assign(name_obj, object, envir = parent.frame())
    })


## zoom without center
setMethod(
    f = "zoom",
    signature = c("ADEg.S2", "numeric", "missing"),
    definition  =  function(object, zoom, center) {
        oldxlim <- object@g.args$xlim
        oldylim <- object@g.args$ylim
        if(length(zoom) != 1)
            stop("zoom factor should be length 1")
        diffx <- diff(oldxlim)
        diffy <- diff(oldylim)
        center <- c(oldxlim[1] + diffx / 2, oldylim[1] + diffy / 2)
        diffx <- diffx / zoom
        diffy <- diffy / zoom
        object@g.args$xlim <- c(center[1] - diffx / 2, center[1] + diffx / 2)
        object@g.args$ylim <- c(center[2] - diffy / 2, center[2] + diffy / 2)
        if(object@adeg.par$pgrid$draw || object@adeg.par$paxes$draw)
            object@s.misc$backgrid <- .getgrid(xlim = object@g.args$xlim, ylim = object@g.args$ylim, object@adeg.par$pgrid$nint, object@adeg.par$porigin$origin, asp = object@adeg.par$paxes$aspectratio)
        prepare(object)
        setlatticecall(object)
        print(object)
        invisible()
    })


## zoom with center
setMethod(
    f = "zoom",
    signature = c("ADEg.S2", "numeric", "numeric"),
    definition = function(object, zoom, center) {
        if(length(center) != 2) 
            stop("error, center should be length 2")
        if(length(zoom) != 1) 
            stop("zoom factor should be length 1")
        diffx <- diff(object@g.args$xlim) / zoom
        diffy <- diff(object@g.args$ylim) / zoom
        object@g.args$xlim <- c(center[1] - diffx / 2, center[1] + diffx / 2)
        object@g.args$ylim <- c(center[2] - diffy / 2, center[2] + diffy / 2)
        if(object@adeg.par$pgrid$draw || object@adeg.par$paxes$draw)
            object@s.misc$backgrid <- .getgrid(xlim = object@g.args$xlim, ylim = object@g.args$ylim, object@adeg.par$pgrid$nint, object@adeg.par$porigin$origin, asp = object@adeg.par$paxes$aspectratio)
        prepare(object)
        setlatticecall(object)
        print(object)
        invisible()
    })


setMethod(
    f = "addhist",
    signature = "ADEg.S2",
    definition = function(object, bandwidth, gridsize = 60, kernel = "normal", cbreaks = 2, storeData = TRUE, plot = TRUE, pos = -1, ...) {
        if(!(inherits(object, "ADEg.S2")))
            stop("Only implemented for 'ADEg.S2' object")
        
        if(storeData) {
            dfxy <- object@data$dfxy
            xax <- object@data$xax
            yax <- object@data$yax
        } else {
            dfxy <- eval(object@data$dfxy, envir = sys.frame(object@data$frame))
            xax <- eval(object@data$xax, envir = sys.frame(object@data$frame))
            yax <- eval(object@data$yax, envir = sys.frame(object@data$frame))
        }
        
        graphsnames <- c("object", "densX", "densY", "link") 
        ## sorting parameters
        sortparameters <- sortparamADEgS(..., graphsnames = graphsnames)
        update(object, sortparameters[[1]], plot = FALSE)
        ## setting positions
        positions <- layout2position(matrix(c(2, 4, 1, 3), 2, 2, byrow = TRUE), c(3, 1) / 2, c(3, 1) / 2, FALSE)

        ## grid computation
        xlimX <- object@g.args$xlim
        ylimY <- object@g.args$ylim
        breaks <- object@s.misc$backgrid
        cgrid <- breaks$d / cbreaks
        bb1 <- range(breaks$x0[!is.na(breaks$x0)])
        bb2 <- range(breaks$y0[!is.na(breaks$y0)])
        breaksX <- seq(from = bb1[1], to = bb1[2], by = cgrid)
        breaksY <- seq(from = bb2[1], to = bb2[2], by = cgrid)
        while(min(breaksX) > xlimX[1])
            breaksX <- c((min(breaksX) - cgrid), breaksX)
        while(max(breaksX) < xlimX[2])
            breaksX <- c(breaksX, (max(breaksX) + cgrid))
        while(min(breaksY) > ylimY[1])
            breaksY <- c((min(breaksY) - cgrid), breaksY)
        while(max(breaksY) < ylimY[2])
            breaksY <- c(breaksY, (max(breaksY) + cgrid))
        
        ## limits and graduation
        limcalX <- hist(dfxy[, xax], breaksX, plot = FALSE)
        limcalY <- hist(dfxy[, yax], breaksY, plot = FALSE)
        top <- 1.1 * max(c(limcalX$counts, limcalY$counts))
        xlimY <- ylimX <- c(0, top)
        drawLines <- pretty(0:top)
        drawLines <- drawLines[-c(1, length(drawLines))]

        if(!missing(bandwidth)) {
            densiX <- bkde(dfxy[, xax], kernel = kernel, bandwidth = bandwidth, gridsize = gridsize)
            densiY <- bkde(dfxy[, yax], kernel = kernel, bandwidth = bandwidth, gridsize = gridsize)
        } else {
            densiX <- bkde(dfxy[, xax], kernel = kernel, gridsize = gridsize)
            densiY <- bkde(dfxy[, yax], kernel = kernel, gridsize = gridsize)
        }
        
        ## trellis creation 
        g2 <- xyplot(dfxy[, xax] ~ 1, xlim = xlimX, ylim = ylimX, horizontal = TRUE, scales = list(draw = FALSE), xlab = NULL, ylab = NULL, histValues = limcalX, drawLines = drawLines, panel = function(x, y, histValues, horizontal, drawLines, ...) .adeg.panel.hist(y = y, histValues = histValues, horizontal = horizontal, drawLines = drawLines, densi = densiX, params = sortparameters[[2]], ...))
        g3 <- xyplot(dfxy[, yax] ~ 1, xlim = xlimY, ylim = ylimY, horizontal = FALSE, scales = list(draw = FALSE), xlab = NULL, ylab = NULL, histValues = limcalY, drawLines = drawLines, panel = function(x, y, histValues, horizontal, drawLines, ...) .adeg.panel.hist(y = y, histValues = histValues, densi = densiY, horizontal = horizontal, drawLines = drawLines, params = sortparameters[[3]], ...))
        g4 <- xyplot(1 ~ 1, xlim = xlimY, ylim = ylimX, scales = list(draw = F), xlab = NULL, ylab = NULL, drawLines = drawLines, panel = function(drawLines, ...) .adeg.panel.join(drawLines = drawLines, params = sortparameters[[4]], ...))
        
        ## ADEgS creation and display
        obj <- new(Class = "ADEgS", ADEglist = list(object, g2, g3, g4), positions = positions, add = matrix(0, ncol = 4, nrow = 4), Call = match.call())
        names(obj) <- graphsnames
        if(plot)
            print(obj)
        invisible(obj)
    })


setMethod(
    f = "gettrellis",
    signature = "ADEg.S2",
    definition = function(object) {
        if(object@data$storeData) {
            dfxy <- as.matrix(object@data$dfxy)
            xax <- object@data$xax
            yax <- object@data$yax
        } else {
            dfxy <- as.matrix(eval(object@data$dfxy, envir = sys.frame(object@data$frame)))
            yax <- eval(object@data$yax, envir = sys.frame(object@data$frame))
            xax <- eval(object@data$xax, envir = sys.frame(object@data$frame))
        }
        
        tmptrellis <- do.call(what = object@lattice.call$graphictype, args = c(formula(dfxy[, yax] ~ dfxy[, xax]), object@lattice.call$arguments, environment()))
        return(tmptrellis)
    })

Try the adegraphics package in your browser

Any scripts or data that you put into this service are public.

adegraphics documentation built on May 31, 2017, 2:10 a.m.