R/initGRASS.R

In rsbivand/rgrass7: Interface Between 'GRASS' Geographical Information System and 'R'

# Interpreted GRASS 7, 8 raster interface functions
# Copyright (c) 2008-22 Roger S. Bivand
#
# GIS_LOCK 110814 RSB, suggested by Brian Oney
get.GIS_LOCK <- function() {
    Sys.getenv("GIS_LOCK")
}

set.GIS_LOCK <- function(pid) {
    if (missing(pid)) pid <- round(runif(1, 1, 1000))
    pid <- as.integer(pid)
    stopifnot(!is.na(pid))
    Sys.setenv(GIS_LOCK=pid)
}

unset.GIS_LOCK <- function() {
    Sys.unsetenv("GIS_LOCK")
}

unlink_.gislock <- function() {
    gl <- paste(Sys.getenv("GISDBASE"), Sys.getenv("LOCATION_NAME"),
        Sys.getenv("MAPSET"), ".gislock", sep="/")
    if (file.exists(gl)) unlink(gl)
}

ask_override <- function(msg, missing_override, envir) {
  if (interactive() && missing_override) {
    message(msg, ".")
    a <- ""
    while(!grepl("^[Yy]([Ee][Ss])?$|^[Nn]([Oo])?$", a)) {
      a <- readline("Do you want to override ('no' will abort)? (y/n) ")
    }
    if (grepl("^[Yy]", a)) {
      assign("override", TRUE, envir = envir)
      message("Overriding. Avoid this question by setting override = TRUE")
    } else stop("Aborting. To override, set override = TRUE", call. = FALSE)
  } else {
    stop(msg, "; to override, set override = TRUE", call. = FALSE)
  }
}

