.packageName <- "grasper"
"grasp.GRASS" <-
function (layername) 
{
    Yname <- names(YYY)[gr.Yi]
    cat("\n")
    cat("********** GraspeR export to GRASS **********", "\n")
    cat("As I had problems with the function rast.put,", "\n")
    cat("I decided to export data first to a file,", "\n")
    cat("then reimport it in GRASS...", "\n")
    cat("*********************************************", "\n")
    cat(date(), "\n")
    cat("RESPONSE NAME: ", Yname, "\n")
    cat("Layer name: ", layername, "\n")
    cat("\n")
    grasp.ascii()
    a = paste("r.in.arc input=", filename, " output=", layername, sep = "")
    system(a)
    b = paste("d.rast ", layername, sep = "")
    system(b)
    cat("*********************************************", "\n")
}
"grasp.GUI" <-
function (grass.on = FALSE) 
{
    require(tcltk) || stop("Tcl/Tk is not available, see README for installation and configuration...")
    require(mgcv) || stop("Mgcv library is not available, install it from CRAN...")
    require(MASS) || stop("MASS library is not available, install it from CRAN...")
    require(stats) || stop("stats library is not available, install it from CRAN...")
    if (grass.on) 
        require(GRASS)
    d.show.sites <- function(...) {
        G <- gmeta()
        x <- XXX[YYY[, 2] == 1, 2]
        y <- XXX[YYY[, 2] == 1, 3]
        z <- rep(1, length(XXX[YYY[, 2] == 1, 1]))
	xyz <- data.frame(east=x,north=y,zn=z)
	sites.put2(g,xyz,dims=c("east","north"),lname="presences",check=FALSE)
        system("d.sites type=+ sitefile=presences color=red")
    }
    grasp.lut.create <- function(...) {
        grasp.lut(gr.Yi)
    }
    d.erase <- function(...) {
        system("d.erase")
    }
    g.list.rast <- function(...) {
        system("g.list rast")
    }
    startmon <- function(...) {
        system("d.mon x0")
    }
    stopmon <- function(...) {
        system("d.mon stop=x0")
    }
    selectgrid.export <- function(...) {
        GRASS.export <- function(...) {
            grasp.GRASS(tclvalue(YYname))
            tkdestroy(gridselexport)
        }
        gridselexport <- tktoplevel()
        tktitle(gridselexport) <- "Select grid"
        Yname <- names(YYY[, gr.Yi])
        YYname <- tclVar("pred")
        gridselexport.label <- tklabel(gridselexport, text = "Grid name to export to:")
        gridselexport.entry <- tkentry(gridselexport, textvariable = YYname, 
            width = 10)
        gridselexport.but <- tkbutton(gridselexport, text = "Export", 
            command = GRASS.export)
        tkpack(gridselexport.label, gridselexport.entry, gridselexport.but, 
            fill = "x")
    }
    selectgrid.show <- function(...) {
        GRASS.show <- function(...) {
            Gname <- tclvalue(YYname)
            Gfunct <- paste("system(", "\"", "d.rast ", Gname, 
                "\"", ")", sep = "")
            eval(parse(text = Gfunct))
            tkdestroy(gridselshow)
        }
        gridselshow <- tktoplevel()
        tktitle(gridselshow) <- "Select grid"
        Yname <- names(YYY[, gr.Yi])
        YYname <- tclVar(paste(Yname, "pred", sep = ""))
        gridselshow.label <- tklabel(gridselshow, text = "Grid name to show:")
        gridselshow.entry <- tkentry(gridselshow, textvariable = YYname, 
            width = 10)
        gridselshow.but <- tkbutton(gridselshow, text = "Show", 
            command = GRASS.show)
        tkpack(gridselshow.label, gridselshow.entry, gridselshow.but, 
            fill = "x")
    }
    XXX.fix <- function(..) fix(XXX)
    grasp.limits.GUI.spec <- function(...) grasp.limits.GUI()
    grasp.corlim.plot <- function(...) lapply(gr.selY, grasp.corlim)
    grasp.update.packages <- function(...) update.packages()
    close.all <- function(...) q("yes")
    grasp.ascii.export <- function(...) grasp.ascii()
    grasp.export.txt <- function() grasp.export()
    YYY.fix <- function(...) fix(YYY)
    XXXpred.fix <- function(...) fix(XXXpred)
    WEIGHTS.fix <- function(...) fix(WEIGHTS)
    grasp.pred.gui <- function(...) grasp.pred()
    test.apply.ok <- function(...) {
        if (apply.ok == FALSE) 
            stop("Set options first...")
    }
    grasp.histo.plot <- function(...) {
        lapply(gr.selY, grasp.histo)
    }
    grasp.RvsP.plot <- function(...) {
        lapply(gr.selY, grasp.RvsP)
    }
    grasp.pred.plot.plot <- function(...) {
        par(mfrow = c(1, 1), mai = c(0.5, 0.5, 0.5, 0.5), tcl = 0.25)
        grasp.pred.plot(gr.predmat)
    }
    grasp.model.plot <- function(...) {
        par(cex = 0.8, mai = c(0.5, 0.5, 0.5, 0.75))
        plot.gam(gam.start, pages = 1, scale = 0, n = 1000)
        title(main = "GRASP MODEL PLOTS", sub = gam.start$formula)
    }
    grasp.cormat.plot <- function(...) lapply(gr.selY, grasp.cormat)
    grasp.datamap.plot <- function(...) lapply(gr.selY, grasp.datamap)
    grasp.model.go <- function(...) lapply(gr.selY, grasp.model)
    about.msgbox <- function(...) tkmessageBox(icon = "info", 
        message = "R-GRASP - By A. Lehmann. Ported to R by F. Fivaz", 
        type = "ok", parent = main, title = "About...")
    main.close <- function(...) tkdestroy(main)
    grasp.persp.plot <- function(...) vis.gam(gam.start)
    grasp.model.summary <- function(...) {
        cat("Warning : this function only works if you already have created a model", 
            "\n")
        sum.gam <- summary.gam(gam.start)
        print(sum.gam)
    }
    grasp.model.check <- function(...) gam.check(gam.start)
    grasp.step.anova <- function(...) grasp.step.gam(gam.start, 
        direction = "both")
    grasp.scope.list <- function(...) grasp.scope(gr.selX)
    grasp.summary.gui <- function(...) lapply(gr.selY, grasp.summary)
    main <- tktoplevel()
    tktitle(main) <- "GRASP for R"
    main.statusbar <- tkframe(main)
    main.statusbar.label <- tklabel(main.statusbar, text = "Welcome to GRASP for R", 
        relief = "sunken", anchor = "w")
    tkpack(main.statusbar.label, side = "left", padx = 2, expand = "yes", 
        fill = "both")
    tkpack(main.statusbar, side = "bottom", fill = "x", pady = 2)
    main.menu <- tkmenu(main, tearoff = 0)
    main.menu.file <- tkmenu(main, tearoff = 0)
    tkadd(main.menu, "cascade", menu = main.menu.file, label = "File", 
        underline = 0)
    tkadd(main.menu.file, "command", label = "Import...", command = grasp.import.GUI)
    tkadd(main.menu.file, "command", label = "grasp.in...", command = grasp.in.GUI)
    tkadd(main.menu.file, "separator")
    tkadd(main.menu.file, "command", label = "Close GUI", command = main.close)
    tkadd(main.menu.file, "command", label = "Save workspace and exit", 
        command = close.all)
    main.menu.edit <- tkmenu(main, tearoff = 0)
    tkadd(main.menu, "cascade", menu = main.menu.edit, label = "Edit", 
        underline = 0)
    tkadd(main.menu.edit, "command", label = "Set options...", 
        command = grasp.options.GUI)
    tkadd(main.menu.edit, "command", label = "Set responses...", 
        command = grasp.select.responses)
    tkadd(main.menu.edit, "command", label = "Set predictors...", 
        command = grasp.select.predictors)
    tkadd(main.menu.edit, "command", label = "Set limits...", 
        command = grasp.limits.GUI.spec)
    tkadd(main.menu.edit, "separator")
    tkadd(main.menu.edit, "command", label = "YYY", command = YYY.fix)
    tkadd(main.menu.edit, "command", label = "XXX", command = XXX.fix)
    tkadd(main.menu.edit, "command", label = "XXXpred", command = XXXpred.fix)
    tkadd(main.menu.edit, "command", label = "WEIGHTS", command = WEIGHTS.fix)
    main.menu.analysis <- tkmenu(main, tearoff = 0)
    tkadd(main.menu, "cascade", menu = main.menu.analysis, label = "Analysis", 
        underline = 0)
    tkadd(main.menu.analysis, "command", label = "Summary", command = grasp.summary.gui)
    tkadd(main.menu.analysis, "command", label = "Summary of model", 
        command = grasp.model.summary)
    tkadd(main.menu.analysis, "separator")
    tkadd(main.menu.analysis, "command", label = "Model", command = grasp.model.go)
    tkadd(main.menu.analysis, "command", label = "Create scope list", 
        command = grasp.scope.list)
    tkadd(main.menu.analysis, "command", label = "Stepwise selection using ANOVA (EXPERIMENTAL)", 
        command = grasp.step.anova)
    tkadd(main.menu.analysis, "command", label = "Predict", command = grasp.pred.gui)
    tkadd(main.menu.analysis, "command", label = "Check GAM model", 
        command = grasp.model.check)
    tkadd(main.menu.analysis, "separator")
    tkadd(main.menu.analysis, "command", label = "Automated selection, model and predict...", 
        command = grasp.model.GUI)
    main.menu.plot <- tkmenu(main, tearoff = 0)
    tkadd(main.menu, "cascade", menu = main.menu.plot, label = "Plot", 
        underline = 0)
    tkadd(main.menu.plot, "command", label = "Data map", command = grasp.datamap.plot)
    tkadd(main.menu.plot, "command", label = "Histograms", command = grasp.histo.plot)
    tkadd(main.menu.plot, "command", label = "Response vs. predictors", 
        command = grasp.RvsP.plot)
    tkadd(main.menu.plot, "command", label = "Correlations", 
        command = grasp.cormat.plot)
    tkadd(main.menu.plot, "command", label = "Covariate space", 
        command = grasp.corlim.plot)
    tkadd(main.menu.plot, "separator")
    tkadd(main.menu.plot, "command", label = "Model", command = grasp.model.plot)
    tkadd(main.menu.plot, "command", label = "Perspective plot of model", 
        command = grasp.persp.plot)
    tkadd(main.menu.plot, "command", label = "Predictions", command = grasp.pred.plot.plot)
    main.menu.export <- tkmenu(main, tearoff = 0)
    tkadd(main.menu, "cascade", menu = main.menu.export, label = "Export", 
        underline = 0)
    tkadd(main.menu.export, "command", label = "Export to ASCII...", 
        command = grasp.ascii.export)
    tkadd(main.menu.export, "command", label = "Export to points...", 
        command = grasp.export.txt)
    tkadd(main.menu.export, "command", label = "Create lookup tables", 
        command = grasp.lut.create)
    if (grass.on) {
        main.menu.GRASS <- tkmenu(main, tearoff = 0)
        tkadd(main.menu, "cascade", menu = main.menu.GRASS, label = "GRASS", 
            underline = 0)
        tkadd(main.menu.GRASS, "command", label = "Start monitor X0", 
            command = startmon)
        tkadd(main.menu.GRASS, "command", label = "Stop monitor X0", 
            command = stopmon)
        tkadd(main.menu.GRASS, "command", label = "GraspeR.GRASS (Create grid)...", 
            command = selectgrid.export)
        tkadd(main.menu.GRASS, "command", label = "Convert grid to integer...")
        tkadd(main.menu.GRASS, "command", label = "Display grid...", 
            command = selectgrid.show)
        tkadd(main.menu.GRASS, "command", label = "Display presences on the map", 
            command = d.show.sites)
        tkadd(main.menu.GRASS, "command", label = "Erase currently selected monitor", 
            command = d.erase)
        tkadd(main.menu.GRASS, "command", label = "List available grids", 
            command = g.list.rast)
    }
    main.menu.help <- tkmenu(main, tearoff = 0)
    tkadd(main.menu, "cascade", menu = main.menu.help, label = "Help", 
        underline = 0)
    tkadd(main.menu.help, "command", label = "About...", command = grasp.about.GUI)
    tkadd(main.menu.help, "separator")
    tkadd(main.menu.help, "command", label = "Update packages", 
        command = grasp.update.packages)
    tkconfigure(main, menu = main.menu)
    assign("main", main, pos = 1)
    frame1 <- tkframe(main, relief = "groove", borderwidth = 2)
    main.backgrd.label.main <- tklabel(frame1, text = "GRASP for R", 
        anchor = "w", font = "arial 20", justify = "left")
    main.backgrd.label.sub <- tklabel(frame1, text = "Generalized Regression Analysis and Spatial Prediction for R", 
        anchor = "w", font = "arial 14", justify = "left")
    tkpack(frame1, main.backgrd.label.main, main.backgrd.label.sub, 
        side = "top", fill = "x")
}
"grasp.README.GUI" <-
function () 
{
    README.close <- function() tkdestroy(README)
    README <- tktoplevel()
    tktitle(README) <- "README for GraspeR"
    frame1 <- tkframe(README)
    frame2 <- tkframe(README)
    frame1.yscroll <- tkscrollbar(frame1)
    frame1.text <- tktext(frame1, font = "Arial 10", yscrollcommand = paste(.Tk.ID(frame1.yscroll), 
        "set"), height = 20)
    tkconfigure(frame1.yscroll, command = paste(.Tk.ID(frame1.text), 
        "yview"))
    tkpack(frame1, frame1.text, side = "left", fill = "x")
    tkpack(frame1, frame1.yscroll, side = "right", fill = "y")
    zz <- tkopen("README")
    zy <- tkread(zz)
    tkclose(zz)
    tkinsert(frame1.text, "end", zy)
    tkpack(frame2, tkbutton(frame2, text = "Close", font = "Arial 10", 
        command = README.close))
}
"grasp.RvsP" <-
function (gr.Yi = gr.selY, sX = gr.selX) 
{
    Yname <- names(YYY)[gr.Yi]
    cat("\n")
    cat("********** GRASP RESPONSE VS PREDICTORS **********", 
        "\n")
    cat(date(), "\n")
    cat("RESPONSE NAME: ", Yname, "\n")
    par(mfrow = c(4, 2), mai = c(0.5, 0.5, 0.5, 0.5))
    first <- TRUE
    YYY <- YYY[gr.modmask[, gr.Yi], ]
    XXX <- XXX[gr.modmask[, gr.Yi], ]
    for (xi in sX) {
        plot(XXX[, xi], YYY[, gr.Yi], xlab = names(XXX)[xi], 
            ylab = names(YYY)[gr.Yi])
        if (!is.factor(XXX[, xi])) 
            lines(smooth.spline(XXX[, xi], YYY[, gr.Yi], df = 3))
        if (first) 
            title(paste(OPT$TITLE, "RESPONSE vs. PREDICTIONS", 
                sep = " "))
        first <- FALSE
    }
    cat("\n")
    cat(" ********** GRASP RESPONSE VS PREDICTORS END ********** ", 
        "\n")
    cat("\n")
}
"grasp.TODO.GUI" <-
function () 
{
    TODO.close <- function() tkdestroy(TODO)
    TODO <- tktoplevel()
    tktitle(TODO) <- "TODO list for GraspeR"
    frame1 <- tkframe(TODO)
    frame2 <- tkframe(TODO)
    frame1.yscroll <- tkscrollbar(frame1)
    frame1.text <- tktext(frame1, font = "Arial 10", yscrollcommand = paste(.Tk.ID(frame1.yscroll), 
        "set"), height = 20)
    tkconfigure(frame1.yscroll, command = paste(.Tk.ID(frame1.text), 
        "yview"))
    tkpack(frame1, frame1.text, side = "left", fill = "x")
    tkpack(frame1, frame1.yscroll, side = "right", fill = "y")
    zz <- tkopen("todo.txt")
    zy <- tkread(zz)
    tkclose(zz)
    tkinsert(frame1.text, "end", zy)
    tkpack(frame2, tkbutton(frame2, text = "Close", font = "Arial 10", 
        command = TODO.close))
}
"grasp.in.GUI" <-
function () 
{
    graspin.close <- function(...) {
        tkdestroy(graspin)
    }
    grasp.init <- function(...) {
        YYYvar.local <- as.character(tclvalue(YYYvar))
        YYYparse <- eval(parse(text = YYYvar.local))
        XXXvar.local <- as.character(tclvalue(XXXvar))
        XXXparse <- eval(parse(text = XXXvar.local))
        XXXpredvar.local <- as.character(tclvalue(XXXpredvar))
        XXXpredparse <- eval(parse(text = XXXpredvar.local))
        cat("YYY = ", YYYvar.local, "\n")
        cat("XXX = ", XXXvar.local, "\n")
        cat("XXXpred = ", XXXpredvar.local, "\n")
        grasp.in(YYYparse, XXXparse, XXXpredparse)
        cat("initializing done", "\n")
    }
    graspin <- tktoplevel()
    tktitle(graspin) <- "GraspeR in"
    YYYvar <- tclVar("YYY")
    XXXvar <- tclVar("XXX")
    XXXpredvar <- tclVar("XXXpred")
    frame1 <- tkframe(graspin, relief = "groove", borderwidth = 2)
    frame2 <- tkframe(graspin, relief = "groove", borderwidth = 2)
    frame3 <- tkframe(graspin, relief = "groove", borderwidth = 2)
    frame1.label1 <- tklabel(frame1, text = "GraspeR.in - Data initializing")
    frame1.label2 = tklabel(frame1, text = "Warning: Apply will reinitialize all your precedent choices...!", 
        wraplength = 200)
    tkpack(frame1, frame1.label1, frame1.label2, fill = "x")
    frame2.label1 <- tklabel(frame2, text = "YYY:")
    frame2.label2 <- tklabel(frame2, text = "XXX:")
    frame2.label3 <- tklabel(frame2, text = "XXXpred:")
    frame2.entry1 <- tkentry(frame2, textvariable = YYYvar, width = 10)
    frame2.entry2 <- tkentry(frame2, textvariable = XXXvar, width = 10)
    frame2.entry3 <- tkentry(frame2, textvariable = XXXpredvar, 
        width = 10)
    tkgrid(frame2.label1, frame2.entry1, sticky = "w")
    tkgrid(frame2.label2, frame2.entry2, sticky = "w")
    tkgrid(frame2.label3, frame2.entry3, sticky = "w")
    tkpack(frame2, fill = "x")
    frame3.but1 <- tkbutton(frame3, text = "Apply", padx = 20, 
        command = grasp.init)
    frame3.but2 <- tkbutton(frame3, text = "Close", padx = 20, 
        command = graspin.close)
    tkgrid(frame3.but1, frame3.but2, sticky = "w")
    tkpack(frame3)
}
"grasp.about.GUI" <-
function () 
{
    about.close <- function() {
        tkdestroy(about)
    }
    about <- tktoplevel()
    tktitle(about) <- "About GraspeR"
    about.platform <- version[[1]]
    about.version <- paste(version[[6]], version[[7]], sep = ".")
    about.date <- paste(version[[10]], version[[9]], version[[8]], 
        sep = "/")
    frame1 <- tkframe(about, relief = "groove", borderwidth = 2)
    frame2 <- tkframe(about, relief = "groove", borderwidth = 2)
    frame3 <- tkframe(about, relief = "groove", borderwidth = 2)
    frame1.label1 <- tklabel(frame1, text = "GraspeR version 0.4-2", 
        font = "Arial 12")
    frame1.label2 <- tklabel(frame1, text = "Written by F. Fivaz (fabien.fivaz@bluewin.ch)", 
        font = "Arial 11")
    frame1.label3 <- tklabel(frame1, text = "Original programming on S-Plus by Anthony Lehmann,", 
        font = "Arial 11")
    frame1.label12 <- tklabel(frame1, text = "John Leathwich and Jake McOverton (Landcare Research Institute, NZ)", 
        font = "Arial 11")
    frame1.label4 <- tklabel(frame1, text = "http://www.cscf.ch/grasp", 
        font = "Arial 11")
    frame1.label5 <- tklabel(frame1, text = "Released under the terms of the GPL license", 
        font = "Arial 11")
    frame1.label6 <- tklabel(frame1, text = "Swiss Center of Faunal Cartography", 
        font = "Arial 10")
    frame1.label7 <- tklabel(frame1, text = "Terreaux 14", font = "Arial 9")
    frame1.label8 <- tklabel(frame1, text = "2000 Neuchtel", 
        font = "Arial 10")
    frame1.label9 <- tklabel(frame1, text = "Switzerland", font = "Arial 9")
    frame1.label10 <- tklabel(frame1, text = "+41 32 725 72 57", 
        font = "Arial 10")
    frame1.label11 <- tklabel(frame1, text = "http://www.cscf.ch/", 
        font = "Arial 10")
    tkpack(frame1, frame1.label1, frame1.label2, frame1.label3, 
        frame1.label12, frame1.label4, frame1.label5, frame1.label6, 
        frame1.label7, frame1.label8, frame1.label9, frame1.label10, 
        frame1.label11, fill = "x")
    frame2.label1 <- tklabel(frame2, text = "Platform", font = "Arial 11")
    frame2.label11 <- tklabel(frame2, text = about.platform, 
        font = "Courrier 11")
    tkgrid(frame2.label1, frame2.label11)
    frame2.label2 <- tklabel(frame2, text = "Version of R", font = "Arial 11")
    frame2.label21 <- tklabel(frame2, text = about.version, font = "Courrier 11")
    tkgrid(frame2.label2, frame2.label21)
    frame2.label3 <- tklabel(frame2, text = "R release date", 
        font = "Arial 11")
    frame2.label31 <- tklabel(frame2, text = about.date, font = "Courrier 10")
    tkgrid(frame2.label3, frame2.label31)
    tkpack(frame2, fill = "x")
    frame3.button1 <- tkbutton(frame3, text = "Close", command = about.close, 
        padx = 30, font = "Arial 11")
    frame3.button2 <- tkbutton(frame3, text = "License", command = grasp.gpl.GUI, 
        padx = 30, font = "Arial 11")
    tkgrid(frame3.button1, frame3.button2)
    tkpack(frame3)
}
"grasp.anova.gam" <-
function (object, ..., dispersion = NULL, test = NULL) 
{
    object$df.residual <- object$df.null - sum(object$edf) - 
        object$nsdf
    dotargs <- list(...)
    named <- if (is.null(names(dotargs))) 
        rep(FALSE, length(dotargs))
    else (names(dotargs) != "")
    if (any(named)) 
        warning(paste("The following arguments to anova.glm(..)", 
            "are invalid and dropped:", paste(deparse(dotargs[named]), 
                collapse = ", ")))
    dotargs <- dotargs[!named]
    is.gam <- unlist(lapply(dotargs, function(x) inherits(x, 
        "gam")))
    dotargs <- dotargs[is.gam]
    if (length(dotargs) == 0) 
        stop("need two or more models to compare")
    for (i in 1:length(dotargs)) {
        class(dotargs[[i]]) <- c(class(dotargs[[i]]), "glm")
        dotargs[[i]]$df.residual <- dotargs[[i]]$df.null - sum(dotargs[[i]]$edf) - 
            dotargs[[i]]$nsdf
    }
    grasp.anova.glmlist(c(list(object), dotargs), test = test, 
        dispersion = dispersion)
}
"grasp.anova.glmlist" <-
function (object, ..., dispersion = NULL, test = NULL) 
{
    responses <- as.character(lapply(object, function(x) {
        deparse(formula(x)[[2]])
    }))
    sameresp <- responses == responses[1]
    if (!all(sameresp)) {
        object <- object[sameresp]
        warning(paste("Models with response", deparse(responses[!sameresp]), 
            "removed because response differs from", "model 1"))
    }
    ns <- sapply(object, function(x) length(x$residuals))
    if (any(ns != ns[1])) 
        stop("models were not all fitted to the same size of dataset")
    nmodels <- length(object)
    if (nmodels == 1) 
        return(anova.glm(object[[1]], dispersion = dispersion, 
            test = test))
    resdf <- as.numeric(lapply(object, function(x) x$df.residual))
    resdev <- as.numeric(lapply(object, function(x) x$deviance))
    table <- data.frame(resdf, resdev, c(NA, -diff(resdf)), c(NA, 
        -diff(resdev)))
    variables <- lapply(object, function(x) paste(deparse(formula(x)), 
        collapse = "\n"))
    dimnames(table) <- list(1:nmodels, c("Resid. Df", "Resid. Dev", 
        "Df", "Deviance"))
    title <- "Analysis of Deviance Table\n"
    topnote <- paste("Model ", format(1:nmodels), ": ", variables, 
        sep = "", collapse = "\n")
    if (!is.null(test)) {
        bigmodel <- object[[order(resdf)[1]]]
        df.dispersion <- if (dispersion == 1) 
            Inf
        else min(resdf)
        table <- grasp.stat.anova(table = table, test = test, 
            scale = dispersion, df.scale = df.dispersion, n = length(bigmodel$residuals))
    }
    structure(table, heading = c(title, topnote), class = c("anova", 
        "data.frame"))
}
"grasp.ascii" <-
function (gr.Yi = gr.selY, var = gr.predmat, resolution = 1000) 
{
    assign("gr.Yi", gr.Yi, pos = 1)
    if (length(gr.Yi) > 2) {
        stop("This function accepts only one varible in gr.Yi. Use lapply(gr.Yi, grasp.ascii) if you want to run it many times!")
    }
    else {
        Y <- as.numeric(gr.Yi)
    }
    Yname <- names(YYY)[gr.Yi]
    cat("\n")
    cat(" vvvvvvvvvv GRASP ASCII vvvvvvvvvv ", "\n")
    cat(date(), "\n")
    cat("RESPONSE NAME: ", Yname, "\n")
    maxX <- (ceiling(max(XXXpred$x)/resolution) * resolution) + 
        resolution
    minX <- (floor(min(XXXpred$x)/resolution) * resolution)
    maxY <- (ceiling(max(XXXpred$y)/resolution) * resolution) + 
        resolution
    minY <- (floor(min(XXXpred$y)/resolution) * resolution)
    half <- resolution/2
    cat("maxX: ", maxX, "\n")
    cat("minX: ", minX, "\n")
    cat("maxY: ", maxY, "\n")
    cat("minY: ", minY, "\n")
    Nrow <- (maxX - minX)/resolution
    Ncol <- (maxY - minY)/resolution
    cat("nrow =", Nrow, "and ncol =", Ncol, "\n")
    filename <- paste("pred_", names(YYY[gr.Yi]), ".asc", sep = "")
    fred1 <- round((XXXpred$x - (minX - half))/resolution)
    fred2 <- round(Ncol - ((XXXpred$y - (minY + half))/resolution))
    fred3 <- zapsmall(var[, Y], 4)
    map <- matrix(-99.9, nrow = Nrow, ncol = Ncol)
    temp <- as.data.frame(cbind(fred1, fred2, fred3))
    print(temp[1:10, ])
    noduplicates <- all(!(duplicated(paste(temp$fred1, temp$fred2, 
        sep = "x"))))
    if (noduplicates) 
        cat("INFO: There are no duplicated X and Y coordinates in prediction set !", 
            "\n")
    else if (dim(temp)[1] < 10000) {
        temp <- aggregate(temp, by = list(temp$fred1, temp$fred2), 
            mean)
        cat("AGGREGATION: The mean of predicted value found for each combination of Xs and Ys is returned !!!", 
            "\n")
    }
    else cat("AGGREGATION (>10000 predictions): Only the first predicted value found for each combination of Xs and Ys is returned !!!", 
        "\n")
    fred1 <- temp$fred1
    fred2 <- temp$fred2
    fred3 <- temp$fred3
    for (r in 1:nrow(temp)) {
        map[fred1[r], fred2[r]] <- fred3[r]
    }
    write(paste("ncols", Nrow), file = filename)
    write(paste("nrows", Ncol), file = filename, append = TRUE)
    write(paste("xllcorner", minX), file = filename, append = TRUE)
    write(paste("yllcorner", minY), file = filename, append = TRUE)
    write(paste("cellsize", resolution), file = filename, append = TRUE)
    write("NODATA_value -99.9", file = filename, append = TRUE)
    write(map, file = filename, ncol = Ncol, append = TRUE)
    cat("prediction exported to: ", "\n")
    cat(filename, "\n")
    assign("map", map, pos = 1)
    assign("filename", filename, pos = 1)
    cat("\n")
    cat(" ********** GRASP ASCII END ********** ", "\n")
}
"grasp.corlim" <-
function (gr.Yi = gr.selY, cols = gr.selX, thin = 1) 
{
    x11()
    Yname <- names(YYY)[gr.Yi]
    cat("\n")
    cat("*********** GRASP COVARIATE SPACE PLOT ***********", 
        "\n")
    cat(date(), "\n")
    cat("\n")
    cat("RESPONSE NAME: ", Yname, "\n")
    data <- XXX[gr.modmask[, gr.Yi], ]
    assign("data", data, pos = 1)
    gr.selXCOR <- gr.selXCOR
    panel <- function(x, y) {
        ind <- YYY[, gr.Yi] == 1
        points(x, y)
        points(x[ind], y[ind], col = 2)
    }
    ndata <- thin * nrow(data)
    index <- ((1:ndata) * 1)/thin
    thindata <- data[index, ]
    pairs(thindata[, cols], panel = panel)
    text(0, 1.17, paste("GRASP: ", " ", Yname), adj = 0, cex = 0.7)
    cat("Red points are presences (1), black points absences(0)", 
        "\n")
    cat("\n")
    cat(" ********** GRASP COAVRIATE SPACE PLOT END ********** ", 
        "\n")
    cat("\n")
    cat("\n")
}
"grasp.cormat" <-
function (gr.Yi = gr.selY, cols = gr.selX, thin = 1) 
{
    x11()
    Yname <- names(YYY)[gr.Yi]
    cat("\n")
    cat("********** GRASP CORRELATION MATRIX CALCULATION **********", 
        "\n")
    cat(date(), "\n")
    cat("\n")
    cat("RESPONSE NAME: ", Yname, "\n")
    data <- XXX[gr.modmask[, gr.Yi], ]
    XXX <- XXX[gr.modmask[, gr.Yi], ]
    assign("data", data, pos = 1)
    gr.selXCOR <- gr.selXCOR
    panel <- function(x, y) {
        points(x, y, col = 2)
        corr <- zapsmall(cor(x, y), 2)
        text(min(x), max(y), cex = 1.2, as.character(corr), adj = 0)
    }
    ndata <- thin * nrow(data)
    index <- ((1:ndata) * 1)/thin
    thindata <- data[index, ]
    pairs(thindata[, cols], panel = panel)
    text(0, 1.17, paste("GRASP: ", " ", Yname), adj = 0, cex = 0.7)
    gr.selXcor <- NULL
    gr.selXfac <- NULL
    for (i in gr.selX) {
        if (!is.factor(XXX[, i])) 
            gr.selXcor <- c(gr.selXcor, i)
        else gr.selXfac <- gr.selXfac <- c(gr.selXfac, i)
    }
    gr.selXorder <- match(gr.selXcor, gr.selXcor)
    cortemp <- cor(XXX[, gr.selXcor])
    cortemp[cortemp == 1] <- 0
    cat("STARTING MATRIX:", "\n")
    print(cortemp)
    assign("CorMatrix", cortemp, pos = 1)
    cat(names(XXX)[gr.selXcor], "\n")
    while (max(abs(cortemp)) > 0.05) {
        cormax <- abs(cortemp) == max(abs(cortemp))
        selCor <- apply(cormax, 2, sum) * gr.selXorder
        gr.selXcor <- gr.selXcor[-match(max(selCor), selCor)]
        gr.selXorder <- gr.selXorder[-match(max(selCor), selCor)]
        cortemp <- cor(XXX[, gr.selXcor])
        cortemp[cortemp == 1] <- 0
    }
    cat("UNCORRELATED MATRIX:", "\n")
    print(cortemp)
    gr.selXCOR[[gr.Yi]] <- c(gr.selXcor, gr.selXfac)
    assign("gr.selXCOR", gr.selXCOR, pos = 1)
    cat("\n")
    cat("Matrix has been saved under CorMatrix!", "\n")
    cat("\n")
    cat(" ********** GRASP CORMAT END ********** ", "\n")
    cat("\n")
    cat("\n")
}
"grasp.datamap" <-
function (gr.Yi) 
{
    cat("\n")
    cat("*****************************************************", 
        "\n")
    cat("**********       GRASP-R grasp.datamap()   **********", 
        "\n")
    cat("********** Graph of datamap with pres/abs  **********", 
        "\n")
    cat("**********        GRASP by A. Lehmann      **********", 
        "\n")
    cat("**********      Ported to R by F. Fivaz    **********", 
        "\n")
    cat("*****************************************************", 
        "\n")
    cat("\n")
    cat(date(), "\n")
    cat("\n")
    x11()
    Yname <- names(YYY)[gr.Yi]
    cat("RESPONSE NAME: ", Yname, "\n")
    longitude <- XXX$x
    latitude <- XXX$y
    rangex <- max(longitude) - min(longitude)
    rangey <- max(latitude) - min(latitude)
    XMIN <- min(longitude) - 0.1 * rangex
    XMAX <- max(longitude) + 0.1 * rangex
    YMIN <- min(latitude) - 0.1 * rangey
    YMAX <- max(latitude) + 0.1 * rangey
    par(mfrow = c(1, 1), cex = 0.8, mai = c(0.75, 0.75, 0.75, 
        0.75))
    plot(longitude[YYY[, gr.Yi] > 0], latitude[YYY[, gr.Yi] > 
        0], pch = 1, cex = 1, xlim = c(XMIN, XMAX), ylim = c(YMIN, 
        YMAX), bty = "n", col = 2)
    points(longitude[YYY[, gr.Yi] == 0][gr.modmask[, gr.Yi] == 
        TRUE], latitude[YYY[, gr.Yi] == 0][gr.modmask[, gr.Yi] == 
        TRUE], pch = 1, col = 1, cex = 0.6)
    nbp <- as.character(length((YYY[(YYY[, gr.Yi] > 0), gr.Yi])))
    nba <- as.character(length((YYY[(YYY[, gr.Yi] == 0), gr.Yi])))
    legend(x = c(0, 0), y = c(XMAX, YMAX), legend = c(paste("Present: ", 
        nbp), paste("Absent: ", nba)), pch = c("+ . "), bty = "n", 
        cex = 0.6)
    title(main = paste(OPT$TITLE, " Datamap"), cex = 0.5)
    cat("\n")
    cat("**********        R-GRASP DATAMAP END      **********", 
        "\n")
    cat("\n")
}
"grasp.dump" <-
structure(list(value = function () 
{
    dump("grasp.in", file = "./build/grasper/R/grasp.in.R")
    dump("grasp.GUI", file = "./build/grasper/R/grasp.GUI.R")
    dump("grasp.import.GUI", file = "./build/grasper/R/grasp.import.GUI.R")
    dump("grasp.validate", file = "./build/grasper/R/grasp.validate.R")
    dump("grasp.histo", file = "./build/grasper/R/grasp.histo.R")
    dump("grasp.RvsP", file = "./build/grasper/R/grasp.RvsP.R")
    dump("grasp.datamap", file = "./build/grasper/R/grasp.datamap.R")
    dump("grasp.cormat", file = "./build/grasper/R/grasp.cormat.R")
    dump("grasp.corlim", file = "./build/grasper/R/grasp.corlim.R")
    dump("grasp.GRASS", file = "./build/grasper/R/grasp.GRASS.R")
    dump("grasp.model", file = "./build/grasper/R/grasp.model.R")
    dump("grasp.start", file = "./build/grasper/R/grasp.start.R")
    dump("grasp.scope", file = "./build/grasper/R/grasp.scope.R")
    dump("grasp.pred", file = "./build/grasper/R/grasp.pred.R")
    dump("grasp.pred.plot", file = "./build/grasper/R/grasp.pred.plot.R")
    dump("grasp.lut", file = "./build/grasper/R/grasp.lut.R")
    dump("grasp.ascii", file = "./build/grasper/R/grasp.ascii.R")
    dump("grasp.import", file = "./build/grasper/R/grasp.import.R")
    dump("grasp.about.GUI", file = "./build/grasper/R/grasp.about.GUI.R")
    dump("grasp.model.GUI", file = "./build/grasper/R/grasp.model.GUI.R")
    dump("grasp.roc", file = "./build/grasper/R/grasp.roc.R")
    dump("grasp.options.GUI", file = "./build/grasper/R/grasp.options.GUI.R")
    dump("grasp.export", file = "./build/grasper/R/grasp.export.R")
    dump("grasp.limits", file = "./build/grasper/R/grasp.limits.R")
    dump("grasp.README.GUI", file = "./build/grasper/R/grasp.README.GUI.R")
    dump("grasp.gpl.GUI", file = "./build/grasper/R/grasp.gpl.GUI.R")
    dump("grasp.TODO.GUI", file = "./build/grasper/R/grasp.TODO.GUI.R")
    dump("grasp.select.responses", file = "./build/grasper/R/grasp.select.responses.R")
    dump("grasp.select.predictors", file = "./build/grasper/R/grasp.select.predictors.R")
    dump("grasp.TODO.GUI", file = "./build/grasper/R/grasp.TODO.GUI.R")
    dump("grasp.in.GUI", file = "./build/grasper/R/grasp.TODO.in.R")
    dump("grasp.limits.GUI", file = "./build/grasper/R/grasp.limits.GUI.R")
    dump("grasp.dump", file = "./build/grasper/R/grasp.dump.R")
    dump("grasp.anova.gam", file = "./build/grasper/R/grasp.anova.gam.R")
    dump("grasp.anova.glmlist", file = "./build/grasper/R/grasp.anova.glmlist.R")
    dump("grasp.stat.anova", file = "./build/grasper/R/grasp.stat.anova.R")
    dump("grasp.step.gam", file = "./build/grasper/R/grasp.step.gam.R")
    dump("grasp.summary", file = "./build/grasper/R/grasp.summary.R")
}, visible = FALSE), .Names = c("value", "visible"))
"grasp.export" <-
function (var = gr.predmat) 
{
    cat("*****************************************************", 
        "\n")
    cat("**********        R-GRASP EXPORT           **********", 
        "\n")
    cat("********** Exporting results in txt format **********", 
        "\n")
    cat("**********      GRASP by A. Lehmann        **********", 
        "\n")
    cat("**********    Ported to R by F. Fivaz      **********", 
        "\n")
    cat("*****************************************************", 
        "\n")
    cat("\n")
    cat(date(), "\n")
    cat("\n")
    gr.Yi <- gr.selY
    Yname <- names(YYY[gr.Yi])
    cat("Response name:", Yname, "\n")
    cat("\n")
    file <- paste("pred_", Yname, ".txt", sep = "")
    gr.export <- var[, gr.Yi]
    glmax <- max(var)
    glength <- length(var)
    cat("Converting to percents (and integer)...", "\n")
    gr.export <- gr.export * 100
    gr.export <- as.integer(gr.export)
    to.export <- data.frame(x = XXXpred$x, y = XXXpred$y, pred = gr.export)
    cat("Writing file", file, "to disk...", "\n")
    write.table(to.export, file = file, sep = ",", row.names = F)
    cat("\n")
    cat("**********      R-GRASP EXPORT END         **********", 
        "\n")
    cat("\n")
}
"grasp.gpl.GUI" <-
function () 
{
    gpl.close <- function() tkdestroy(gpl)
    gpl <- tktoplevel()
    tktitle(gpl) <- "GPL Licence"
    frame1 <- tkframe(gpl)
    frame2 <- tkframe(gpl)
    frame1.yscroll <- tkscrollbar(frame1)
    frame1.text <- tktext(frame1, font = "Arial 10", yscrollcommand = paste(.Tk.ID(frame1.yscroll), 
        "set"), height = 20)
    tkconfigure(frame1.yscroll, command = paste(.Tk.ID(frame1.text), 
        "yview"))
    tkpack(frame1, frame1.text, side = "left", fill = "x")
    tkpack(frame1, frame1.yscroll, side = "right", fill = "y")
    zz <- tkopen("gpl.txt")
    zy <- tkread(zz)
    tkclose(zz)
    tkinsert(frame1.text, "end", zy)
    tkpack(frame2, tkbutton(frame2, text = "Close", font = "Arial 10", 
        command = gpl.close))
}
"grasp.histo" <-
function (gr.Yi, sX = gr.selX, nbar = 10) 
{
    cat("\n")
    cat("*****************************************************", 
        "\n")
    cat("**********           grasp.histo()         **********", 
        "\n")
    cat("**********         GRASP-R Histograms      **********", 
        "\n")
    cat("**********     GRASP by A. Lehmann et al.  **********", 
        "\n")
    cat("**********      Ported to R by F. Fivaz    **********", 
        "\n")
    cat("*****************************************************", 
        "\n")
    cat("\n")
    cat(date(), "\n")
    cat("\n")
    cat("Initializing variables... ")
    x11()
    Yname <- names(YYY)[gr.Yi]
    y <- YYY[gr.modmask[, gr.Yi], gr.Yi]
    XX <- XXX[gr.modmask[, gr.Yi], ]
    first <- TRUE
    cat("done", "\n")
    cat("Response name: ", Yname, "\n")
    cat("Opening graph window... ")
    numgr <- length(gr.selX) - 3
    par(mfrow = c(2, 4), cex = 0.65)
    prop <- length(y[y > 0])/length(y)
    cat("done", "\n")
    cat("Drawing histograms...")
    for (i in sX) {
        if (is.numeric(XX[, i])) {
            Xmin <- round(min(XX[!is.na(XX[, i]), i]), 2)
            Xlag <- (max(XX[!is.na(XX[, i]), i]) - Xmin)/nbar
            Xbreaks <- as.character(Xmin)
            for (nb in 1:(nbar - 1)) {
                Xnew <- round(Xmin + (nb * Xlag), 2)
                Xbreaks <- c(Xbreaks, as.character(Xnew))
            }
            temp <- table(factor(cut(y[!is.na(XX[, i])], c(-1, 
                1e-05, 500))), cut(XX[!is.na(XX[, i]), i], nbar))
            loc <- barplot(temp, xlab = names(XX[i]), ylab = "count", 
                names = Xbreaks)
            nbp <- as.character(length(y[y > 0]))
            if (prop < 1) {
                par(new = T)
                temp[1, temp[1, ] == 0] <- 1e-08
                fred2 <- (temp[2, ]/(temp[1, ] + temp[2, ]))/prop
                barplot(fred2, axes = FALSE, axisnames = FALSE, 
                  density = NULL, space = 0, lwd = 0.5, col = NULL)
                abline(h = 1, lty = 2)
            }
            if (first) {
                title(paste(OPT$TITLE, " histograms"))
                first <- FALSE
            }
        }
    }
    cat("done", "\n")
    cat("\n")
    cat("**********        grasp.histo() end        **********", 
        "\n")
    cat("\n")
}
"grasp.import.GUI" <-
function () 
{
    opendlgYYY <- function(...) {
	cat("\n********** WARNING **********")
	cat("\nIf you get an error related to")
	cat("\nOPT, try setting the options")
	cat("\nfirst (Edit/Set options)")
	cat("\n*****************************\n")
        file.select.YYY <- tclvalue(tkgetOpenFile(parent = import))
        print(file.select.YYY)
        assign("file.select.YYY", file.select.YYY, pos = 1)
        YYY.local <- read.delim(file = file.select.YYY, sep = OPT$SEL)
        cat("Responses saved into YYY.local", "\n")
        assign("YYY.local", YYY.local, pos = 1)
        YYY.done <- TRUE
        assign("YYY.done", YYY.done, pos = 1)
        label1.full <- paste("YYY saved from ", file.select.YYY, 
            sep = " ")
        tkinsert(frame5.lstbox, "end", label1.full)
    }
    opendlgXXX <- function(...) {
        file.select.XXX <- tclvalue(tkgetOpenFile(parent = import))
        print(file.select.XXX)
        XXX.local <- read.delim(file = file.select.XXX, sep = OPT$SEL)
        cat("Responses saved into XXX.local", "\n")
        assign("XXX.local", XXX.local, pos = 1)
        label2.full <- paste("XXX saved from ", file.select.XXX, 
            sep = " ")
        tkinsert(frame5.lstbox, "end", label2.full)
        XXX.done <- TRUE
        assign("XXX.done", XXX.done, pos = 1)
    }
    opendlgXXXpred <- function(...) {
        file.select.XXXpred <- tclvalue(tkgetOpenFile(parent = import))
        print(file.select.XXXpred)
        XXXpred.local <- read.delim(file = file.select.XXXpred, 
            sep = OPT$SEL)
        cat("Responses saved into XXXpred.local", "\n")
        assign("XXXpred.local", XXXpred.local, pos = 1)
        label3.full <- paste("XXXpred saved from ", file.select.XXXpred, 
            sep = " ")
        tkinsert(frame5.lstbox, "end", label3.full)
        XXXpred.done <- TRUE
        assign("XXXpred.done", XXXpred.done, pos = 1)
    }
    destroy.import <- function(...) {
        tkdestroy(import)
    }
    apply.import <- function(...) {
        label.applied <- NULL
        assign("YYY", YYY.local, pos = 1)
        label.applied <- paste(label.applied, "YYY", sep = " ")
        cat("YYY created...", "\n")
        assign("XXX", XXX.local, pos = 1)
        label.applied <- paste(label.applied, "XXX", sep = " ")
        cat("XXX created...", "\n")
        assign("XXXpred", XXXpred.local, pos = 1)
        label.applied <- paste(label.applied, "XXXpred", sep = " ")
        cat("XXXpred created...", "\n")
        label.applied <- paste("Import done for:", label.applied, 
            sep = " ")
        assign("label.applied", label.applied, pos = 1)
        tkinsert(frame5.lstbox, "end", label.applied)
        WEIGHTS <- data.frame(index = YYY[1], ours = rep(1, dim(XXX)[1]))
        assign("WEIGHTS", WEIGHTS, pos = 1)
        tkinsert(frame5.lstbox, "end", "Starting grasp.in...")
        grasp.in(YYY, XXX, XXXpred)
        tkinsert(frame5.lstbox, "end", "Initializing done!")
    }
    import <- tktoplevel()
    tktitle(import) <- "GraspeR data import"
    YYY.done <- FALSE
    assign("YYY.done", YYY.done, pos = 1)
    XXX.done <- FALSE
    assign("XXX.done", XXX.done, pos = 1)
    XXXpred.done <- FALSE
    assign("XXXpred.done", XXXpred.done, pos = 1)
    frame1 <- tkframe(import, relief = "groove", borderwidth = 2)
    frame2 <- tkframe(import, relief = "groove", borderwidth = 2)
    frame3 <- tkframe(import, relief = "groove", borderwidth = 2)
    frame4 <- tkframe(import, relief = "groove", borderwidth = 2)
    frame5 <- tkframe(import, relief = "groove", borderwidth = 2)
    frame1.label <- tklabel(frame1, text = "Import files into GraspeR")
    tkpack(frame1, frame1.label, fill = "x")
    frame2.label1 <- tklabel(frame2, text = "Responses (YYY):")
    frame2.label2 <- tklabel(frame2, text = "Predictors from (XXX):")
    frame2.label3 <- tklabel(frame2, text = "Predict to (XXXpred):")
    frame2.but1 <- tkbutton(frame2, text = "Import...", padx = 20, 
        command = opendlgYYY)
    frame2.but2 <- tkbutton(frame2, text = "import...", padx = 20, 
        command = opendlgXXX)
    frame2.but3 <- tkbutton(frame2, text = "import...", padx = 20, 
        command = opendlgXXXpred)
    tkgrid(frame2.label1, frame2.but1, sticky = "w")
    tkgrid(frame2.label2, frame2.but2, sticky = "w")
    tkgrid(frame2.label3, frame2.but3, sticky = "w")
    tkpack(frame2, fill = "x")
    frame5.lstbox <- tklistbox(frame5, selectmode = "single")
    tkpack(frame5, frame5.lstbox, fill = "x")
    apply.but.import <- tkbutton(frame4, text = "Apply", padx = 30, 
        command = apply.import)
    close.but.import <- tkbutton(frame4, text = "Close", padx = 30, 
        command = destroy.import)
    tkgrid(apply.but.import, close.but.import, sticky = "w")
    tkpack(frame4)
}
"grasp.import" <-
function () 
{
}
"grasp.in" <-
function (Ymat, Xmat, Xpred) 
{
    cat("\n")
    cat("*****************************************************", 
        "\n")
    cat("**********           R-GRASP IN            **********", 
        "\n")
    cat("**********       Initializes variables     **********", 
        "\n")
    cat("**********        GRASP by A. Lehmann      **********", 
        "\n")
    cat("**********      Ported to R by F. Fivaz    **********", 
        "\n")
    cat("*****************************************************", 
        "\n")
    cat("\n")
    cat(date(), "\n")
    cat("\n")
    cat("Loading libraries... ")
    library(mgcv)
    library(MASS)
    library(stats)
    cat("done", "\n")
    cat("Creating YYY... ")
    assign("YYY", Ymat, pos = 1)
    cat("done", "\n")
    cat("Creating STEPMODEL... ")
    STEPMODEL <- list(gam(rep(c(0, 1), 50) ~ runif(100, 0, 10), 
        family = binomial()))
    assign("STEPMODEL", STEPMODEL, pos = 1)
    assign("gam.start", STEPMODEL, pos = 1)
    cat("done", "\n")
    cat("Creating gr.selim...")
    assign("gr.selim", c(0), pos = 1)
    cat("done", "\n")
    cat("Creating XXX... ")
    XXX <- Xmat
    assign("XXX", Xmat, pos = 1)
    cat("done", "\n")
    cat("Creating XXXpred... ")
    assign("XXXpred", Xpred, pos = 1)
    cat("done", "\n")
    cat("Initializing gr.selX and gr.selY... ")
    SELXCOR <- NULL
    assign("gr.selY", c(2:length(Ymat)), pos = 1)
    assign("gr.selX", c(4:length(Xmat)), pos = 1)
    assign("selX", gr.selX, pos = 1)
    cat("done", "\n")
    cat("Selected responses (gr.selY): ", gr.selY, "\n")
    cat("Selected predictors (gr.selX): ", gr.selX, "\n")
    cat("Removing past variables if exist... ")
    OPT <- NULL
    assign("OPT", OPT, pos = 1)
    gr.selXCOR = XXX
    assign("gr.selXCOR", gr.selXCOR, pos = 1)
    gr.selXCOR <- XXX
    cat("done", "\n")
    cat("Creating gr.modmask...")
    modcol <- length(YYY)
    modrow <- length(YYY[, 1])
    gr.modmask <- matrix(TRUE, ncol = dim(YYY)[2], nrow = dim(YYY)[1])
    assign("gr.modmask", gr.modmask, pos = 1)
    cat("done", "\n")
    cat("Creating gr.predmask...")
    gr.predmask <- matrix(rep(T, dim(XXXpred)[1] * dim(YYY)[2]), 
        ncol = dim(YYY)[2])
    assign("gr.predmask", gr.predmask, pos = 1)
    cat("done", "\n")
    cat("Creating gr.predmat...")
    gr.predmat <- as.data.frame(matrix(as.single(rep(-99.9, dim(XXXpred)[1] * 
        dim(YYY)[2])), ncol = dim(YYY)[2]))
    assign("gr.predmat", gr.predmat, pos = 1)
    fixed <- rep(1, dim(XXX)[1] * dim(YYY)[2])
    assign("fixed", fixed, pos = 1)
    cat("done", "\n")
    Yname <- names(YYY[gr.selY])
    cat("SELECTED RESPONSES:", Yname, "\n")
    WEIGHTS <- data.frame(index = YYY[1], Yname = rep(1, dim(XXX)[1]))
    assign("WEIGHTS", WEIGHTS, pos = 1)
    cat("GRASP-R initialized!", "\n")
    cat("\n")
    cat("**********         R-GRASP IN END          **********", 
        "\n")
    cat("\n")
}
"grasp.limits.GUI" <-
function () 
{
    limits.close <- function(...) {
        tkdestroy(limits)
    }
    apply.limits <- function() {
        nlim <- tkcurselection(frame2.lstbox1)
        nlim <- tclvalue(nlim)
        write(nlim, file = "lim")
        nlim <- scan(file = "lim")
        sX.loc <- nlim + 1
        npast.loc <- as.numeric(tclvalue(npast))
        grasp.limits(gr.selY, sX = sX.loc, npast = npast.loc)
        assign("gr.selim", sX.loc, pos = 1)
        cat("Limits applied!", "\n")
    }
    limits <- tktoplevel()
    tktitle(limits) <- "GraspeR: Set limits"
    npast <- tclVar("10")
    frame1 <- tkframe(limits, relief = "groove", borderwidth = 2)
    frame2 <- tkframe(limits, relief = "groove", borderwidth = 2)
    frame3 <- tkframe(limits, relief = "groove", borderwidth = 2)
    frame4 <- tkframe(limits, relief = "groove", borderwidth = 2)
    frame1.label1 <- tklabel(frame1, text = "Set limits", justify = "left", 
        wraplength = 200, font = "Arial 11")
    tkgrid(frame1.label1, columnspan = 2)
    frame1.label2 <- tklabel(frame1, text = "This function restricts the data within limits defined for the below selected response variables (min. 2) by keeping the below given number of zeroes observations on each side of the last presence along selected predictors.", 
        font = "Arial 9", wraplength = 200)
    tkgrid(frame1.label2, columnspan = 2)
    tkpack(frame1, fill = "x")
    frame4.label3 <- tklabel(frame4, text = "npast", font = "Arial 9")
    frame4.entry1 <- tkentry(frame4, textvariable = npast, font = "Arial 9")
    tkgrid(frame4.label3, frame4.entry1)
    tkpack(frame4, fill = "x")
    frame2.yscroll <- tkscrollbar(frame2)
    frame2.lstbox1 <- tklistbox(frame2, selectmode = "multiple", 
        exportselection = FALSE)
    tkconfigure(frame2.lstbox1, yscrollcommand = paste(.Tk.ID(frame2.yscroll), 
        "set"))
    tkconfigure(frame2.yscroll, command = paste(.Tk.ID(frame2.lstbox1), 
        "yview"))
    for (i in c(1:length(XXX))) {
        tkinsert(frame2.lstbox1, "end", names(XXX)[i])
    }
    gr.selim0 <- gr.selim - 1
    for (i in gr.selim0) tkselection.set(frame2.lstbox1, i)
    tkgrid(frame2.lstbox1, frame2.yscroll)
    tkpack(frame2, fill = "y")
    apply.but <- tkbutton(frame3, text = "Apply", command = apply.limits)
    close.but <- tkbutton(frame3, text = "Close", command = limits.close)
    tkgrid(apply.but, close.but, sticky = "w")
    tkpack(frame3, fill = "x")
}
"grasp.limits" <-
function (gr.Yi, sX = OPTIONS$SELXLIM, npast = OPTIONS$NPAST, 
    lim = "and") 
{
    gr.modmask <- gr.modmask
    gr.predmask <- gr.predmask
    Yname <- names(YYY)[gr.Yi]
    cat("\n")
    cat(" vvvvvvvvvv GRASP LIMITS vvvvvvvvvv ", "\n")
    cat(date(), "\n")
    cat("RESPONSE NAME: ", Yname, "\n")
    cat("\n")
    response <- YYY[, gr.Yi]
    if (is.na(sX)) 
        stop("no limiting predictors were defined in GRASP OPTIONS")
    if (min(response) != 0) 
        stop("there is no response equal to 0, limits can not be calculated !", 
            "\n")
    predictor <- XXX[, sX]
    n.numerics <- 0
    n.factors <- 0
    max.levels <- 0
    limitlabels <- NULL
    countlabels <- NULL
    for (i in 1:length(sX)) {
        if (i == 1) {
            limitlabels <- append(limitlabels, names(predictor)[i], 
                n.numerics)
            n.numerics <- n.numerics + 1
        }
        else {
            limitlabels <- append(limitlabels, names(predictor)[i], 
                n.numerics)
            n.numerics <- n.numerics + 1
        }
    }
    cat("Number of variables: ", length(sX), fill = T)
    cat("Number of numerics: ", n.numerics, fill = T)
    cat("Number of factors: ", n.factors, fill = T)
    if (lim == "or") {
        mask <- rep(FALSE, length(response))
        predict.template <- rep(0, length(XXXpred[, 1]))
    }
    else {
        mask <- rep(TRUE, length(response))
        predict.template <- rep(1, length(XXXpred[, 1]))
    }
    if (lim == "mixte") {
        mask2 <- rep(FALSE, length(response))
        predict.template2 <- rep(0, length(XXXpred[, 1]))
    }
    limits <- matrix(0, nrow = n.numerics, ncol = 3)
    dimnames(limits) <- list(limitlabels, c("lower", "upper", 
        "mean"))
    counts <- matrix(0, nrow = n.factors, ncol = max.levels)
    dimnames(counts) <- list(countlabels, NULL)
    n.numerics <- 0
    n.factors <- 0
    for (i in 1:length(sX)) {
        n.numerics <- n.numerics + 1
        sorted <- cbind(predictor[order(predictor[, i], response), 
            i], response[order(predictor[, i], response)])
        j <- seq(along = sorted[, 1])
        min.pos <- min(j[sorted[, 2] > 0])
        min.pos2 <- max(1, min.pos)
        min.pos <- max(1, min.pos - npast)
        lower.limit <- sorted[min.pos, 1]
        lower.limit2 <- sorted[min.pos2, 1]
        sorted <- cbind(predictor[order(predictor[, i], 0 - response), 
            i], response[order(predictor[, i], 0 - response)])
        j <- seq(along = sorted[, 1])
        max.pos <- max(j[sorted[, 2] > 0])
        max.pos2 <- min(length(sorted[, 1]), max.pos)
        max.pos <- min(length(sorted[, 1]), max.pos + npast)
        upper.limit <- sorted[max.pos, 1]
        upper.limit2 <- sorted[max.pos2, 1]
        if (lim == "and") {
            mask[predictor[, i] < lower.limit] <- FALSE
            mask[predictor[, i] > upper.limit] <- FALSE
            k <- match(names(predictor)[i], names(XXXpred))
            predict.template[XXXpred[, k] > upper.limit] <- 0
            predict.template[XXXpred[, k] < lower.limit] <- 0
        }
        if (lim == "or") {
            mask[(predictor[, i] > lower.limit) & (predictor[, 
                i] < upper.limit)] <- TRUE
            k <- match(names(predictor)[i], names(XXXpred))
            predict.template[(XXXpred[, k] > lower.limit) & (XXXpred[, 
                k] < upper.limit)] <- 1
        }
        if (lim == "mixte") {
            mask[predictor[, i] < lower.limit2] <- FALSE
            mask[predictor[, i] > upper.limit2] <- FALSE
            mask2[(predictor[, i] > lower.limit) & (predictor[, 
                i] < lower.limit2)] <- TRUE
            mask2[(predictor[, i] > upper.limit2) & (predictor[, 
                i] < upper.limit)] <- TRUE
            k <- match(names(predictor)[i], names(XXXpred))
            predict.template[XXXpred[, k] > upper.limit2] <- 0
            predict.template[XXXpred[, k] < lower.limit2] <- 0
            predict.template2[(XXXpred[, k] > lower.limit) & 
                (XXXpred[, k] < lower.limit2)] <- 1
            predict.template2[(XXXpred[, k] > upper.limit2) & 
                (XXXpred[, k] < upper.limit)] <- 1
        }
        limits[n.numerics, ] <- c(zapsmall(lower.limit, 4), zapsmall(upper.limit, 
            4), zapsmall(mean(predictor[response > 0, i]), 4))
        cat("Lower and upper limits, and occupied mean for ", 
            names(predictor[i]), " are ", limits[n.numerics, 
                ], fill = T)
        limits2 <- limits
        limits2[n.numerics, ] <- c(zapsmall(lower.limit2, 4), 
            zapsmall(upper.limit2, 4), zapsmall(mean(predictor[response > 
                0, i]), 4))
    }
    if (lim == "mixte") {
        mask <- mask | mask2
        predict.template <- predict.template | predict.template2
    }
    excluded <- length(mask[mask == FALSE])
    cat("Limits of models (gr.modmask) set and ", excluded, " cases excluded", 
        fill = T)
    gr.modmask[, gr.Yi] <- as.logical(mask)
    assign("gr.modmask", gr.modmask, pos = 1)
    excluded2 <- length(predict.template[predict.template == 
        FALSE])
    cat("Limits of prediction (gr.predmask) set and ", excluded2, 
        " cases excluded", fill = T)
    gr.predmask[, gr.Yi] <- as.logical(predict.template)
    assign("gr.predmask", gr.predmask, pos = 1)
    cat("\n")
    cat(" ********** GRASP LIMITS END ********** ", "\n")
    cat("\n")
}
"grasp.lut" <-
function (gr.Yi, gam.model = gam.start, path = "pred1.lut") 
{
    Yname <- names(YYY)[gr.Yi]
    cat("\n")
    cat(" vvvvvvvvvv GRASP LOOKUP vvvvvvvvvv ", "\n")
    cat(date(), "\n")
    cat("RESPONSE NAME: ", Yname, "\n")
    artificial <- as.data.frame(matrix(rep(1, 200 * length(gr.selX)), 
        200, length(gr.selX)))
    flist <- list(c(0, 0))
    for (i in 1:length(gr.selX)) if (!is.factor(XXX[, gr.selX[i]])) {
        artificial[, i] <- seq(min(XXXpred[, gr.selX[i]]), max(XXXpred[, 
            gr.selX[i]]), length = 200)
    }
    else {
        cat("INFO: !!! your factor map in Arcview will have to be reclassify according to the factor levels presented here:", 
            "\n")
        print(levels(XXX[gr.modmask[, gr.Yi], gr.selX[i]]))
        for (f in 1:length(levels(XXX[, gr.selX[i]]))) {
            if (summary(XXX[gr.modmask[, gr.Yi], gr.selX[i]])[f][1] > 
                0) {
                artificial[f, i] <- levels(XXX[, gr.selX[i]])[f]
                flist[[gr.selX[i]]] <- c(flist[[gr.selX[i]]], 
                  f)
            }
        }
        for (f in 1:length(levels(XXX[, gr.selX[i]]))) {
            if (summary(XXX[gr.modmask[, gr.Yi], gr.selX[i]])[f][1] == 
                0) 
                artificial[f, i] <- levels(XXX[, gr.selX[i]])[flist[[gr.selX[i]]][1]]
        }
        artificial[-flist[[gr.selX[i]]], i] <- levels(XXX[, gr.selX[i]])[flist[[gr.selX[i]]][1]]
        artificial[, i] <- as.factor(artificial[, i])
        print(flist[[gr.selX[i]]])
    }
    dimnames(artificial) <- list(1:200, names(XXX[, gr.selX]))
    print(artificial[c(1:5), ])
    cat("", "\n")
    print(artificial[c(196:200), ])
    assign("artificial", artificial, pos = 1)
    LUT <- matrix(0, nrow = 204, ncol = length(gr.selX) + 1)
    LUT[1:204, 1] <- seq(1, 204)
    LUT.SE <- LUT
    tempse <- predict(gam.model, artificial, se.fit = T, type = "terms")
    term.matrix <- tempse$fit
    se.matrix <- tempse$se.fit
    assign("term.matrix", term.matrix, pos = 1)
    assign("se.matrix", se.matrix, pos = 1)
    mod.terms <- dimnames(gam.model$model)[[2]]
    j <- 0
    for (term1 in names(XXX[gr.selX])) {
        pos1 <- grep(term1, names(XXX[gr.selX])) + 1
        testx <- term1
        pos2 <- pmatch(testx, mod.terms)
        pos3 <- pmatch(term1, names(XXX))
        if (!(pmatch(testx, mod.terms, nomatch = "nomatch") == 
            "nomatch")) {
            LUT[1:200, pos1] <- zapsmall(term.matrix[pos2, 1:200], 
                6)
            j <- j + 1
            LUT.SE[1:200, pos1] <- zapsmall(se.matrix[pos2, 1:200], 
                6)
        }
        else {
            LUT[1:200, pos1] <- rep(0, 200)
            LUT.SE[1:200, pos1] <- rep(0, 200)
        }
        if (!is.factor(XXX[, pos3])) {
            LUT[201, pos1] <- min(XXXpred[, pos3])
            LUT[202, pos1] <- max(XXXpred[, pos3])
            LUT[203, pos1] <- 200
            LUT[204, pos1] <- zapsmall(term.matrix[1, 1], 6)
        }
        else {
            pos4 <- pmatch(term1, mod.terms)
            LUT[, pos1] <- as.single(LUT[, pos1])
            LUT.SE[, pos1] <- as.single(LUT[1:200, pos1])
            if (!is.na(pmatch(term1, mod.terms))) {
                print(term1)
                LUT[1:200, pos1] <- zapsmall(term.matrix[1:200, 
                  pos4], 6)
                LUT[-flist[[gr.selX[pos1]]], pos1] <- 0
                j <- j + 1
                fac.se <- NULL
                ranklevel <- 1
                for (level in levels(XXX[, pos3])) {
                  fac.se[ranklevel] <- tempse[[pos4]]$se.y[tempse[[pos4]]$x == 
                    level][1]
                  ranklevel <- ranklevel + 1
                }
                LUT.SE[1:length(levels(XXX[, pos3])), pos1] <- zapsmall(fac.se, 
                  6)
                LUT.SE[-flist[[gr.selX[pos1]]], pos1] <- 0
            }
            else {
                cat(term1, "\n")
                cat("FACTOR OUT", "\n")
                LUT[1:200, pos1] <- rep(0, 200)
                LUT.SE[1:200, pos1] <- rep(0, 200)
            }
            LUT[201, pos1] <- 1
            LUT[202, pos1] <- length(levels(XXX[, pos3]))
            LUT[203, pos1] <- length(levels(XXX[, pos3]))
            LUT[204, pos1] <- zapsmall(attr(term.matrix, "constant"), 
                6)
        }
    }
    LUT.SE[201:204, ] <- LUT[201:204, ]
    dimnames(LUT) <- list(NULL, c("row.names", names(XXX)[gr.selX]))
    dimnames(LUT.SE) <- list(NULL, c("row.names", names(XXX)[gr.selX]))
    cat("LUT prediction:", "\n")
    print(LUT[c(1:5), ])
    cat("", "\n")
    print(LUT[c(196:200), ])
    cat("LUT standard error:", "\n")
    print(LUT.SE[c(1:5), ])
    cat("", "\n")
    print(LUT.SE[c(196:200), ])
    pathlut <- paste(path, Yname, "_lut.txt", sep = "")
    print(pathlut)
    write.table(LUT, file = pathlut, sep = "    ", quote = FALSE, 
        row.names = FALSE)
    pathse <- paste(path, Yname, "_se.txt", sep = "")
    print(pathse)
    write.table(LUT.SE, file = pathse, sep = "  ", quote = FALSE, 
        row.names = FALSE)
}
"grasp.model.GUI" <-
function () 
{
    kill.MODEL <- function() {
        tkdestroy(MODEL)
    }
    go.model <- function(...) {
        step.fam <- c("gaussian()", "quasibinomial()", "quasibinomial()", 
            "quasipoisson()")
        step.test <- c("Chisq", "F", "F", "F")
        model.auto$test <- tkcurselection(frame2.list1)
        model.auto$test <- tclvalue(model.auto$test)
        model.auto$family <- step.fam[as.numeric(model.auto$test) + 
            1]
        model.auto$test <- step.test[as.numeric(model.auto$test) + 
            1]
        model.auto$direction <- tkcurselection(frame2.list2)
        model.auto$direction <- tclvalue(model.auto$direction)
        model.auto$direction <- dirselect[as.numeric(model.auto$direction) + 
            1]
        model.auto$resolution <- as.numeric(tclvalue(MODEL.RESOLUTION))
        model.auto$plimit <- as.numeric(tclvalue(MODEL.P.LIMIT))
        model.auto$steps <- as.numeric(tclvalue(MODEL.STEPS))
        model.auto$df <- as.numeric(tclvalue(MODEL.DF))
        model.auto$stepit <- as.logical(tclvalue(MODEL.STEP.IT))
        model.auto$verbose <- as.logical(tclvalue(MODEL.VERBOSE))
        model.auto$auto.df <- as.logical(tclvalue(MODEL.AUTO.DF))
        model.auto$predictit <- as.logical(tclvalue(MODEL.DO.PRED))
        model.auto$plotpredictit <- as.logical(tclvalue(MODEL.PLOT.PRED))
        assign("model.auto", model.auto, pos = 1)
        grasp.model(gr.Yi, trace = model.auto$verbose, df = model.auto$df, 
            calcdf = model.auto$auto.df, stepfam = model.auto$family)
        grasp.scope(gr.selX, df = model.auto$df, calcdf = model.auto$auto.df)
        if (model.auto$stepit) 
            grasp.step.gam(direction = model.auto$direction, 
                steps = model.auto$steps, trace = model.auto$model.auto$verbose, 
                limit = model.auto$plimit, test = model.auto$test)
        if (model.auto$predictit) 
            grasp.pred()
        if (model.auto$plotpredictit) 
            grasp.pred.plot(gr.predmat, resolution = model.auto$resolution)
        assign("model.auto", model.auto, pos = 1)
    }
    MODEL <- tktoplevel()
    tktitle(MODEL) <- "GraspeR variable selection, model and predictions"
    model.auto <- vector("list", 12)
    names(model.auto) <- c("stepit", "predictit", "plotpredictit", 
        "direction", "test", "plimit", "steps", "verbose", "family", 
        "df", "auto.df", "resolution")
    stepselect <- c("Biomass, size, ...", "Presence / absence", 
        "Cover, %, ...", "Richness, Abundance, ...")
    dirselect <- c("both", "backward", "forward")
    famselect <- c("Gaussian", "Poisson", "Binomial", "Quasibinomial")
    MODEL.P.LIMIT <- tclVar("0.05")
    MODEL.STEPS <- tclVar(1000)
    MODEL.VERBOSE <- tclVar("FALSE")
    MODEL.STEP.IT <- tclVar("TRUE")
    MODEL.DF <- tclVar(4)
    MODEL.AUTO.DF <- tclVar("FALSE")
    MODEL.DO.PRED <- tclVar("TRUE")
    MODEL.PLOT.PRED <- tclVar("TRUE")
    MODEL.RESOLUTION <- tclVar(1000)
    frame1 <- tkframe(MODEL, relief = "groove", borderwidth = 2)
    frame2 <- tkframe(MODEL, relief = "groove", borderwidth = 2)
    frame3 <- tkframe(MODEL, relief = "groove", borderwidth = 2)
    frame4 <- tkframe(MODEL, relief = "groove", borderwidth = 2)
    frame5 <- tkframe(MODEL, relief = "groove", borderwidth = 2)
    frame1.label1 <- tklabel(frame1, text = "GraspeR Modeling", 
        font = "Arial 11")
    frame1.label2 <- tklabel(frame1, text = "This window lets you define and execute the modelling steps", 
        font = "Arial 10", wraplength = 280)
    tkpack(frame1, frame1.label1, frame1.label2, fill = "x")
    frame2.label1 <- tklabel(frame2, text = "Stepwise selection", 
        font = "Arial 11")
    tkgrid(frame2.label1, columnspan = 2)
    frame2.label21 <- tklabel(frame2, text = "Check to do the stepwise selection", 
        font = "Arial 10")
    frame2.check2 <- tkcheckbutton(frame2, variable = MODEL.STEP.IT, 
        height = 1, offvalue = "FALSE", onvalue = "TRUE")
    tkgrid(frame2.label21, frame2.check2)
    frame2.label2 <- tklabel(frame2, text = "Select the kind of data you have", 
        font = "Arial 10")
    tkgrid(frame2.label2, columnspan = 2)
    frame2.list1 <- tklistbox(frame2, selectmode = "single", 
        height = 4, font = "Arial 10", exportselection = FALSE, 
        width = 25)
    for (i in 1:4) {
        tkinsert(frame2.list1, "end", stepselect[i])
    }
    tkselection.set(frame2.list1, 1)
    tkgrid(frame2.list1, columnspan = 2)
    frame2.labela <- tklabel(frame2, text = "Double-click on the selection above to see test and family for the associated data type", 
        font = "Arial 10", wraplength = 250)
    tkgrid(frame2.labela, columnspan = 2)
    frame2.entrya <- tkentry(frame2, width = 10, font = "Arial 10", 
        state = "disabled", text = "Quasibinomial")
    frame2.entryb <- tkentry(frame2, width = 15, font = "Arial 10", 
        state = "disabled", text = "F")
    tkgrid(frame2.entrya, frame2.entryb)
    frame2.label3 <- tklabel(frame2, text = "Direction", font = "Arial 10")
    tkgrid(frame2.label3, columnspan = 2)
    frame2.list2 <- tklistbox(frame2, selectmode = "single", 
        height = 3, font = "Arial 10", exportselection = FALSE)
    for (i in 1:3) {
        tkinsert(frame2.list2, "end", dirselect[i])
    }
    tkselection.set(frame2.list2, 0)
    tkgrid(frame2.list2, columnspan = 2)
    frame2.label4 <- tklabel(frame2, text = "P.limit for selection", 
        font = "Arial 10")
    frame2.entry1 <- tkentry(frame2, textvariable = MODEL.P.LIMIT, 
        width = 10, justify = "left", font = "Arial 10")
    tkgrid(frame2.label4, frame2.entry1)
    frame2.label5 <- tklabel(frame2, text = "Number of steps", 
        font = "Arial 10")
    frame2.entry2 <- tkentry(frame2, textvariable = MODEL.STEPS, 
        width = 10, justify = "left", font = "Arial 10 ")
    tkgrid(frame2.label5, frame2.entry2)
    frame2.label6 <- tklabel(frame2, text = "Check to force verbose output", 
        font = "Arial 10")
    frame2.check1 <- tkcheckbutton(frame2, variable = MODEL.VERBOSE, 
        height = 1, offvalue = "FALSE", onvalue = "TRUE")
    tkgrid(frame2.label6, frame2.check1)
    tkpack(frame2, fill = "x")
    frame3.label1 <- tklabel(frame3, text = "Modeling using GAMs", 
        font = "Arial 11")
    tkgrid(frame3.label1, columnspan = 2)
    frame3.label2 <- tklabel(frame3, text = "Family depends on the selections above", 
        font = "Arial 10")
    tkgrid(frame3.label2, columnspan = 2)
    frame3.label3 <- tklabel(frame3, text = "Smoothing degrees of freedom", 
        font = "Arial 10")
    frame3.entry1 <- tkentry(frame3, textvariable = MODEL.DF, 
        width = 10, justify = "left", font = "Arial 10")
    tkgrid(frame3.label3, frame3.entry1)
    frame3.label4 <- tklabel(frame3, text = "Let the gam function calculate df", 
        font = "Arial 10")
    frame3.check3 <- tkcheckbutton(frame3, variable = MODEL.AUTO.DF, 
        height = 1, offvalue = "FALSE", onvalue = "TRUE")
    tkgrid(frame3.label4, frame3.check3)
    tkpack(frame3, fill = "x")
    frame4.label1 <- tklabel(frame4, text = "Predict", font = "Arial 11")
    tkgrid(frame4.label1, columnspan = 2)
    frame4.label2 <- tklabel(frame4, text = "Check to calculate predictions", 
        font = "Arial 10")
    frame4.check1 <- tkcheckbutton(frame4, variable = MODEL.DO.PRED, 
        height = 1, offvalue = "FALSE", onvalue = "TRUE")
    tkgrid(frame4.label2, frame4.check1)
    frame4.label3 <- tklabel(frame4, text = "Check to plot predictions", 
        font = "Arial 10")
    frame4.check2 <- tkcheckbutton(frame4, variable = MODEL.PLOT.PRED, 
        height = 1, offvalue = "FALSE", onvalue = "TRUE")
    tkgrid(frame4.label3, frame4.check2)
    frame4.label4 <- tklabel(frame4, text = "Resolution for output", 
        font = "Arial 10")
    frame4.entry1 <- tkentry(frame4, textvariable = MODEL.RESOLUTION, 
        width = 10, justify = "left", font = "Arial 10")
    tkgrid(frame4.label4, frame4.entry1)
    tkpack(frame4, fill = "x")
    frame5.but1 <- tkbutton(frame5, text = "Gogogooo!", padx = 40, 
        font = "Arial 10", command = go.model)
    frame5.but2 <- tkbutton(frame5, text = "Loosing my time!", 
        padx = 40, font = "Arial 10", command = kill.MODEL)
    tkgrid(frame5.but1, frame5.but2)
    tkpack(frame5, fill = "x")
    tkbind(frame2.list1, "<1>", function() {
        step.fam <- c("Gaussian", "Quasibinomial", "Quasibinomial", 
            "Quasipoisson")
        step.test <- c("Chisq", "F", "F", "F")
        mod.test <- tkcurselection(frame2.list1)
        mod.test <- tclvalue(mod.test)
        mod.test.local <- tclVar(step.test[as.numeric(mod.test) + 
            1])
        mod.fam <- tclVar(step.fam[as.numeric(mod.test) + 1])
        tkconfigure(frame2.entrya, textvariable = mod.test.local)
        tkconfigure(frame2.entryb, textvariable = mod.fam)
    })
}
"grasp.model" <-
function (gr.Yi = gr.Yi, cX = gr.selX, optest = "F", df = 4, 
    trace = TRUE, calcdf = FALSE, stepfam = "quasibinomial()") 
{
    if (trace) {
        cat("\n")
        cat("*****************************************************", 
            "\n")
        cat("**********          R-GRASP MODEL          **********", 
            "\n")
        cat("**********       Modelling using gam()     **********", 
            "\n")
        cat("**********        GRASP by A. Lehmann      **********", 
            "\n")
        cat("**********      Ported to R by F. Fivaz    **********", 
            "\n")
        cat("*****************************************************", 
            "\n")
        cat("\n")
        cat(date(), "\n")
        cat("\n")
        cat("Initializing variables... ")
    }
    Yname <- names(YYY[gr.Yi])
    gr.selYCOR <- gr.Yi
    gr.selXCOR <- list(gr.selY)
    for (i in gr.Yi) {
        gr.selXCOR[[i]] <- gr.selX
    }
    gr.selXCOR <- gr.selXCOR
    assign("gr.selXCOR", gr.selXCOR, pos = 1)
    assign("gr.Yi", gr.Yi, pos = 1)
    if (trace) {
        cat("done", "\n")
        cat("\n")
        assign("Yname", Yname, pos = 1)
        cat("RESPONSE NAME: ", Yname, "\n")
    }
    if (((stepfam == "binomial") | (stepfam == "quasi")) & ((max(YYY[, 
        gr.Yi]) > 1) | (min(YYY[, gr.Yi]) < 0))) {
        stop("DATA OUT OF RANGE [0,1] TO USE A BINOMIAL MODEL !")
    }
    mkt.keep.AIC <- function(object, AIC) {
        list(df.resid = object$df.resid, deviance = object$deviance, 
            term = as.character(object$formula)[3], AIC = AIC)
    }
    mkt.keep.p <- function(object, pvalue) {
        list(df.resid = object$df.resid, deviance = object$deviance, 
            term = as.character(object$formula)[3], pvalue = pvalue)
    }
    for (xi in gr.selXCOR[[gr.Yi]]) {
        if (is.factor(XXX[, xi]) & length(levels(XXX[, xi])) < 
            2) {
            gr.selXCOR[[gr.Yi]] <- gr.selXCOR[[gr.Yi]][-match(xi, 
                gr.selXCOR[[gr.Yi]])]
            print(paste("factor", names(XXX)[xi], "was removed from the potential predictors of", 
                names(YYY)[gr.Yi], "because it has less than two levels"))
        }
    }
    grasp.scope(gr.selXCOR[[gr.Yi]], trace = FALSE)
    grasp.start(cX, sX = gr.selXCOR[[gr.Yi]], df = df, trace = FALSE, 
        calcdf = calcdf)
    START <- model.formula
    assign("model.formula", model.formula, pos = 1)
    XXX <- XXX[gr.modmask[, gr.Yi], ]
    YYY <- YYY[gr.modmask[, gr.Yi], ]
    WEIGHTS.df <- paste("WEIGHTS[gr.modmask[, ", gr.Yi, "], ", 
        gr.Yi, "]")
    gam.start <- eval(parse(text = paste("gam(", as.character(START[2]), 
        "~", as.character(START[3]), ", family = ", stepfam, 
        ",data = XXX", ", weights = ", WEIGHTS.df, ", control = gam.control(maxit = 50, epsilon=0.001))")))
    assign("gam.start", gam.start, pos = 1)
    STEPMODEL[[gr.Yi]] <- gam.start
    assign("STEPMODEL", STEPMODEL, pos = 1)
    if (trace) 
        cat("Ploting results...", "\n")
    plot.gam(gam.start, pages = 1, scale = 0, n = 1000)
    if (trace) {
        cat("SUMMARY OF MODEL", "\n")
        summary.gam(gam.start)
        cat("\n")
        cat("**********        R-GRASP MODEL END        **********", 
            "\n")
        cat("\n")
    }
}
"grasp.options.GUI" <-
function (...) 
{
    options.apply <- function(...) {
        apply.ok <- TRUE
        assign("apply.ok", apply.ok, pos = 1)
        OPT <- list()
        OPT$TITLE <- as.character(tclvalue(OPTIONS.TITLE))
        OPT$LAYOUT <- eval(parse(text = as.character(tclvalue(OPTIONS.LAYOUT))))
        OPT$NBBARS <- as.integer(tclvalue(OPTIONS.NBBARS))
        OPT$WEIGHTS <- as.character(tclvalue(OPTIONS.WEIGHTS))
        OPT$RESOLUTION <- as.numeric(tclvalue(OPTIONS.RESOLUTION))
        OPT$SEP <- as.character(tclvalue(OPTIONS.SEP))
        print(OPT)
        assign("OPT", OPT, pos = 1)
        cat("Options set!", "\n")
    }
    options.default <- function(...) {
        OPT.DEFAULT <- NULL
        OPT <- OPT.DEFAULT
        assign("OPT", OPT, pos = 1)
        cat("Options set to default", "\n")
    }
    options.close <- function() {
        tkdestroy(OPTIONS)
    }
    OPTIONS <- tktoplevel()
    tktitle(OPTIONS) <- "R-GRASP options"
    apply.ok <- FALSE
    assign("apply.ok", apply.ok, pos = 1)
    OPTIONS.TITLE <- tclVar("R-GRASP: ")
    OPTIONS.LAYOUT <- tclVar("c(3,3)")
    OPTIONS.NBBARS <- tclVar(10)
    OPTIONS.WEIGHTS <- tclVar("WEIGHTS")
    OPTIONS.RESOLUTION <- tclVar(1000)
    OPTIONS.SELX <- tclVar("c(4,5,6,7,8,9,10,11)")
    OPTIONS.SEP <- tclVar(" ")
    frame1 <- tkframe(OPTIONS, relief = "groove", borderwidth = 2)
    frame2 <- tkframe(OPTIONS, relief = "groove", borderwidth = 2)
    frame3 <- tkframe(OPTIONS, relief = "groove", borderwidth = 2)
    frame1.label1 <- tklabel(frame1, text = "GraspeR Options", 
        font = "Arial 11")
    frame1.label2 <- tklabel(frame1, text = "This window lets you define the options", 
        font = "arial 10")
    tkpack(frame1, frame1.label1, frame1.label2, fill = "x")
    frame2.main <- tklabel(frame2, text = "General options", 
        font = "arial 10", justify = "center")
    frame2.label1 <- tklabel(frame2, text = "Title", font = "arial 10")
    frame2.label2 <- tklabel(frame2, text = "Layout", font = "arial 10")
    frame2.label3 <- tklabel(frame2, text = "Nb. of bars", font = "arial 10")
    frame2.label4 <- tklabel(frame2, text = "Weights", font = "arial 10")
    frame2.label5 <- tklabel(frame2, text = "Resolution", font = "arial 10")
    frame2.label6 <- tklabel(frame2, text = "Separator for text files", 
        font = "arial 10")
    frame2.entry1 <- tkentry(frame2, textvariable = OPTIONS.TITLE, 
        width = 20, justify = "left")
    frame2.entry2 <- tkentry(frame2, textvariable = OPTIONS.LAYOUT, 
        width = 20, justify = "left")
    frame2.entry3 <- tkentry(frame2, textvariable = OPTIONS.NBBARS, 
        width = 20, justify = "left")
    frame2.entry4 <- tkentry(frame2, textvariable = OPTIONS.WEIGHTS, 
        width = 20, justify = "left")
    frame2.entry5 <- tkentry(frame2, textvariable = OPTIONS.RESOLUTION, 
        width = 20, justify = "left")
    frame2.entry6 <- tkentry(frame2, textvariable = OPTIONS.SEP, 
        width = 20, justify = "left")
    tkgrid(frame2.main, columnspan = 2, sticky = "w")
    tkgrid(frame2.label1, frame2.entry1, sticky = "w")
    tkgrid(frame2.label2, frame2.entry2, sticky = "w")
    tkgrid(frame2.label3, frame2.entry3, sticky = "w")
    tkgrid(frame2.label4, frame2.entry4, sticky = "w")
    tkgrid(frame2.label5, frame2.entry5, sticky = "w")
    tkgrid(frame2.label6, frame2.entry6, sticky = "w")
    tkpack(frame2, fill = "x")
    apply.but <- tkbutton(frame3, text = "Apply", command = options.apply, 
        padx = 40, font = "arial 10")
    defaults.but <- tkbutton(frame3, text = "Defaults", command = options.default, 
        padx = 40, font = "arial 10")
    close.but <- tkbutton(frame3, text = "Close", command = options.close, 
        padx = 40, font = "arial 10")
    tkgrid(apply.but, defaults.but, close.but, sticky = "w")
    tkpack(frame3, fill = "x")
}
"grasp.pred" <-
function (gr.Yi = gr.selY) 
{
    cat("\n")
    cat("*****************************************************", 
        "\n")
    cat("**********           GRASP PREDICT         **********", 
        "\n")
    cat("**********         Predicts responses      **********", 
        "\n")
    cat("**********        GRASP by A. Lehmann      **********", 
        "\n")
    cat("**********      Ported to R by F. Fivaz    **********", 
        "\n")
    cat("*****************************************************", 
        "\n")
    cat("\n")
    cat(date(), "\n")
    cat("\n")
    Yname <- names(YYY)[gr.Yi]
    cat("Response name: ", Yname, "\n")
    print(gam.start)
    cat("predicting... ")
    prediction <- rep(1, length(XXXpred[, 1]))
    prediction[gr.predmask[, gr.Yi] == FALSE] <- -99.9
    prediction[prediction == 1] <- predict.gam(gam.start, XXXpred[prediction == 
        1, ], type = "response")
    cat("done", "\n")
    cat("Saving predictions...")
    print(prediction[1:10])
    gr.predmat[, gr.Yi] <- round(prediction, 4)
    assign("gr.predmat", gr.predmat, pos = 1)
    cat("done", "\n")
    cat("\n")
    cat("**********         GRASP PREDICT END       **********", 
        "\n")
}
"grasp.pred.plot" <-
function (predmat = gr.predmat, gr.Yi = gr.selY, resolution = 1000) 
{
    cat("\n")
    cat("*****************************************************", 
        "\n")
    cat("**********       GRASP PREDICTION PLOT     **********", 
        "\n")
    cat("**********         Plots predictions       **********", 
        "\n")
    cat("**********        GRASP by A. Lehmann      **********", 
        "\n")
    cat("**********      Ported to R by F. Fivaz    **********", 
        "\n")
    cat("*****************************************************", 
        "\n")
    cat("\n")
    cat(date(), "\n")
    cat("\n")
    Yname <- names(YYY)[gr.Yi]
    cat("Response name: ", Yname, "\n")
    TITLE <- "GraspeR"
    maxX <- (ceiling(max(XXXpred$x)/resolution) * resolution) + 
        resolution
    minX <- (floor(min(XXXpred$x)/resolution) * resolution)
    maxY <- (ceiling(max(XXXpred$y)/resolution) * resolution) + 
        resolution
    minY <- (floor(min(XXXpred$y)/resolution) * resolution)
    half <- resolution/2
    Nrow <- (maxX - minX)/resolution
    Ncol <- (maxY - minY)/resolution
    if ((Nrow * Ncol) > 1e+07) {
        cat("ERROR: too many pixels (", Nrow * Ncol, ")>> increase your resolution in the options", 
            "\n")
        return(invisible())
    }
    cat("\n")
    cat("maxX: ", maxX, "\n")
    cat("minX: ", minX, "\n")
    cat("maxY: ", maxY, "\n")
    cat("minY: ", minY, "\n")
    cat("Nrow: ", Nrow, "\n")
    cat("Ncol: ", Ncol, "\n")
    rangeX <- maxX - minX
    rangeY <- maxY - minY
    par(mfrow = c(1, 1), mai = c(0.5, 0.5, 0.5, 0.5))
    fred0 <- (predmat[, gr.Yi] != -99.9)
    fred1 <- XXXpred$x
    fred2 <- XXXpred$y
    fred1 <- round((fred1[fred0] - (minX - half))/resolution)
    fred2 <- round((fred2[fred0] - (minY + half))/resolution)
    fred3 <- predmat[fred0, gr.Yi]
    temp <- as.data.frame(cbind(fred1, fred2, fred3))
    cat("\n")
    cat("Temp:", "\n")
    print(temp[1:10, ])
    temp.temp <- temp
    noduplicates <- all(!(duplicated(paste(temp$fred1, temp$fred2, 
        sep = "x"))))
    cat("\n")
    if (noduplicates) 
        cat("There are no duplicated X and Y coordinates in prediction set !", 
            "\n")
    else if (dim(temp)[1] < 10000) {
        temp <- aggregate(temp, by = list(temp$fred1, temp$fred2), 
            mean)
        cat("AGGREGATION: The mean of predicted value found for each combination of Xs and Ys is returned !!!", 
            "\n")
    }
    else cat("AGGREGATION (>10000 predictions): Only the first predicted value found for each combination of Xs and Ys is returned !!!", 
        "\n")
    fred1 <- temp$fred1
    fred2 <- temp$fred2
    fred3 <- temp$fred3
    map <- NULL
    map <- matrix(NA, nrow = Nrow, ncol = Ncol)
    for (r in 1:length(temp[, 1])) {
        map[fred1[r], fred2[r]] <- fred3[r]
    }
    plot(fred1, fred2, pch = " ", ylim = c(0, Ncol + 0.1 * Ncol), 
        xlim = c(0, Nrow + 0.1 * Nrow))
    image(map, col = heat.colors(12))
    title(paste(TITLE, " ", "\n Grid resolution : ", 1000), cex = 0.6)
    cat("\n")
    cat("**********     GRASP PREDICTION PLOT END   **********", 
        "\n")
    cat("\n")
}
"grasp.roc" <-
function (z1, z2) 
{
    grasp.roc.auc <- function(x) {
        x1 <- 1 - x$spec
        y1 <- x$sens
        trapezint(x1, y1, 0, 1)
    }
    eva <- data.frame(seuil = 0, sens = 1, spec = 1)
    k <- 0.01
    i <- 2
    while (k < 0.9) {
        a <- table(z1 >= k, z2)[4]
        assign("a", a, pos = 1)
        b <- table(z1 >= k, z2)[2]
        c <- table(z1 >= k, z2)[3]
        assign("c", c, pos = 1)
        d <- table(z1 >= k, z2)[1]
        eva[i, "seuil"] <- k
        eva[i, "sens"] <- ifelse(is.na((a/(a + c))), 0, a/(a + 
            c))
        eva[i, "spec"] <- d/(b + d)
        k <- k + 0.01
        i <- i + 1
    }
    eva[i, "seuil"] <- 1
    eva[i, "sens"] <- 0
    eva[i, "spec"] <- 1
    assign("eva", eva, pos = 1)
    return(list(data = eva, auc = grasp.roc.auc(eva)))
}
"grasp.scope" <-
function (sX = gr.selX, df = 4, calcdf = FALSE, trace = TRUE) 
{
    if (trace) {
        cat("\n")
        cat("*****************************************************", 
            "\n")
        cat("**********        R-GRASP SCOPE            **********", 
            "\n")
        cat("**********      Creates scope list         **********", 
            "\n")
        cat("**********      GRASP by A. Lehmann        **********", 
            "\n")
        cat("**********    Ported to R by F. Fivaz      **********", 
            "\n")
        cat("*****************************************************", 
            "\n")
        cat("\n")
        cat(date(), "\n")
        cat("\n")
        cat("Initializing variables... ")
    }
    vnames <- names(XXX[, sX])
    step.list <- as.list(vnames)
    names(step.list) <- vnames
    assign("vnames", vnames, pos = 1)
    if (trace) {
        cat("done", "\n")
        cat("\n")
        cat("Scope list: ", "\n")
        cat("\n")
    }
    if (calcdf == FALSE) {
        for (Xi in sX) {
            vname <- names(XXX)[Xi]
            junk <- c("1")
            if (!is.factor(XXX[[vname]])) 
                junk <- c("1", paste("s", "(", vname, ", ", df + 
                  1, ", fx = T)", sep = ""))
            junk <- eval(parse(text = paste(" ~ ", paste(junk, 
                collapse = "+"))))
            step.list[[vname]] <- junk
        }
    }
    else {
        for (Xi in sX) {
            vname <- names(XXX)[Xi]
            junk <- c("1")
            if (!is.factor(XXX[[vname]])) 
                junk <- c("1", paste("s", "(", vname, ")", sep = ""))
            junk <- eval(parse(text = paste(" ~ ", paste(junk, 
                collapse = "+"))))
            step.list[[vname]] <- junk
        }
    }
    if (trace) 
        print(step.list)
    assign("step.list", step.list, pos = 1)
    if (trace) 
        cat("**********      R-GRASP SCOPE END          **********", 
            "\n")
}
"grasp.select.predictors" <-
function () 
{
    predsel.close <- function(...) {
        tkdestroy(predsel)
    }
    apply.predictors <- function() {
        pred.sel <- tkcurselection(frame2.lstbox1)
        pred.sel <- tclvalue(pred.sel)
        write(pred.sel, file = "resp")
        pred.sel <- scan(file = "resp")
        gr.selX <- pred.sel + 4
        assign("gr.selX", gr.selX, pos = 1)
        assign("gr.Xi", gr.selX, pos = 1)
        assign("SelX", gr.selX, pos = 1)
        for (i in gr.selX) {
            Yname <- names(XXX[i])
            print(Yname)
        }
    }
    predsel <- tktoplevel()
    tktitle(predsel) <- "R-GRASP Select"
    frame1 <- tkframe(predsel, relief = "groove", borderwidth = 2)
    frame2 <- tkframe(predsel, relief = "groove", borderwidth = 2)
    frame3 <- tkframe(predsel, relief = "groove", borderwidth = 2)
    frame1.label <- tklabel(frame1, text = "Select predictors", 
        justify = "left", wraplength = 200)
    tkpack(frame1, frame1.label, fill = "x")
    frame2.yscroll <- tkscrollbar(frame2, repeatinterval = 5, 
        command = function(...) tkyview(frame2.lstbox1, ...))
    frame2.lstbox1 <- tklistbox(frame2, selectmode = "multiple", 
        exportselection = FALSE, yscrollcommand = function(...) tkset(frame2.yscroll, 
            ...))
    for (i in c(4:length(XXX))) {
        tkinsert(frame2.lstbox1, "end", names(XXX)[i])
    }
    gr.selX0 <- gr.selX - 4
    for (i in gr.selX0) tkselection.set(frame2.lstbox1, i)
    tkgrid(frame2.lstbox1, frame2.yscroll)
    tkgrid.configure(frame2.yscroll, rowspan = 4, sticky = "nsw")
    tkpack(frame2, fill = "y")
    apply.but <- tkbutton(frame3, text = "Apply", command = apply.predictors)
    close.but <- tkbutton(frame3, text = "Close", command = predsel.close)
    tkgrid(apply.but, close.but, sticky = "w")
    tkpack(frame3, fill = "x")
}
"grasp.select.responses" <-
function () 
{
    respsel.close <- function(...) {
        tkdestroy(respsel)
    }
    apply.response <- function() {
        resp.sel <- tkcurselection(frame4.lstbox2)
        resp.sel <- tclvalue(resp.sel)
        write(resp.sel, file = "resp")
        resp.sel <- scan(file = "resp")
        gr.selY <- resp.sel + 2
        assign("gr.selY", gr.selY, pos = 1)
        assign("gr.Yi", gr.selY, pos = 1)
        assign("OPT$SELY", gr.selY, pos = 1)
        for (i in gr.selY) {
            Yname <- names(YYY[i])
            print(Yname)
        }
    }
    respsel <- tktoplevel()
    tktitle(respsel) <- "R-GRASP Select"
    frame1 <- tkframe(respsel, relief = "groove", borderwidth = 2)
    frame4 <- tkframe(respsel, relief = "groove", borderwidth = 2)
    frame3 <- tkframe(respsel, relief = "groove", borderwidth = 2)
    frame1.label <- tklabel(frame1, text = "Select response variables", 
        justify = "left", wraplength = 200)
    tkpack(frame1, frame1.label, fill = "x")
    frame4.lstbox2 <- tklistbox(frame4, selectmode = "multiple", 
        exportselection = FALSE)
    for (i in c(2:length(YYY))) {
        tkinsert(frame4.lstbox2, "end", names(YYY)[i])
    }
    tkpack(frame4, frame4.lstbox2, fill = "x")
    apply.but <- tkbutton(frame3, text = "Apply", command = apply.response)
    close.but <- tkbutton(frame3, text = "Close", command = respsel.close)
    tkgrid(apply.but, close.but, sticky = "w")
    tkpack(frame3, fill = "x")
}
"grasp.start" <-
function (cX, sX, df = 4, calcdf = FALSE, trace = TRUE) 
{
    if (trace) {
        cat("\n")
        cat("*****************************************************", 
            "\n")
        cat("**********        R-GRASP START            **********", 
            "\n")
        cat("**********    Creates starting formula     **********", 
            "\n")
        cat("**********      GRASP by A. Lehmann        **********", 
            "\n")
        cat("**********    Ported to R by F. Fivaz      **********", 
            "\n")
        cat("*****************************************************", 
            "\n")
        cat("\n")
        cat(date(), "\n")
        cat("\n")
        cat("Initializing variables... ")
    }
    sX <- intersect(sX, cX)
    vnames <- names(XXX[, c(1, sX)])
    model.formula <- NULL
    if (trace) {
        cat("done", "\n")
        cat("\n")
        cat("Variables used:", "\n")
    }
    if (calcdf == FALSE) {
        for (Xi in sX) {
            if (trace) 
                cat(names(XXX)[Xi], "\n")
            vname <- names(XXX)[Xi]
            if (is.factor(XXX[[vname]])) 
                model.formula <- c(model.formula, paste("s", 
                  "(", vname, ")"))
            else model.formula <- c(model.formula, paste("s", 
                "(", vname, ", k=", df + 1, ", fx = TRUE)"))
        }
    }
    else {
        for (Xi in sX) {
            if (trace) 
                cat(names(XXX)[Xi], "\n")
            vname <- names(XXX)[Xi]
            if (is.factor(XXX[[vname]])) 
                model.formula <- c(model.formula, paste("s", 
                  "(", vname, ")"))
            else model.formula <- c(model.formula, paste("s", 
                "(", vname, ")"))
        }
    }
    gam.formula <- model.formula
    assign("gam.formula", gam.formula, pos = 1)
    model.formula <- c(model.formula)
    if (length(sX) > 1) {
        model.formula <- eval(parse(text = paste("YYY$", names(YYY)[gr.Yi], 
            "~", paste(model.formula, collapse = "+"))))
    }
    else {
        if (length(sX) == 0) {
            model.formula <- eval(parse(text = paste("YYY$", 
                names(YYY)[gr.Yi], "~", "0")))
        }
        else {
            model.formula <- eval(parse(text = paste("YYY$", 
                names(YYY)[gr.Yi], "~", model.formula)))
        }
    }
    model.formula
    cat("\n")
    assign("model.formula", model.formula, pos = 1)
    if (trace) {
        print(model.formula)
        cat("\n")
        cat("Formula created!", "\n")
        cat("\n")
        cat("**********        R-GRASP START END         **********", 
            "\n")
        cat("\n")
    }
}
"grasp.stat.anova" <-
function (table, test = c("Chisq", "F", "Cp"), scale, df.scale, 
    n) 
{
    test <- match.arg(test)
    dev.col <- match("Deviance", colnames(table))
    if (is.na(dev.col)) 
        dev.col <- match("Sum of Sq", colnames(table))
    if (is.na(dev.col)) 
        stop("Anova objects need a \"Deviance\" or a \"Sum of Sq\" columns for the F test")
    switch(test, Chisq = {
        cbind(table, "P(>|Chi|)" = pchisq(abs(table[, dev.col]/scale), 
            abs(table[, "Df"]), lower.tail = FALSE))
    }, F = {
        Fvalue <- abs((table[, dev.col]/table[, "Df"])/scale)
        Fvalue[table[, "Df"] == 0] <- NA
        cbind(table, F = Fvalue, "Pr(>F)" = pf(Fvalue, abs(table[, 
            "Df"]), abs(df.scale), lower.tail = FALSE))
    }, Cp = {
        cbind(table, Cp = table[, "Resid. Dev"] + 2 * scale * 
            (n - table[, "Resid. Df"]))
    })
}
"grasp.step.gam" <-
function (object = gam.start, scope = step.list, scale, direction = c("both", 
    "backward", "forward"), trace = TRUE, keep = NULL, steps = 1000, 
    limit = 0.05, test = "F") 
{
    LIMIT = limit
    OPT$test <- test
    cat("direction =", direction, "\n")
    cat("steps =", steps, "\n")
    cat("limit =", limit, "\n")
    cat("test =", test, "\n")
    XXX <- XXX[gr.modmask[, gr.Yi], ]
    YYY <- YYY[gr.modmask[, gr.Yi], ]
    convert.gam <- function(object) {
        objgam <- vector("list", 3)
        names(objgam) <- c("family", "formula", "terms")
        objgam$formula <- formula(object)
        objgam$family <- vector("list", 3)
        names(objgam$family) <- c("name", "link", "variance")
        objgam$family$name <- object$family[[1]]
        objgam$family$link <- object$family[[2]]
        objgam$family$variance <- object$family[[5]]
        objgam$terms <- vector("list", 2)
        names(objgam$terms) <- c("response", "term.labels")
        objgam$terms$response <- 1
        objgam$terms$term.labels <- gam.formula
        return(objgam)
    }
    scope.char <- function(form) {
        for (i in 1:length(form)) {
            form[[i]] <- c("1", gam.formula[i])
        }
        return(form)
    }
    untangle.scope <- function(terms, regimens) {
        a <- attributes(terms)
        response <- deparse(terms[[2]])
        term.labels <- a$term.labels
        nt <- length(regimens)
        Select <- integer(nt)
        for (i in seq(nt)) {
            j <- match(regimens[i], term.labels, 0)
            if (any(j)) {
                if (sum(j > 0) > 1) 
                  stop("problem")
                Select[i] <- seq(j)[j > 0]
                term.labels <- term.labels[-sum(j)]
            }
            else {
                if (!(j <- match("1", regimens[[i]], 0))) 
                  stop("problem 2")
                Select[i] <- j
            }
        }
        if (length(term.labels)) 
            term.labels <- paste(term.labels, "+")
        return(list(response = paste(response, term.labels, sep = " ~ "), 
            Select = Select))
    }
    make.step <- function(models, fit, scale, object) {
        chfrom <- sapply(models, "[[", "from")
        chfrom[chfrom == "1"] <- ""
        chto <- sapply(models, "[[", "to")
        chto[chto == "1"] <- ""
        dev <- sapply(models, "[[", "deviance")
        df <- sapply(models, "[[", "df.resid")
        ddev <- c(NA, diff(dev))
        ddf <- c(NA, diff(df))
        pvalue <- sapply(models, "[[", "pvalue")
        heading <- as.list(c("Stepwise Model Path", "\nAnalysis of deviance Table", 
            "\nInitial Model: ", deparse(as.vector(formula(object))), 
            "\nFinal Model: ", deparse(as.vector(formula(fit))), 
            paste("\nScale: ", format(scale), "\n", sep = "")))
        aod <- data.frame(From = chfrom, To = chto, Df = ddf, 
            Deviance = ddev, "Resid. Df" = df, "Resid. Dev" = dev, 
            pvalue = pvalue, check.names = F)
        cat("\n")
        print(aod)
        cat("\n")
        cat(unlist(heading))
        cat("\n")
        cat("Creating new gam.start model, with results from stewise selection...")
        gam.start <- update(gam.start, formula(fit))
        assign("gam.start", gam.start, pos = 1)
        cat("done", "\n")
    }
    direction <- match.arg(direction)
    scope <- scope.char(scope)
    object.real <- object
    object <- convert.gam(object)
    response <- untangle.scope(object$formula, scope)
    object <- object.real
    form.y <- response$response
    backward <- direction == "both" | direction == "backward"
    forward <- direction == "both" | direction == "forward"
    items <- response$Select
    family <- object$family
    cat("\n")
    Call <- object$call
    term.lengths <- sapply(scope, length)
    n.items <- length(items)
    visited <- array(F, term.lengths)
    visited[array(items, c(1, n.items))] <- T
    models <- vector("list", length(visited))
    nm <- 2
    form.vector <- character(n.items)
    items <- items + 1
    for (i in seq(n.items)) {
        form.vector[i] <- scope[[i]][items[i]]
    }
    form <- deparse(object$formula)
    cat("form.vector passed", "\n")
    fit <- object
    fit$df.resid <- length(fit$y) - fit$nsdf - sum(fit$edf)
    n <- length(fit$fitted)
    scale <- fit$sig2
    cat("Scale est. =", scale, "\n")
    bAIC <- deviance(fit) + 2 * (n - fit$df.null) * scale
    models[[1]] <- list(deviance = deviance(fit), df.resid = fit$df.resid, 
        pvalue = LIMIT, from = "", to = "")
    STOP <- 1
    bFRED <- 1
    if (test == "Chisq") 
        scale <- 1
    while (STOP > LIMIT && steps > 0) {
        steps <- steps - 1
        STOP <- bFRED
        bFRED <- LIMIT
        kFRED <- LIMIT
        bitems <- items
        bfit <- fit
        Nstep <- 0
        for (i in seq(n.items)) {
            if (backward) {
                cat("Start backward...", "\n")
                trial <- items
                trial[i] <- trial[i] - 1
                if (trial[i] > 0 && !visited[array(trial, c(1, 
                  n.items))]) {
                  visited[array(trial, c(1, n.items))] <- T
                  tform.vector <- form.vector
                  tform.vector[i] <- scope[[i]][trial[i]]
                  cat("Trial:", form, "\n")
                  form <- paste(form.y, paste(tform.vector, collapse = " + "))
                  tfit <- update(object.real, eval(parse(text = form)))
                  TEST <- grasp.anova.gam(fit, tfit, test = test, 
                    dispersion = scale)
                  fit$df.resid <- length(fit$y) - fit$nsdf - 
                    sum(fit$edf)
                  tfit$df.resid <- length(tfit$y) - tfit$nsdf - 
                    sum(tfit$edf)
                  bfit$df.resid <- length(bfit$y) - bfit$nsdf - 
                    sum(bfit$edf)
                  assign("fit", fit, pos = 1)
                  assign("tfit", tfit, pos = 1)
                  if (test == "Chisq") 
                    tFRED <- TEST[2, 5]
                  if (test == "F") 
                    tFRED <- TEST[2, 6]
                  if (tFRED > bFRED) {
                    bFRED <- tFRED
                    kFRED <- tFRED
                    bitems <- trial
                    bfit <- tfit
                    bform.vector <- tform.vector
                    bfrom <- form.vector[i]
                    bto <- tform.vector[i]
                    Nstep <- i
                  }
                }
            }
            if (forward) {
                cat("Start forward...", "\n")
                trial <- items
                trial[i] <- trial[i] + 1
                if (trial[i] <= term.lengths[i] && !visited[array(trial, 
                  c(1, n.items))]) {
                  visited[array(trial, c(1, n.items))] <- T
                  tform.vector <- form.vector
                  tform.vector[i] <- scope[[i]][trial[i]]
                  form <- paste(form.y, paste(tform.vector, collapse = " + "))
                  tfit <- update(object.real, eval(parse(text = form)))
                  TEST <- grasp.anova.gam(fit, tfit, test = test, 
                    dispersion = scale)
                  fit$df.resid <- length(fit$y) - fit$nsdf - 
                    sum(fit$edf)
                  tfit$df.resid <- length(tfit$y) - tfit$nsdf - 
                    sum(tfit$edf)
                  bfit$df.resid <- length(bfit$y) - bfit$nsdf - 
                    sum(bfit$edf)
                  tFRED <- TEST[2, 5]
                  if (tFRED < kFRED & tFRED < LIMIT) {
                    bFRED <- LIMIT + 0.001
                    kFRED <- tFRED
                    bitems <- trial
                    bfit <- tfit
                    bform.vector <- tform.vector
                    bfrom <- form.vector[i]
                    bto <- tform.vector[i]
                    Nstep <- i
                  }
                }
            }
        }
        if (STOP <= LIMIT | steps == 0 | Nstep == 0) {
            return(make.step(models[seq(nm - 1)], fit, scale, 
                object))
        }
        else {
            items <- bitems
            models[[nm]] <- list(deviance = deviance(bfit), df.resid = bfit$df.resid, 
                pvalue = kFRED, from = bfrom, to = bto)
            nm <- nm + 1
            fit <- bfit
            form.vector <- bform.vector
        }
    }
    assign("models", models, pos = 1)
}
"grasp.summary" <-
function (gr.Yi = gr.selY) 
{
    cat("********* GraspeR.summary **********", "\n")
    cat(date(), "\n")
    cat("\n")
    cat("Ys...", "\n")
    dimYYY <- dim(YYY)
    cat("Dimension of YYY:", dimYYY, "\n")
    Yname <- names(YYY)[gr.Yi]
    cat("Selected response: ", gr.Yi, "\n")
    cat("Response name: ", Yname, "\n", "\n")
    selection <- gr.modmask[, gr.Yi]
    if (length(gr.Yi) > 1) {
        cat("More than one VOI to summarize, doing lapply()", 
            "\n")
        lapply(gr.Yi, grasp.summary)
    }
    else {
        print(summary(YYY[selection, gr.Yi]))
        cat("\n")
        cat("XXX:", "\n")
        print(summary(XXX[selection, gr.selX]))
    }
    cat("\n")
    cat("************************************", "\n")
}
"grasp.validate" <-
function () 
{
    STEPMODEL <- gam.start
    OPTIONS$CVGROUPS <- 5
    assign("OPTIONS", OPTIONS, pos = 1)
    Yname <- names(YYY)[gr.Yi]
    cat("RESPONSE NAME: ", Yname, "\n")
    par(mfrow = c(2, 2), mai = c(0.75, 0.75, 0.75, 0.75))
    subsets <- rep(1:OPTIONS$CVGROUPS, length.out = length(XXX[, 
        1]))
    temppredict <- rep(NA, length(XXX[, 1]))
    assign("temppredict", temppredict, pos = 1)
    for (Nloop in 1:OPTIONS$CVGROUPS) {
        OPTIONS$SUBSET1 <- subsets != Nloop
        if (OPTIONS$CVGROUPS == 1) 
            OPTIONS$SUBSET1 <- !OPTIONS$SUBSET1
        OPTIONS$SUBSET1 <- (as.logical(gr.modmask[, gr.Yi]) & 
            OPTIONS$SUBSET1)
        tempmodel <- update(STEPMODEL)
        if (OPTIONS$CVGROUPS == 1) 
            OPTIONS$SUBSET2 <- OPTIONS$SUBSET1
        else OPTIONS$SUBSET2 <- (as.logical(gr.modmask[, gr.Yi]) & 
            !OPTIONS$SUBSET1)
        temppredict[OPTIONS$SUBSET2] <- predict.gam(tempmodel, 
            XXX[OPTIONS$SUBSET2, ], type = "response")
    }
    temp1 <- YYY[!is.na(temppredict), gr.Yi]
    temp2 <- temppredict[!is.na(temppredict)]
    plot(temp1, temp2, ylab = "cross-predicted", xlab = paste("observed ", 
        Yname), pch = "*")
    BIN <- gam.start$family[1] == "quasibinomial"
    if (BIN) 
        if (BIN) {
            nbgroups <- 10
            cvROC <- grasp.roc(temp2, temp1)
            legend(min(YYY[!is.na(YYY[, gr.Yi]), gr.Yi]), max(temp2), 
                paste("N groups : ", OPTIONS$CVGROUPS, ", cvROC =", 
                  zapsmall(cvROC$auc, 2)), cex = 0.7)
        }
        else {
            legend(min(YYY[!is.na(YYY[, gr.Yi]), gr.Yi]), max(temp2), 
                paste("N groups : ", OPTIONS$CVGROUPS, ", cvROC =", 
                  zapsmall(cor(temp1, temp2), 2)), cex = 0.7)
        }
    STEPMODEL.local <- STEPMODEL
    STEPMODEL.local[[gr.Yi]]$crosspred <- temppredict
    assign("STEPMODEL", STEPMODEL.local, pos = 1)
    title("CROSS-VALIDATION", cex = 0.5)
    CVGROUPS <- 1
    subsets <- rep(1:CVGROUPS, length.out = length(XXX[, 1]))
    temppredict <- rep(NA, length(XXX[, 1]))
    for (Nloop in 1:CVGROUPS) {
        OPTIONS$SUBSET1 <- subsets != Nloop
        if (CVGROUPS == 1) 
            OPTIONS$SUBSET1 <- !OPTIONS$SUBSET1
        OPTIONS$SUBSET1 <- (as.logical(gr.modmask[, gr.Yi]) & 
            OPTIONS$SUBSET1)
        assign("OPTIONS", OPTIONS, pos = 1)
        tempmodel <- update(STEPMODEL)
        if (CVGROUPS == 1) 
            OPTIONS$SUBSET2 <- OPTIONS$SUBSET1
        else OPTIONS$SUBSET2 <- (as.logical(gr.modmask[, gr.Yi]) & 
            !OPTIONS$SUBSET1)
        assign("OPTIONS", OPTIONS, pos = 1)
        temppredict[OPTIONS$SUBSET2] <- predict.gam(tempmodel, 
            XXX[OPTIONS$SUBSET2, ], type = "response")
    }
    temp1 <- YYY[!is.na(temppredict), gr.Yi]
    temp2 <- temppredict[!is.na(temppredict)]
    plot(temp1, temp2, ylab = "predicted", xlab = paste("observed ", 
        Yname), pch = "*")
    if (BIN) 
        if (BIN) {
            nbgroups <- 10
            ROC <- grasp.roc(temp2, temp1)
            legend(min(YYY[!is.na(YYY[, gr.Yi]), gr.Yi]), max(temp2), 
                paste("N groups : ", CVGROUPS, ", ROC =", zapsmall(ROC$auc, 
                  2)), cex = 0.7)
        }
        else {
            legend(min(YYY[!is.na(YYY[, gr.Yi]), gr.Yi]), max(temp2), 
                paste("N groups : ", CVGROUPS, ", ROC =", zapsmall(cor(temp1, 
                  temp2), 2)), cex = 0.7)
        }
    COR <- cor(temp1, temp2)
    if (exists("DROP.CONTRIB")) {
        DROP.CONTRIB <- DROP.CONTRIB
        endline <- length(gr.selX) + 7
        DROP.CONTRIB[endline + 1, gr.Yi] <- COR
        DROP.CONTRIB[endline + 2, gr.Yi] <- cvCOR
        row.names(DROP.CONTRIB)[c(endline + 1, endline + 2)] <- c("Cor", 
            "cvCor")
        dump(c("DROP.CONTRIB", "ALONE.CONTRIB"), fileout = paste(OPTIONS$PATH, 
            "contributions.txt", sep = ""))
        assign("DROP.CONTRIB", DROP.CONTRIB, pos = 1)
    }
    title("VALIDATION", cex = 0.5)
    qqnorm(resid(gam.start))
    cat("\n")
    cat(" ********** GRASP VALIDATE END ********** ", "\n")
    cat("\n")
}
