Commit e2751391 authored by Romulo Pereira Goncalves's avatar Romulo Pereira Goncalves
Browse files

Merge branch 'docker' into 'master'

Docker

See merge request !2
parents 77bef5e6 3a42ebe5
Package: HaSa
Title: Autonomous Image Sampling and Probability Mapping
Version: 1.2.0
Version: 1.3.0
Authors@R:
person(given = "Carsten",
family = "Neumann",
......@@ -15,6 +15,7 @@ Imports:
sp (<= 1.4-1),
rgdal (<= 1.4-8),
raster,
geojsonio,
maptools,
rgeos,
spatialEco,
......@@ -24,6 +25,7 @@ Imports:
velox,
leaflet,
leafem,
IRdisplay,
htmlwidgets
Remotes:url::https://cran.r-project.org/src/contrib/Archive/velox/velox_0.2.0.tar.gz
Encoding: UTF-8
......
......@@ -15,19 +15,21 @@
#' @param last only true for one class classifier c("FALSE", TRUE")
#' @param seed set seed for reproducable results
#' @param init.seed "sample" for new or use run1@seeds to reproduce previous steps
#' @param parallel_mode run loops using all available cores
#' @param save_runs if the user wants to save the runs, if TRUE the complete Habitat Class object is returned
#' @param parallel_mode run loops in parallel
#' @param max_num_cores maximum number of cores for parallelism
#'
#' @return a list with 3 elements:
#' 1) An index
#' 2) Accuracy vector
#' 3) A vector with a Habitat objects, each consisting of 7 slots: \cr
#' run1@models - list of selected classifiers \cr
#' run1@ref_samples - list of SpatialPointsDataFrames with same length as run1@models holding reference labels [1,2] for each selected model \cr
#' run1@switch - vector of length run1@models indicating if target class equals 2, if not NA the labels need to be switched \cr
#' run1@models - list of selected classifiers (only if save_runs is TRUE) \cr
#' run1@ref_samples - list of SpatialPointsDataFrames with same length as run1@models holding reference labels [1,2] for each selected model (only if save_runs is TRUE) \cr
#' run1@switch - vector of length run1@models indicating if target class equals 2, if not NA the labels need to be switched (only if save_runs is TRUE) \cr
#' run1@layer - raster map of habitat type probability \cr
#' run1@mod_all - list of all classifiers (equals nb_models) \cr
#' run1@class_ind - vector of predictive distance measure for all habitats \cr
#' run1@seeds - vector of seeds for random sampling \cr
#' run1@mod_all - list of all classifiers (equals nb_models) (only if save_runs is TRUE) \cr
#' run1@class_ind - vector of predictive distance measure for all habitats (only if save_runs is TRUE) \cr
#' run1@seeds - vector of seeds for random sampling (only if save_runs is TRUE) \cr
#' all files are saved with step number, the *.tif file is additionally saved with class names
#' @keywords internal
......@@ -46,7 +48,9 @@ sample_nb <- function(raster,
last,
seed,
init.seed,
parallel_mode) {
save_runs,
parallel_mode,
max_num_cores) {
###
n_channel <- length(names(raster))
###velox
......@@ -74,8 +78,8 @@ sample_nb <- function(raster,
seed2 <- init.seed
}
oobe <- matrix(NA, nrow = n, ncol = nb_mean)
models <- list()
points <- list()
models_list <- list()
points_list <- list()
dif <- matrix(NA, nrow = nb_mean, ncol = nrow(reference))
channel <- matrix(NA, nrow = nb_mean, ncol = nrow(reference))
switch <- matrix(NA, nrow = nb_mean, ncol = nrow(reference))
......@@ -85,6 +89,12 @@ sample_nb <- function(raster,
if (parallel_mode == TRUE) {
cores = parallel::detectCores( logical = TRUE)
if (cores > max_num_cores) {
cores <- max_num_cores
} else {
cores <- cores - 1
}
res <- parallel::mclapply(
1:nb_mean,
model_opt_r,
......@@ -103,11 +113,13 @@ sample_nb <- function(raster,
pbtn2 = pbtn2,
ras_vx = ras.vx,
max_samples_per_class = max_samples_per_class,
mc.cores = cores
mc.cores = cores,
mc.preschedule = TRUE,
mc.cleanup = TRUE
)
for (k in 1:nb_mean) {
points[[k]] <- res[["k" = k]][["points"]]
models[[k]] <- res[["k" = k]][["models"]]
points_list[[k]] <- res[["k" = k]][["points"]]
models_list[[k]] <- res[["k" = k]][["models"]]
oobe[, k] <- res[["k" = k]][["oobe"]][, 1]
}
} else {
......@@ -130,22 +142,29 @@ sample_nb <- function(raster,
ras_vx = ras.vx,
max_samples_per_class = max_samples_per_class
)
points[[k]] <- res$points
models[[k]] <- res$models
points_list[[k]] <- res$points
models_list[[k]] <- res$models
oobe[, k] <- res$oobe[, 1]
setTxtProgressBar(pb, k)
}
}
#which_models_null <- which(models == "NULL")
which_models_null <- vapply(models, is.not.null <- function(x){!is.null(x)}, FALSE)
if (length(models) == 0 |
length(which_models_null[which_models_null == FALSE]) == length(models)) {
which_models_null <- vapply(models_list, is.not.null <- function(x){!is.null(x)}, FALSE)
if (length(models_list) == 0 |
length(which_models_null[which_models_null == FALSE]) == length(models_list)) {
remove(points_list)
remove(models_list)
remove(ooe)
stop("No Models - would you be so kind to increase init.samples, please")
}
if (length(which_models_null[which_models_null == FALSE]) > 0) {
models <- models[which_models_null]
models <- models_list[which_models_null]
} else {
models <- models_list
}
remove(models_list)
for (jj in 1:nrow(reference)) {
ref <- jj
rr = 3
......@@ -204,11 +223,16 @@ sample_nb <- function(raster,
}
close(pb)
mod_all <- models
if (save_runs == TRUE) {
mod_all <- models
} else {
mod_all = list()
}
models <- models[ch]
print(paste("n_models =", length(models)))
switch <- switch[ch, index]
points <- points[ch]
points <- points_list[ch]
remove(points_list)
dif <- dif[2,]
##############################################################################
###Vohersage
......@@ -241,16 +265,38 @@ sample_nb <- function(raster,
dummy <- raster::calc(dummy, fun = sum)
layer[[1]] <- dummy
obj <- new(
"Habitat",
models = models,
ref_samples = points,
switch = switch,
layer = layer,
mod_all = mod_all,
class_ind = dif,
seeds = seed2
)
if (save_runs == TRUE) {
obj <- new(
"Habitat",
models = models,
ref_samples = points,
switch = switch,
layer = layer,
mod_all = mod_all,
class_ind = dif,
seeds = seed2
)
} else {
obj <- new(
"Habitat",
models = list(),
ref_samples = list(),
switch = vector(),
layer = layer,
mod_all = list(),
class_ind = 0,
seeds = 0
)
}
remove(models)
remove(points)
remove(switch)
remove(layer)
remove(mod_all)
remove(dif)
remove(seed2)
gc(full = TRUE)
out <- list(index = index, acc = acc, obj = obj)
return(out)
}
......@@ -120,10 +120,7 @@ model_opt_r <- function(k,
break
}
}
model_pre <- model1
pbtn1_pre <- pbtn1
pbtn2_pre <- pbtn2
oobe <- oobe
########################################################################
if (model == "rf") {
correct <-
......@@ -138,8 +135,6 @@ model_opt_r <- function(k,
if (length(which_classes_correct) == 0) {
if (j == 1) {
break
} else{
pbtn1 <- pbtn1
}
} else {
d1 <- correct[which_classes_correct]
......@@ -149,7 +144,8 @@ model_opt_r <- function(k,
pbtn1 <-
as.data.frame(cbind(classes[d1], matrix(p1, ncol = 2)))
sp::coordinates(pbtn1) <- c("V2", "V3")
sp::proj4string(pbtn1) <- sp::proj4string(pbt)
#sp::proj4string(pbtn1) <- sp::proj4string(pbt)
crs(pbtn1) <- crs(pbt)
poly <- rgeos::gBuffer(spgeom = pbtn1,
width = buffer,
......@@ -201,8 +197,6 @@ model_opt_r <- function(k,
if (length(which_classes_correct_2) == 0) {
if (j == 1) {
break
} else{
pbtn2 <- pbtn2
}
} else {
d2 <- correct[which_classes_correct_2]
......@@ -212,7 +206,8 @@ model_opt_r <- function(k,
pbtn2 <-
as.data.frame(cbind(classes[d2], matrix(p2, ncol = 2)))
sp::coordinates(pbtn2) <- c("V2", "V3")
sp::proj4string(pbtn2) <- sp::proj4string(pbt)
#sp::proj4string(pbtn2) <- sp::proj4string(pbt)
crs(pbtn2) <- crs(pbt)
poly <- rgeos::gBuffer(spgeom = pbtn2,
width = buffer,
......@@ -298,6 +293,8 @@ model_opt_r <- function(k,
classes <- data$classes
pbt <- rbind(pbtn1, pbtn2)
}
remove(pbt)
return(list(
"k" = k,
"models" = models,
......
......@@ -20,13 +20,15 @@
#' @param n_classes total number of classes (habitat types) to be separated
#' @param multiTest number of test runs to compare different probability outputs
#' @param RGB rgb channel numbers for image plot
#' @param overwrite overwrite the results file
#' @param parallel_mode run loops using all available cores
#' @param overwrite overwrite the KML and raster files from previous runs (default TRUE)
#' @param save_runs an Habitat object and extra info (to restart a run) is saved (default TRUE)
#' @param parallel_mode run loops using all available cores (default FALSE)
#' @param max_num_cores maximum number of cores for parallelism (default 5)
#' @param plot_on_browser plot on the browser or inline in a notebook (default TRUE)
#'
#' @return 4 files per step:
#' 1) Habitat type probability map as geocoded *.kml layer and *.tif raster files and *.png image output
#' 2) A Habitat object consisting of 7 slots: \cr
#' 2) A Habitat object (only if save_runs is set to TRUE) consisting of 7 slots: \cr
#' run1@models - list of selcted classifiers \cr
#' run1@ref_samples - list of SpatialPointsDataFrames with same length as run1@models holding reference labels [1,2] for each selected model \cr
#' run1@switch - vector of lenght run1@models indicating if target class equals 2, if not NA the labels need to be switched \cr
......@@ -83,7 +85,10 @@ multi_Class_Sampling <- function(in.raster,
multiTest = 1,
RGB = c(19, 20, 21),
overwrite = TRUE,
parallel_mode = FALSE) {
save_runs = TRUE,
parallel_mode = FALSE,
max_num_cores = 5,
plot_on_browser = TRUE) {
###first steps: data preparation
if (class(reference) == "SpatialPointsDataFrame") {
reference <- as.data.frame(raster::extract(in.raster, reference))
......@@ -92,7 +97,8 @@ multi_Class_Sampling <- function(in.raster,
input_raster <- in.raster
area <- as(raster::extent(in.raster), 'SpatialPolygons')
area <- sp::SpatialPolygonsDataFrame(area, data.frame(ID = 1:length(area)))
sp::proj4string(area) <- sp::proj4string(in.raster)
#sp::proj4string(area) <- sp::proj4string(in.raster)
crs(area) <- crs(in.raster)
col <- colorRampPalette(c("lightgrey",
"orange",
......@@ -151,7 +157,9 @@ multi_Class_Sampling <- function(in.raster,
last = last,
seed = seed,
init.seed = init.seed,
parallel_mode = parallel_mode
save_runs = save_runs,
parallel_mode = parallel_mode,
max_num_cores = max_num_cores
)
index <- maFo_rf$index
......@@ -182,6 +190,9 @@ multi_Class_Sampling <- function(in.raster,
maFo_rf <- maFo[[as.numeric(decision)]]
index <- new.names[[as.numeric(decision)]]
acc <- new.acc[[as.numeric(decision)]]
remove(maFo)
remove(new.names)
remove(new.acc)
##########################################################################
} else{
########################
......@@ -199,7 +210,9 @@ multi_Class_Sampling <- function(in.raster,
last = last,
seed = seed,
init.seed = init.seed,
parallel_mode = parallel_mode
save_runs = save_runs,
parallel_mode = parallel_mode,
max_num_cores = max_num_cores
)
index <- maFo_rf$index
......@@ -217,7 +230,8 @@ multi_Class_Sampling <- function(in.raster,
g = RGB[2],
b = RGB[3],
acc = acc,
outPath = outPath
outPath = outPath,
plot_on_browser = plot_on_browser
)
decision <-
......@@ -226,6 +240,7 @@ multi_Class_Sampling <- function(in.raster,
sample2 <- init.samples
models2 <- nb_models
while (decision == "0") {
remove(maFo_rf)
decision2 <-
readline("Adjust init.samples/nb.models or auto [../.. or 0]: ")
if (decision2 != "0") {
......@@ -253,7 +268,9 @@ multi_Class_Sampling <- function(in.raster,
last = last,
seed = seed,
init.seed = init.seed,
parallel_mode = parallel_mode
save_runs = save_runs,
parallel_mode = parallel_mode,
max_num_cores = max_num_cores
)
index <- maFo_rf$index
......@@ -270,20 +287,25 @@ multi_Class_Sampling <- function(in.raster,
g = RGB[2],
b = RGB[3],
acc = acc,
outPath = outPath
outPath = outPath,
plot_on_browser = plot_on_browser
)
decision <-
readline("Threshold for Habitat Extraction or Sample Again [../0]: ")
}
run1 <- maFo_rf
if (i < 10) {
ni <- paste("0", i, sep = "")
} else{
ni <- i
}
save(run1, file = paste(outPath, paste("Run", ni, sep = ""), sep = ""))
if ( save_runs == TRUE) {
run1 <- maFo_rf
save(run1, file = paste(outPath, paste("Run", ni, sep = ""), sep = ""))
remove(run1)
}
###rgdal version issue
not_good_workaround <- comment(dummy@crs)
comment(dummy@crs) <- ""
......@@ -312,12 +334,16 @@ multi_Class_Sampling <- function(in.raster,
dummy <- maFo_rf@layer[[1]]
dummy[dummy < thres] <- 1
dummy[dummy >= thres] <- NA
in.raster <- in.raster * dummy
reference <- reference[-index,]
out.reference <<- reference
classNames <- classNames[-index]
out.names <<- classNames
in.raster <- in.raster * dummy
out.raster <<- in.raster
if (save_runs) {
out.reference <<- reference
out.names <<- classNames
out.raster <<- in.raster
}
remove(dummy)
remove(maFo_rf)
print(paste(paste("Habitat", i), "Done"))
......@@ -335,6 +361,8 @@ multi_Class_Sampling <- function(in.raster,
paste("threshold_step_", ni, sep = ""),
sep = ""))
}
# Release memory
gc(full = TRUE)
if (i == r) {
print("Congratulation - you finally made it towards the last habitat")
......
......@@ -10,9 +10,10 @@
#' @param b blue channel (integer)
#' @param acc predictive accuracy (integer)
#' @param outPath file path for '.html export (character)
#' @param plot_on_browser plot on the browser or inline in a notebook (default TRUE)
#'
#' @export
iplot <- function(x, y, HaTy, r, g, b, acc, outPath) {
iplot <- function(x, y, HaTy, r, g, b, acc, outPath, plot_on_browser = TRUE) {
#x=layerInfo, y=RGB Image
##############################################################################
if (exists("color") == F) {
......@@ -165,18 +166,35 @@ iplot <- function(x, y, HaTy, r, g, b, acc, outPath) {
file = paste(outPath, 'leaflet.html', sep = ""),
append = TRUE
)
utils::browseURL(paste(outPath, 'leaflet.html', sep =
""), browser = "firefox")
rm(mv)
if (plot_on_browser == TRUE) {
utils::browseURL(paste(outPath, 'leaflet.html', sep = ""),
browser = "firefox")
} else {
html_code = sprintf(
'<iframe src="%s" width=1000 height=550></iframe>',
paste(outPath, 'leaflet.html', sep = "")
)
IRdisplay::display_html(html_code)
}
} else {
htmlwidgets::saveWidget(mv,
selfcontained = FALSE,
paste(outPath, 'leaflet.html', sep = ""))
rm(mv)
cat(
"<style>.leaflet-container {cursor: crosshair !important;}</style>",
file = paste(outPath, 'leaflet.html', sep = ""),
append = TRUE
)
utils::browseURL(paste(outPath, 'leaflet.html', sep = ""))
if (plot_on_browser == TRUE) {
utils::browseURL(paste(outPath, 'leaflet.html', sep = ""))
} else {
html_code = sprintf(
'<iframe src="%s" width=1000 height=550></iframe>',
paste(outPath, 'leaflet.html', sep = ""))
IRdisplay::display_html(html_code)
}
}
#cat("<style>.leaflet-clickable {cursor: crosshair !important;}</style>",
# file = "leaflet.html",
......
......@@ -4,7 +4,7 @@
\alias{iplot}
\title{Plot Habitat Types}
\usage{
iplot(x, y, HaTy, r, g, b, acc, outPath)
iplot(x, y, HaTy, r, g, b, acc, outPath, plot_on_browser = TRUE)
}
\arguments{
\item{x}{probability image (*rasterObject)}
......@@ -22,6 +22,8 @@ iplot(x, y, HaTy, r, g, b, acc, outPath)
\item{acc}{predictive accuracy (integer)}
\item{outPath}{file path for '.html export (character)}
\item{plot_on_browser}{plot on the browser or inline in a notebook (default TRUE)}
}
\description{
A quick wrapper to produce an interactive raster map of habitat type probability in a web browser using leaflet
......
......@@ -24,7 +24,10 @@ multi_Class_Sampling(
multiTest = 1,
RGB = c(19, 20, 21),
overwrite = TRUE,
parallel_mode = FALSE
save_runs = TRUE,
parallel_mode = FALSE,
max_num_cores = 5,
plot_on_browser = TRUE
)
}
\arguments{
......@@ -64,15 +67,21 @@ multi_Class_Sampling(
\item{RGB}{rgb channel numbers for image plot}
\item{overwrite}{overwrite the results file}
\item{overwrite}{overwrite the KML and raster files from previous runs (default TRUE)}
\item{parallel_mode}{run loops using all available cores}
\item{save_runs}{an Habitat object and extra info (to restart a run) is saved (default TRUE)}
\item{parallel_mode}{run loops using all available cores (default FALSE)}
\item{max_num_cores}{maximum number of cores for parallelism (default 5)}
\item{plot_on_browser}{plot on the browser or inline in a notebook (default TRUE)}
}
\value{
4 files per step:
\enumerate{
\item Habitat type probability map as geocoded *.kml layer and *.tif raster files and *.png image output
\item A Habitat object consisting of 7 slots: \cr
\item A Habitat object (only if save_runs is set to TRUE) consisting of 7 slots: \cr
run1@models - list of selcted classifiers \cr
run1@ref_samples - list of SpatialPointsDataFrames with same length as run1@models holding reference labels \link{1,2} for each selected model \cr
run1@switch - vector of lenght run1@models indicating if target class equals 2, if not NA the labels need to be switched \cr
......
......@@ -18,7 +18,9 @@ sample_nb(
last,
seed,
init.seed,
parallel_mode
save_runs,
parallel_mode,
max_num_cores
)
}
\arguments{
......@@ -46,7 +48,11 @@ sample_nb(
\item{init.seed}{"sample" for new or use run1@seeds to reproduce previous steps}
\item{parallel_mode}{run loops using all available cores}
\item{save_runs}{if the user wants to save the runs, if TRUE the complete Habitat Class object is returned}
\item{parallel_mode}{run loops in parallel}
\item{max_num_cores}{maximum number of cores for parallelism}
\item{nb_models}{number of models (independent classifiers) to collect}
}
......@@ -56,13 +62,13 @@ a list with 3 elements:
\item An index
\item Accuracy vector
\item A vector with a Habitat objects, each consisting of 7 slots: \cr
run1@models - list of selected classifiers \cr
run1@ref_samples - list of SpatialPointsDataFrames with same length as run1@models holding reference labels \link{1,2} for each selected model \cr
run1@switch - vector of length run1@models indicating if target class equals 2, if not NA the labels need to be switched \cr
run1@models - list of selected classifiers (only if save_runs is TRUE) \cr
run1@ref_samples - list of SpatialPointsDataFrames with same length as run1@models holding reference labels \link{1,2} for each selected model (only if save_runs is TRUE) \cr
run1@switch - vector of length run1@models indicating if target class equals 2, if not NA the labels need to be switched (only if save_runs is TRUE) \cr
run1@layer - raster map of habitat type probability \cr
run1@mod_all - list of all classifiers (equals nb_models) \cr
run1@class_ind - vector of predictive distance measure for all habitats \cr
run1@seeds - vector of seeds for random sampling \cr
run1@mod_all - list of all classifiers (equals nb_models) (only if save_runs is TRUE) \cr
run1@class_ind - vector of predictive distance measure for all habitats (only if save_runs is TRUE) \cr
run1@seeds - vector of seeds for random sampling (only if save_runs is TRUE) \cr
all files are saved with step number, the *.tif file is additionally saved with class names
}
}
......
This diff is collapsed.
......@@ -25,16 +25,7 @@
##0)##
#####
##0.1##
wd<-"./demo/"
setwd(wd)
##0.2##
inPath<-"./Funktionen/"
dataPath<-"./Data/"
outPath<-paste(wd,"Data/Results/",sep="")
##0.3##
##0.0##
install.packages("https://cran.r-project.org/src/contrib/Archive/BH/BH_1.69.0-1.tar.gz", repos=NULL, type="source")
install.packages("https://cran.r-project.org/src/contrib/Archive/sf/sf_0.8-1.tar.gz", repos=NULL, type="source")
install.packages("https://cran.r-project.org/src/contrib/Archive/sp/sp_1.4-1.tar.gz", repos=NULL, type="source")
......@@ -49,6 +40,17 @@ remotes::install_git(
build_manual = TRUE,
build_vignettes = TRUE
)
##0.1##
wd<-"./demo/"
setwd(wd)
##0.2##
inPath<-"./Funktionen/"
dataPath<-"./Data/"
outPath<-"Data/Results/"
##0.3##
libraries <- c("rgdal","raster","maptools","spatialEco","randomForest","e1071","devtools","velox","rgeos","leaflet","htmlwidgets", "HaSa")
lapply(libraries, library, character.only = TRUE)
rasterOptions(tmpdir="./RasterTmp/")
......@@ -92,11 +94,11 @@ classNames<-c("deciduous","coniferous","heather_young","heather_old","heather_sh
######