initGRASS <- function(gisBase = NULL, home, SG, gisDbase, addon_base, location,
    mapset, override=FALSE, use_g.dirseps.exe=TRUE, pid, remove_GISRC=FALSE,
    ignore.stderr=get.ignore.stderrOption()) {

    if (nchar(Sys.getenv("GISRC")) > 0 && !override)
      ask_override(paste0("A GRASS location (defined by ",
                          Sys.getenv("GISRC"),
                          ") is already in use"),
                   missing_override = missing(override),
                   envir = environment())

    if (nchar(get.GIS_LOCK()) > 0) {
      if(!override){
        ask_override("A GIS_LOCK environment variable is present",
                     missing_override = missing(override),
                     envir = environment())
        unset.GIS_LOCK() # no error means user wants to override
      }
      else unset.GIS_LOCK()
    }

    if (missing(pid)) pid <- round(runif(1, 1, 1000))
    pid <- as.integer(pid)
    stopifnot(!is.na(pid))
    stopifnot(is.logical(override))
    stopifnot(length(override) == 1)
    stopifnot(is.logical(use_g.dirseps.exe))
    stopifnot(length(use_g.dirseps.exe) == 1)
    stopifnot(is.logical(remove_GISRC))
    stopifnot(length(remove_GISRC) == 1)

    if (is.null(gisBase)) {
      message("No gisBase set. Trying to detect from the GRASS_INSTALLATION ",
              "environment variable.")
      grass_installation <- Sys.getenv("GRASS_INSTALLATION")
      stopifnot(is.character(grass_installation))
      if (nchar(grass_installation) > 0) {
        message("Taking gisBase value from GRASS_INSTALLATION: ",
                grass_installation)
        gisBase <- grass_installation
      } else {
        message("No GRASS_INSTALLATION environment variable was found.\n",
                "Trying to set gisBase by running command ",
                "`grass --config path` (requires grass in the system PATH).")
        tryCatch({
          gisBase <-
            if (.Platform$OS.type == "windows") {
              shell("grass --config path", intern = TRUE)
            } else {
              system("grass --config path", intern = TRUE)
            }
        }, error = function(e) {
          stop("grass seems to be unavailable in the system PATH.\n",
               "Either provide the gisBase argument or set a ",
               "GRASS_INSTALLATION environment variable to provide the ",
               "gisBase path",
               call. = FALSE)
        }
        )
        message("Taking gisBase value from `grass --config path` output: ",
                gisBase)
        stopifnot(length(gisBase) == 1L)
      }
    }

    if (!file.exists(gisBase)) stop(paste(gisBase, "not found"))
    if (!file.info(gisBase)$isdir[1]) stop(gisBase, " is not a directory")
    bin_is_dir <- file.info(file.path(gisBase, "bin"))$isdir[1]
    if (is.na(bin_is_dir))
      stop(gisBase, " does not contain bin, the directory with GRASS programs")
    if (!bin_is_dir) stop(gisBase, "/bin is not a directory")
    scripts_is_dir <- file.info(file.path(gisBase, "scripts"))$isdir[1]
    if (is.na(scripts_is_dir))
      stop(gisBase, " does not contain scripts, the directory with GRASS scripts")
    if (!scripts_is_dir) stop(gisBase, "/scripts is not a directory")



    gv <- readLines(file.path(gisBase, "etc/VERSIONNUMBER"))
    gv <- substring(gv, 1, 1)

    SYS <- get("SYS", envir=.GRASS_CACHE)
    if (SYS == "WinNat") {
# grass63.bat
        Sys.setenv(GISBASE=gisBase)
        if (missing(home)) home <- Sys.getenv("USERPROFILE")
        Sys.setenv(HOME=home)
        if (missing(addon_base))
            addon_base <- paste(Sys.getenv("APPDATA"),
                "/GRASS", gv, "/addons", sep="")
        addon_res <- file.exists(addon_base, paste(addon_base, "/bin", sep=""))
        if (any(addon_res)) Sys.setenv("GRASS_ADDON_BASE"=addon_base)
        OSGEO4W_ROOT <- Sys.getenv("OSGEO4W_ROOT")
        if (nchar(OSGEO4W_ROOT) > 0) {
            Sys.setenv(GRASS_PROJSHARE=paste(OSGEO4W_ROOT,
                "\\share\\proj", sep=""))
        } else {
            unistring <- toupper(gisBase)
            unistring <- gsub("\\\\", "/", unistring)
            if (length(grep("OSGEO4W.*/APPS/GRASS", unistring)) > 0)
                stop("NOTE: If using OSGeo4W GRASS, start R in the OSGeo4W shell,\nsee help(initGRASS) for further details")
	    if (length(grep("QGIS.*/APPS/GRASS", unistring)) > 0)
                stop("NOTE: If using Windows standalone QGIS GRASS, start R in the QGIS standalone\nOSGeo4W shell, see help(initGRASS) for further details")
            Sys.setenv(GRASS_PROJSHARE=paste(Sys.getenv("GISBASE"),
                "\\share\\proj", sep=""))
        }

        Wpath <- Sys.getenv("PATH")
        if (length(grep(basename(Sys.getenv("GISBASE")), Wpath)) < 1) {
            Sys.setenv(PATH=paste(Sys.getenv("GISBASE"), "\\lib;",
                Sys.getenv("PATH"), sep=""))
            Sys.setenv(PATH=paste(Sys.getenv("GISBASE"), "\\bin;",
                Sys.getenv("PATH"), sep=""))
            Sys.setenv(PATH=paste(Sys.getenv("GISBASE"), "\\extrabin;",
                Sys.getenv("PATH"), sep=""))
            if (addon_res[2]) Sys.setenv(PATH=paste(Sys.getenv(
                "GRASS_ADDON_BASE"), "\\bin;", Sys.getenv("PATH"), sep=""))
# etc/Init.bat
#            GRASS_addons <- Sys.getenv("GRASS_ADDON_PATH")
#            if (GRASS_addons == "")
#                Sys.setenv(PATH=paste(Sys.getenv("WINGISBASE"), "\\bin;",
#                    Sys.getenv("WINGISBASE"), "\\lib;",
#                    Sys.getenv("PATH"), sep=""))
#            else
#                Sys.setenv(PATH=paste(Sys.getenv("WINGISBASE"), "\\bin;",
#                    Sys.getenv("WINGISBASE"), "\\lib;",
#                    GRASS_addons, ";", Sys.getenv("PATH"), sep=""))
            ePyPATH <- Sys.getenv("PYTHONPATH")
            if ((length(grep(basename(Sys.getenv("GISBASE")), ePyPATH)) < 1)
                || nchar(ePyPATH) == 0) {
                GrPyPATH <- paste(Sys.getenv("GISBASE"), "/etc/python",
                    sep="")
                if (nchar(ePyPATH) > 0)
                    Sys.setenv(PYTHONPATH=paste(GrPyPATH, ePyPATH, sep=";"))
                else Sys.setenv(PYTHONPATH=GrPyPATH)
            }
            if (nchar(OSGEO4W_ROOT) > 0) {
              Sys.setenv("PYTHONHOME"=paste(OSGEO4W_ROOT, "apps/Python37", sep="/"))
            } else {
              G_B_files <- list.files(Sys.getenv("GISBASE"))
              Python_dir <- G_B_files[grep("Python", G_B_files)]
              if (length(Python_dir) > 0) Sys.setenv("PYTHONHOME"=paste(Sys.getenv("GISBASE"), Python_dir[1], sep="/"))
            }
#            pyScripts <- basename(list.files(paste(Sys.getenv("GISBASE"),
#                "scripts", sep="/"), pattern="py$"))
#            names(pyScripts) <- sub("\\.py", "", pyScripts)
#            assign("pyScripts", pyScripts, envir=.GRASS_CACHE)
        }
        Sys.setenv(GISRC=paste(Sys.getenv("HOME"), "\\.grassrc", gv, sep=""))
        if (file.exists(Sys.getenv("GISRC")) && !override)
          ask_override(paste("A GISRC file", Sys.getenv("GISRC"), "already exists"),
                       missing_override = missing(override),
                       envir = environment())
        fn_gisrc <- "junk"
        if (isTRUE(file.access(".", 2) == 0)) {
            Sys.setenv(GISRC=fn_gisrc)
        } else {
            warning("working directory not writable, using tempfile for GISRC")
            Sys.setenv(GISRC=paste0(tempfile(), "_", fn_gisrc))
        }
        cat("GISDBASE:", getwd(), "\n", file=Sys.getenv("GISRC"))
        cat("LOCATION_NAME: <UNKNOWN>", "\n", file=Sys.getenv("GISRC"),
            append=TRUE)
        cat("MAPSET: <UNKNOWN>", "\n", file=Sys.getenv("GISRC"),
            append=TRUE)
        gisrc <- ifelse (use_g.dirseps.exe, system(paste("g.dirseps.exe -g",
            shQuote(Sys.getenv("GISRC"))), intern=TRUE),
            Sys.getenv("GISRC"))
        assign("addEXE", .addexe(), envir=.GRASS_CACHE)
        Sys.setenv(GISRC=gisrc)
        if (!missing(gisDbase)) {
            if (!file.exists(gisDbase)) dir.create(gisDbase)
        } else {
            gisDbase <- tempdir()
        }
        gisDbase <- ifelse (use_g.dirseps.exe, system(paste("g.dirseps.exe -g",
            shQuote(gisDbase)), intern=TRUE), gisDbase)
    } else if (SYS == "unix") {
        OSGEO4W_ROOT <- ""
        Sys.setenv(GISBASE=gisBase)
        if (missing(home)) home <- Sys.getenv("HOME")
        if (missing(addon_base))
            addon_base <- paste(Sys.getenv("HOME"), "/.grass", gv, "/addons", sep="")
        addon_res <- file.exists(addon_base, paste(addon_base, "/bin", sep=""),
            paste(addon_base, "/scripts", sep=""))
        if (any(addon_res)) Sys.setenv("GRASS_ADDON_BASE"=addon_base)
        ePATH <- Sys.getenv("PATH")
        if (length(grep(basename(Sys.getenv("GISBASE")), ePATH)) < 1) {
          Sys.setenv(PATH=paste(Sys.getenv("GISBASE"), "/bin:",
          Sys.getenv("GISBASE"), "/scripts",
          ifelse(addon_res[2],
            paste(":", Sys.getenv("GRASS_ADDON_BASE"), "/bin", sep=""), ""),
          ifelse(addon_res[3],
            paste(":", Sys.getenv("GRASS_ADDON_BASE"), "/scripts", sep=""),
            ""),
          ifelse(nchar(ePATH) == 0, "", ":"), ePATH, sep=""))
        }
        eLDPATH <- Sys.getenv("LD_LIBRARY_PATH")
        if (length(grep(basename(Sys.getenv("GISBASE")), eLDPATH)) < 1) {
            Sys.setenv(LD_LIBRARY_PATH=paste(Sys.getenv("GISBASE"), "/lib:",
            ifelse(nchar(eLDPATH) == 0, "", ":"), eLDPATH, sep=""))
        }
#FIXME Sys.info()["sysname"] == "Darwin"
        Sys.setenv(GISRC=paste(home, "/.grassrc", gv, sep=""))
#FIXME
        if (file.exists(Sys.getenv("GISRC")) && !override)
          ask_override(paste("A GISRC file", Sys.getenv("GISRC"), "already exists"),
                       missing_override = missing(override),
                       envir = environment())
        ePyPATH <- Sys.getenv("PYTHONPATH")
        if (length(grep(basename(Sys.getenv("GISBASE")), ePyPATH)) < 1
            || nchar(ePyPATH) == 0) {
            GrPyPATH <- paste(Sys.getenv("GISBASE"), "etc", "python", sep="/")
            if (nchar(ePyPATH) > 0)
                 Sys.setenv(PYTHONPATH=paste(GrPyPATH, ePyPATH, sep=":"))
            else Sys.setenv(PYTHONPATH=GrPyPATH)
        }
        if (!missing(gisDbase)) {
            if (!file.exists(gisDbase)) dir.create(gisDbase)
        } else {
            gisDbase <- tempdir()
        }
        cat("GISDBASE:", gisDbase, "\n", file=Sys.getenv("GISRC"))
        cat("LOCATION_NAME: <UNKNOWN>", "\n", file=Sys.getenv("GISRC"),
            append=TRUE)
        cat("MAPSET: <UNKNOWN>", "\n", file=Sys.getenv("GISRC"),
            append=TRUE)
    } else stop(paste("Platform variant", SYS, "not supported"))
    set.GIS_LOCK(pid)
    assign("INIT_USED", TRUE, envir=.GRASS_CACHE)
    assign("GIS_LOCK", pid, envir=.GRASS_CACHE)
    if (remove_GISRC) assign("remove_GISRC", remove_GISRC, envir=.GRASS_CACHE)
    system(paste(paste("g.gisenv", get("addEXE", envir=.GRASS_CACHE), sep=""),
        shQuote(paste("set=GISDBASE=", gisDbase))))
    if (missing(location)) location <- basename(tempfile())
    loc_path <- paste(gisDbase, location, sep="/")
    if (!file.exists(loc_path)) dir.create(loc_path)
    if (!file.exists(paste(loc_path, "PERMANENT", sep="/")))
        dir.create(paste(loc_path, "PERMANENT", sep="/"))
    if (missing(mapset)) mapset <- basename(tempfile())
    if (!file.exists(paste(loc_path, mapset, sep="/")))
        dir.create(paste(loc_path, mapset, sep="/"))
    system(paste(paste("g.gisenv", get("addEXE", envir=.GRASS_CACHE), sep=""),
        shQuote(paste("set=GISDBASE", gisDbase, sep="="))))
    system(paste(paste("g.gisenv", get("addEXE", envir=.GRASS_CACHE), sep=""),
        shQuote(paste("set=LOCATION_NAME", location, sep="="))))
    system(paste(paste("g.gisenv", get("addEXE", envir=.GRASS_CACHE), sep=""),
        shQuote(paste("set=MAPSET", mapset, sep="="))))
    system(paste(paste("g.gisenv", get("addEXE", envir=.GRASS_CACHE), sep=""),
        shQuote("set=GRASS_GUI=text")))
    Sys.setenv(GISBASE=gisBase)
    Sys.setenv(GISDBASE=gisDbase)
    Sys.setenv(LOCATION_NAME=location)
    Sys.setenv(MAPSET=mapset)
    gv <- system(paste("g.version", get("addEXE", envir=.GRASS_CACHE),
                       sep=""),  intern=TRUE)


    comp <- .compatibleGRASSVersion(gv)
    if ( !comp ){
        stop( attr(comp, "message") )
    }
    grass_python <- Sys.getenv("GRASS_PYTHON")
    if (grass_python == "") {
      if (nchar(OSGEO4W_ROOT) > 0) {
        if (file.exists(paste(OSGEO4W_ROOT, "bin/python3.exe", sep="/"))) {
          Sys.setenv("GRASS_PYTHON"=paste(OSGEO4W_ROOT, "bin/python3.exe", sep="/"))
        } else {
          Sys.setenv("GRASS_PYTHON"=paste(OSGEO4W_ROOT, "bin/python.exe", sep="/"))
        }
      } else {
        if (strsplit(system(paste("g.version", get("addEXE", envir=.GRASS_CACHE), " -g ", sep=""), intern=TRUE)[1], "=")[[1]][2] > "7.6.1")
            Sys.setenv("GRASS_PYTHON"=paste("python3", get("addEXE",
                envir=.GRASS_CACHE), sep=""))
        else
            Sys.setenv("GRASS_PYTHON"=paste("python", get("addEXE",
                envir=.GRASS_CACHE), sep=""))
      }
    }

    assign("GV", gv, envir=.GRASS_CACHE)
    pfile <- paste(loc_path, "PERMANENT", "DEFAULT_WIND", sep="/")
    mSG <- FALSE
    if (!file.exists(pfile)) {
        lonlat <- FALSE
        mSG <- !missing(SG)
        if (mSG) {
            if (inherits(SG, "SpatialGrid")) {
                if (!requireNamespace("sp", quietly=TRUE))
                    stop("The sp package is required for the SG argument")
                bb <- sp::bbox(SG)
                gt <- sp::gridparameters(SG)
                wkt_SG <- sp::wkt(SG)
                lonlatSG <- !sp::is.projected(SG)
            } else if (inherits(SG, "SpatRaster")) {
                if (!requireNamespace("terra", quietly=TRUE))
                    stop("The terra package is required for the SG argument")
                bb <- getMethod("ext", "SpatRaster")(SG)
				bb <- as.vector(bb)
                bb <- matrix(bb, 2, 2, byrow=TRUE)
                colnames(bb) <- c("min", "max")
                cs <- getMethod("res", "SpatRaster")(SG)
                co <- bb[,1]+(cs/2)
                cd <- c(getMethod("ncol", "SpatRaster")(SG),
                    getMethod("nrow", "SpatRaster")(SG))
                gt <- data.frame(cellcentre.offset=co, cellsize=cs,
                    cells.dim=cd)
                wkt_SG <- getMethod("crs", "SpatRaster")(SG)
                lonlatSG <- getMethod("is.lonlat", "SpatRaster")(SG)
            } else {
                stop ("SG must be a SpatRaster or SpatialGrid object")
            }
            lonlat <- !is.na(lonlatSG) && lonlatSG
        }
        cat("proj:       ", ifelse(lonlat, 3, 99), "\n", file=pfile)
        cat("zone:       0\n", file=pfile, append=TRUE)
        cat("north:      ", ifelse(mSG, bb[2, "max"], 1), "\n",
            sep="", file=pfile, append=TRUE)
        cat("south:      ", ifelse(mSG, bb[2, "min"], 0), "\n",
            sep="", file=pfile, append=TRUE)
        cat("east:       ", ifelse(mSG, bb[1, "max"], 1), "\n",
            sep="", file=pfile, append=TRUE)
        cat("west:       ", ifelse(mSG, bb[1, "min"], 0), "\n",
            sep="", file=pfile, append=TRUE)
        cat("cols:       ", ifelse(mSG, gt$cells.dim[1], 1), "\n",
            sep="", file=pfile, append=TRUE)
        cat("rows:       ", ifelse(mSG, gt$cells.dim[2], 1), "\n",
            sep="", file=pfile, append=TRUE)
        cat("e-w resol:  ", ifelse(mSG, gt$cellsize[1], 1), "\n",
            sep="", file=pfile, append=TRUE)
        cat("n-s resol:  ", ifelse(mSG, gt$cellsize[2], 1), "\n",
            sep="", file=pfile, append=TRUE)
        cat("top:        1\n", sep="", file=pfile, append=TRUE)
        cat("bottom:     0\n", sep="", file=pfile, append=TRUE)
        cat("cols3:      ", ifelse(mSG, gt$cells.dim[1], 1), "\n",
            sep="", file=pfile, append=TRUE)
        cat("rows3:      ", ifelse(mSG, gt$cells.dim[2], 1), "\n",
            sep="", file=pfile, append=TRUE)
        cat("depths:     1\n", sep="", file=pfile, append=TRUE)
        cat("e-w resol3: ", ifelse(mSG, gt$cellsize[1], 1), "\n",
            sep="", file=pfile, append=TRUE)
        cat("n-s resol3: ", ifelse(mSG, gt$cellsize[2], 1), "\n",
            sep="", file=pfile, append=TRUE)
        cat("t-b resol:  1\n", sep="", file=pfile, append=TRUE)
    }

    tfile <- paste(loc_path, "PERMANENT", "WIND", sep="/")
    if (!file.exists(tfile)) file.copy(pfile, tfile, overwrite=TRUE)
    tfile <- paste(loc_path, mapset, "WIND", sep="/")
    if (!file.exists(tfile)) file.copy(pfile, tfile, overwrite=TRUE)
    execGRASS("g.region", save="input", flags="overwrite",
        ignore.stderr=ignore.stderr)
    if (mSG) {
        if (nzchar(wkt_SG)) {
            tf <- tempfile()
            writeLines(wkt_SG, con=tf)
            MS <- execGRASS("g.mapset", flags="p", intern=TRUE,
                ignore.stderr=ignore.stderr)
	    if (MS != "PERMANENT")
                execGRASS("g.mapset", mapset="PERMANENT", flags="quiet",
                    ignore.stderr=ignore.stderr)
            tull <- execGRASS("g.proj", flags="c", wkt=tf,
                ignore.stderr=ignore.stderr, intern=TRUE)
            execGRASS("g.region", flags="s", region=paste0("input@", mapset),
                ignore.stderr=ignore.stderr)
            execGRASS("g.region", flags="d", ignore.stderr=ignore.stderr)
	    if (MS != "PERMANENT")
                execGRASS("g.mapset", mapset=mapset, flags="quiet",
                    ignore.stderr=ignore.stderr)
        }
    }
    gmeta(ignore.stderr=ignore.stderr)
}

remove_GISRC <- function() {
    if (get("INIT_USED", envir=.GRASS_CACHE) &&
        get("remove_GISRC", envir=.GRASS_CACHE)) {
        gisrc <- Sys.getenv("GISRC")
        if (file.exists(gisrc)) unlink(gisrc)
        Sys.unsetenv("GISRC")
    }
}