R/explore.kasc.r

In adehabitat: Analysis of Habitat Selection by Animals

explore.kasc <- function (ka, coltxt="blue",
                          hscale = 1, vscale = 1, ...)
{
    if (!inherits(ka,"kasc"))
      stop("ka should be of class kasc")
    e1 <- new.env(parent = baseenv())
    assign("nn", NULL, envir=e1)
    assign("whi", 1, envir=e1) ## current graph

    ## function replot: to replot the content of the object
    replot <- function() {
        if (get("lim", envir=e1)) {
            assign("xlim", range(getXYcoords(ka)$x), envir=e1)
            assign("ylim", range(getXYcoords(ka)$y), envir=e1)
        }
        assign("nn", n2mfrow(length(ka)), envir=e1)
        split.screen(c(1,2))
        split.screen(get("nn", envir=e1), screen=2)
        on.exit(close.screen(all.screens=TRUE))
        na <- names(ka)
        sapply(1:length(na), function(j) {
            i <- na[j]
            screen(j+2)
            opar <- par(mar=c(0,0,2,0))
            image(getkasc(ka,i), main=i, axes=FALSE, xlim=get("xlim", envir=e1), ylim=get("ylim", envir=e1))
            if (get("ajoupo", envir=e1)) {
                text(get("a5", envir=e1)[1], get("a5", envir=e1)[2], ka[get("ia5", envir=e1),i], col=coltxt, font=2, cex=1.15)
            }
            box()
            par(opar)
        })
        screen(1)
        opar <- par(mar=c(0,0,2,0))
        image(getkasc(ka, get("whi", envir=e1)), main=na[get("whi", envir=e1)], axes=FALSE,
              xlim=get("xlim", envir=e1), ylim=get("ylim", envir=e1))
        assign("cusr", par("usr"), envir=e1)
        assign("cplt", par("plt"), envir=e1)
        if (get("ajouli", envir=e1))
            lines(c(get("a1", envir=e1)[1], get("a2", envir=e1)[1]), c(get("a1", envir=e1)[2], get("a2", envir=e1)[2]), lwd = 2,
                  col = "red")
        box()
        par(opar)
    }


    N <- length(ka)
    assign("D", 0, envir=e1)
    assign("xlim", range(getXYcoords(ka)$x), envir=e1)
    assign("ylim", range(getXYcoords(ka)$y), envir=e1)
    assign("lim", TRUE, envir=e1)
    assign("ajouli", FALSE, envir=e1)
    assign("ajoupo", FALSE, envir=e1)
    opt <- options(warn = -1)
    on.exit(options(opt))

    help.txt <- paste("\n-------- to obtain this help, type 'h' ------------------",
                      "z/o            -- Zoom in/Out",
                      "Right-Click    -- Identify value",
                      "Left-Click     -- Select variable /
                  Measure the distance between two points",
                      "q              -- Quit",
                      "---------------------------------------------------------",
                      "\n", sep = "\n")

    tt <- tcltk::tktoplevel()
    tcltk::tkwm.title(tt, "Exploration of kasc maps")
    img <- tkrplot::tkrplot(tt, replot, hscale = hscale, vscale = vscale)
    txt <- tcltk::tktext(tt, bg = "white", font = "courier 10")
    scr <- tcltk::tkscrollbar(tt, repeatinterval = 5, command = function(...) tcltk::tkyview(txt, ...))
    tcltk::tkconfigure(txt, yscrollcommand = function(...) tcltk::tkset(scr,
                            ...))
    tcltk::tkpack(img, side = "top")
    tcltk::tkpack(txt, side = "left", fill = "both", expand = TRUE)
    tcltk::tkpack(scr, side = "right", fill = "y")
    iw <- as.numeric(tcltk::tcl("image", "width", tcltk::tkcget(img, "-image")))
    ih <- as.numeric(tcltk::tcl("image", "height", tcltk::tkcget(img, "-image")))

    showz <- function() tkrplot::tkrreplot(img)
    type <- function(s) {
        tcltk::tkinsert(txt, "end", s)
        tcltk::tksee(txt, "end")
    }
    type(help.txt)
    cc <- function(x, y) {
        x <- (as.double(x) - 1)/iw
        y <- 1 - (as.double(y) - 1)/ih
        px <- (x - get("cplt", envir=e1)[1])/(get("cplt", envir=e1)[2] - get("cplt", envir=e1)[1])
        py <- (y - get("cplt", envir=e1)[3])/(get("cplt", envir=e1)[4] - get("cplt", envir=e1)[3])
        ux <- px * (get("cusr", envir=e1)[2] - get("cusr", envir=e1)[1]) + get("cusr", envir=e1)[1]
        uy <- py * (get("cusr", envir=e1)[4] - get("cusr", envir=e1)[3]) + get("cusr", envir=e1)[3]
        c(ux, uy)
    }
    cc2 <- function(x, y) {
        x <- (as.double(x) - 1)/iw
        y <- 1 - (as.double(y) - 1)/ih
        px <- (x - get("cplt", envir=e1)[1])/(get("cplt", envir=e1)[2] - get("cplt", envir=e1)[1])
        py <- (y - get("cplt", envir=e1)[3])/(get("cplt", envir=e1)[4] - get("cplt", envir=e1)[3])
        c(px, py)
    }

    mm.t <- function(x, y) {
        veri <- cc2(x,y)
        if (veri[1]<0.5) {
            i <- get("D", envir=e1)
            if (i == 0) {
                ux <- (2*veri[1]) * (get("cusr", envir=e1)[2] - get("cusr", envir=e1)[1]) + get("cusr", envir=e1)[1]
                uy <- veri[2]* (get("cusr", envir=e1)[4] - get("cusr", envir=e1)[3]) + get("cusr", envir=e1)[3]
                assign("a1", c(ux, uy), envir=e1)
                assign("D", 1, envir=e1)
            }
            if (i == 1) {
                ux <- (2*veri[1]) * (get("cusr", envir=e1)[2] - get("cusr", envir=e1)[1]) + get("cusr", envir=e1)[1]
                uy <- veri[2]* (get("cusr", envir=e1)[4] - get("cusr", envir=e1)[3]) + get("cusr", envir=e1)[3]
                assign("a2", c(ux, uy), envir=e1)
                assign("D", 0, envir=e1)
                di <- sqrt(sum((get("a2", envir=e1) - get("a1", envir=e1))^2))
                type(paste("distance:", di, "\n"))
                assign("ajouli", TRUE, envir=e1)
                showz()
                assign("ajouli", FALSE, envir=e1)
            }
        } else {
            veri[1] <- 2*(veri[1]-0.5)
            rc <- veri
            rc[1] <- as.numeric(cut(veri[2],seq(0,1,length=get("nn", envir=e1)[1]+1)))
            rc[2] <- as.numeric(cut(veri[1],seq(0,1,length=get("nn", envir=e1)[2]+1)))
            rc[1] <- get("nn", envir=e1)[1] - rc[1] +1
            assign("whi", get("nn", envir=e1)[2]*(rc[1]-1) + rc[2], envir=e1)
            showz()
        }
        return()
    }
    mm.t2 <- function(x, y) {
        veri <- cc2(x,y)
        ux <- (2*veri[1]) * (get("cusr", envir=e1)[2] - get("cusr", envir=e1)[1]) + get("cusr", envir=e1)[1]
        uy <- veri[2]* (get("cusr", envir=e1)[4] - get("cusr", envir=e1)[3]) + get("cusr", envir=e1)[3]
        assign("a3", c(ux, uy), envir=e1)
        xyc <- getXYcoords(ka)
        yc <- rep(xyc$y, each=length(xyc$x))
        xc <- rep(xyc$x, length(xyc$y))
        iy <- rep(1:length(xyc$y), each=length(xyc$x))
        ix <- rep(1:length(xyc$x), length(xyc$y))

        di <- sqrt((xc - get("a3", envir=e1)[1])^2 + (yc - get("a3", envir=e1)[2])^2)
        assign("a5", unlist(cbind(xc,yc)[which.min(di),]), envir=e1)
        assign("ia5", which.min(di), envir=e1)
        assign("ajoupo", TRUE, envir=e1)
        showz()
        assign("ajoupo", FALSE, envir=e1)
        type(paste("Index:", get("ia5", envir=e1),"\n"))
        return()
    }
    mm.mouset <- function(x, y) {
        veri <- cc2(x,y)
        if (veri[1]<0.5) {
        ux <- (2*veri[1]) * (get("cusr", envir=e1)[2] - get("cusr", envir=e1)[1]) + get("cusr", envir=e1)[1]
        uy <- veri[2]* (get("cusr", envir=e1)[4] - get("cusr", envir=e1)[3]) + get("cusr", envir=e1)[3]
        assign("a8", c(ux, uy), envir=e1)
    }
        return()
    }
    kb <- function(A) {
        key <- tolower(A)
        if (key == "q") {
            tcltk::tkdestroy(tt)
            return("OK - Finished")
        }
        if (key == "z") {
            tmppx <- (get("cusr", envir=e1)[1:2] - get("cusr", envir=e1)[1])
            assign("xlim", c(get("a8", envir=e1)[1] - tmppx[2]/4, (get("a8", envir=e1)[1] + tmppx[2]/4)), envir=e1)
            assign("tmppy", (get("cusr", envir=e1)[3:4] - get("cusr", envir=e1)[3]), envir=e1)
            assign("ylim", c(get("a8", envir=e1)[2] - get("tmppy", envir=e1)[2]/4, (get("a8", envir=e1)[2] + get("tmppy", envir=e1)[2]/4)), envir=e1)
            assign("lim", FALSE, envir=e1)
            showz()
        }
        if (key == "o") {
            assign("lim", TRUE, envir=e1)
            showz()
        }
    }
    showz()
    tcltk::tkbind(tt, "<Key>", kb)
    tcltk::tkbind(img, "<Button-1>", mm.t)
    tcltk::tkbind(img, "<Motion>", mm.mouset)
    tcltk::tkbind(img, "<Button-3>", mm.t2)
    tcltk::tkwait.window(tt)

}