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

Merge and solve conflicts

parents 72c75989 d2a87c9a
File added
.Rproj.user
.Rhistory
.RData
.Ruserdata
stages:
- test
- deploy
- cleanup
test_hasa_install:
stage: test
script:
- Rscript docker/context/install_runner.R
only:
- master
pages: # this job must be called 'pages' to advise GitLab to upload content to GitLab Pages
stage: deploy
dependencies:
- test_hasa_install
script:
# Create the public directory
- rm -rf public
- mkdir public
- mkdir -p public/doc
- mkdir -p public/images/
# Copy over the docs
- cp -r docs/*.html public/index.html
- cp -r docs/images/* public/images/
# Check if everything is working great
- ls -al public
- ls -al public/doc
artifacts:
paths:
- public
expire_in: 30 days
only:
- master
- documentation
Version: 1.0
RestoreWorkspace: Default
SaveWorkspace: Default
AlwaysSaveHistory: Default
EnableCodeIndexing: Yes
UseSpacesForTab: Yes
NumSpacesForTab: 2
Encoding: UTF-8
RnwWeave: Sweave
LaTeX: pdfLaTeX
......@@ -11,9 +11,9 @@ Description: Calculates samples and related classifiers for mapping gradual prob
License: GPL-3
Imports:
BH (<= 1.69.0-1),
sf (<= 0.8-1),
sp (<= 1.4-1),
rgdal (<= 1.4-8),
sf,
sp,
rgdal,
raster,
geojsonio,
maptools,
......@@ -33,6 +33,6 @@ LazyData: true
Roxygen: list(markdown = TRUE)
RoxygenNote: 7.1.1
Suggests:
knitr,
rmarkdown
rmarkdown,
knitr
VignetteBuilder: knitr
......@@ -2,7 +2,15 @@
export(clip)
export(iplot)
export(load_reference_as_shape)
export(load_reference_as_table)
export(load_timeseries_stack)
export(multi_Class_Sampling)
export(plot_configuration)
export(plot_results)
export(sample_nb)
export(save_class_tiff)
export(save_kml)
export(save_run)
export(write_Out_Samples)
exportClasses(Habitat)
......@@ -2,8 +2,8 @@
#'
#' Clips a raster object
#'
#' @param raster
#' @param shape
#' @param raster raster object
#' @param shape shape object
#'
#' @return a raster object
#' @export
......
......@@ -18,11 +18,14 @@
#' @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
#' @param progress_bar if true use a normal progress bar, otherwise a shiny's progress bar
#'
#' @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
#' @return a list with 5 elements:
#' 1) returns 0 succeeded, 1 increase init.samples, or 2 increase init.samples and nb_models
#' 2) An index
#' 3) num_models number of models selected
#' 4) Accuracy vector
#' 5) A vector with a Habitat objects, each consisting of 7 slots: \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
......@@ -32,6 +35,7 @@
#' 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
#' @export
###################################################################################
......@@ -50,7 +54,10 @@ sample_nb <- function(raster,
init.seed,
save_runs,
parallel_mode,
max_num_cores) {
max_num_cores,
progress_bar = TRUE) {
print(paste(paste("init.samples = ", nb_samples[1]),
paste("models = ", nb_mean)))
###
n_channel <- length(names(raster))
###velox
......@@ -72,7 +79,7 @@ sample_nb <- function(raster,
n <- nb_it
sample_size <- r
max_samples_per_class <- sample_size * 5
if (init.seed == "sample") {
if (class(init.seed) == "character" && init.seed == "sample") {
seed2 <- sample(c(1:1000000), size = nb_mean, replace = F)
} else {
seed2 <- init.seed
......@@ -83,9 +90,11 @@ sample_nb <- function(raster,
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))
pb <- utils::txtProgressBar(min = 1,
max = nb_mean,
style = 3)
if (progress_bar == TRUE) {
pb <- utils::txtProgressBar(min = 1,
max = nb_mean,
style = 3)
}
if (parallel_mode == TRUE) {
cores = parallel::detectCores( logical = TRUE)
......@@ -145,7 +154,14 @@ sample_nb <- function(raster,
points_list[[k]] <- res$points
models_list[[k]] <- res$models
oobe[, k] <- res$oobe[, 1]
setTxtProgressBar(pb, k)
if (progress_bar) {
setTxtProgressBar(pb, k)
} else {
shinybusy::update_modal_progress(
value = k / (nb_mean + nrow(reference)),
text = paste("Doing sampling for model", k)
)
}
}
}
......@@ -155,8 +171,14 @@ sample_nb <- function(raster,
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")
out <- list(
returns = 1,
index = NULL,
num_models = 0,
acc = NULL,
obj = NULL
)
return(out)
}
if (length(which_models_null[which_models_null == FALSE]) > 0) {
models <- models_list[which_models_null]
......@@ -208,6 +230,12 @@ sample_nb <- function(raster,
}
}
m[l] <- max(dif[2,], na.rm = T)
if (!progress_bar) {
shinybusy::update_modal_progress(
value = (nb_mean+jj) / (nb_mean + nrow(reference)),
text = paste("Doing prediction for class", jj)
)
}
}
loop.taken = difftime(Sys.time(), loop.start, units = "secs")
print(sprintf("Loop 1 took %f", loop.taken))
......@@ -215,17 +243,25 @@ sample_nb <- function(raster,
index <- which.max(dif[2,])
ch <- as.numeric(na.omit(channel[, index]))
if (length(ch) == 0) {
stop(
"No optimal classifier - would you be so kind to adjust init.samples & nb_models, please"
out <- list(
returns = 2,
index = NULL,
num_models = 0,
acc = NULL,
obj = NULL
)
return(out)
}
acc <- (round(m[l] ^ 2, 2) / 0.25)
cat("\n")
print(paste("class=", index, " difference=", (round(m[l] ^ 2, 2) / 0.25),
sep = ""))
l <- l + 1
}
close(pb)
if (progress_bar == TRUE) {
close(pb)
}
if (save_runs == TRUE) {
mod_all <- models
......@@ -233,7 +269,9 @@ sample_nb <- function(raster,
mod_all = list()
}
models <- models[ch]
print(paste("n_models =", length(models)))
num_models <- length(models)
print(paste("n_models =", num_models))
flush(stdout())
switch <- switch[ch, index]
points <- points_list[ch]
remove(points_list)
......@@ -324,6 +362,12 @@ sample_nb <- function(raster,
remove(seed2)
gc(full = TRUE)
out <- list(index = index, acc = acc, obj = obj)
out <- list(
returns = 0,
index = index,
num_models = num_models,
acc = acc,
obj = obj
)
return(out)
}
......@@ -58,11 +58,11 @@ model_opt_r <- function(k,
}
pbt <- spatialEco::point.in.poly(pbt, area)[, 1:n_channel]
#f <- which(is.na(pbt@data[1]))
#if (length(f) != 0) {
# pbt <- pbt[-f,]
#}
pbt@data <- pbt@data[complete.cases(pbt@data[1]), ]
f <- which(is.na(pbt@data[1]))
if (length(f) != 0) {
pbt <- pbt[-f,]
}
set.seed(seed2[k])
classes <-
......@@ -145,7 +145,7 @@ model_opt_r <- function(k,
as.data.frame(cbind(classes[d1], matrix(p1, ncol = 2)))
sp::coordinates(pbtn1) <- c("V2", "V3")
#sp::proj4string(pbtn1) <- sp::proj4string(pbt)
crs(pbtn1) <- crs(pbt)
raster::crs(pbtn1) <- raster::crs(pbt)
poly <- rgeos::gBuffer(spgeom = pbtn1,
width = buffer,
......@@ -207,7 +207,7 @@ model_opt_r <- function(k,
as.data.frame(cbind(classes[d2], matrix(p2, ncol = 2)))
sp::coordinates(pbtn2) <- c("V2", "V3")
#sp::proj4string(pbtn2) <- sp::proj4string(pbt)
crs(pbtn2) <- crs(pbt)
raster::crs(pbtn2) <- raster::crs(pbt)
poly <- rgeos::gBuffer(spgeom = pbtn2,
width = buffer,
......
......@@ -8,18 +8,19 @@
#' @param nb_models number of models (independent classifiers) to collect
#' @param nb_it number of iterations for model accuracy
#' @param buffer distance (in m) for new sample collection around initial samples (depends on pixel size)
#' @param reference reference spectra either SpatialPointsDataFrame (shape file) or data.frame with lines = classes, column = predictors]
#' @param model which machine learning classifier to use c("rf", "svm") for random forest or suppurt vector machine implementation
#' @param reference reference spectra as a data.frame with (lines = classes, column = predictors)
#' @param model which machine learning classifier to use c("rf", "svm") for random forest or support vector machine implementation
#' @param mtry number of predictor used at random forest splitting nodes (mtry << n predictors)
#' @param last only true for one class classifier c("FALSE", TRUE")
#' @param seed set seed for reproducable results
#' @param seed set seed for reproducible results
#' @param init.seed "sample" for new or use run1@seeds to reproduce previous steps
#' @param outPath output path for saving results
#' @param step at which step should the procedure start, e.g. use step = 2 if the first habitat is already extracted
#' @param classNames character vector with class names in the order of reference spectra
#' @param classNames character vector with class names in the order of reference spectra
#' @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 color color pallet
#' @param overwrite overwrite the KML and raster files from previous runs (default TRUE)
#' @param save_runs an Habitat object is saved into disk for each run (default TRUE)
#' @param parallel_mode run loops using all available cores (default FALSE)
......@@ -84,11 +85,28 @@ multi_Class_Sampling <- function(in.raster,
n_classes,
multiTest = 1,
RGB = c(19, 20, 21),
color = c("lightgrey", "orange", "yellow", "limegreen", "forestgreen"),
overwrite = TRUE,
save_runs = TRUE,
parallel_mode = FALSE,
max_num_cores = 5,
plot_on_browser = TRUE) {
# Checks if its a new or a resumed run and asks the user to remove all .tif
# files from the results folder in case of a new run.
if(step == 1){
if (length(list.files(
outPath,
pattern = ".tif$",
all.files = FALSE,
include.dirs = TRUE,
no.. = TRUE
)) != 0) {
message("Remove all .tif files from the Results directory! Don't forget to save them and the other files.
All other files will be overwriten when a new sampling is started.")
return(NULL)
}
}
###first steps: data preparation
if (class(reference) == "SpatialPointsDataFrame") {
reference <- as.data.frame(raster::extract(in.raster, reference))
......@@ -98,7 +116,7 @@ multi_Class_Sampling <- function(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)
crs(area) <- crs(in.raster)
raster::crs(area) <- raster::crs(in.raster)
col <- colorRampPalette(c("lightgrey",
"orange",
......@@ -123,11 +141,8 @@ multi_Class_Sampling <- function(in.raster,
}
}
print(paste(paste("Habitat", 0), "Starting"))
for (i in step:r) {
print(paste(
paste("init.samples = ", init.samples),
paste("models = ", nb_models)
))
if (i == r) {
last = T
}
......@@ -139,59 +154,130 @@ multi_Class_Sampling <- function(in.raster,
new.acc <- list()
decision = "0"
##########################################################################
while (decision == "0") {
for (rs in 1:multiTest) {
########################
sample_nb.start = Sys.time()
maFo_rf <- sample_nb(
raster = in.raster,
nb_samples = seq(init.samples, init.samples, init.samples),
sample_type = sample_type,
nb_mean = nb_models,
nb_it = nb_it,
buffer = buffer,
reference = reference,
model = model,
area = area,
mtry = mtry,
last = last,
seed = seed,
init.seed = init.seed,
save_runs = save_runs,
parallel_mode = parallel_mode,
max_num_cores = max_num_cores
)
sample_nb.taken = difftime(Sys.time(), sample_nb.start, units = "secs")
print(sprintf("Sample_nb 1 took %f", sample_nb.taken))
distribution.start <- Sys.time()
index <- maFo_rf$index
acc <- maFo_rf$acc
maFo_rf <- maFo_rf$obj
returns <- 1
while (returns != 0) {
decision3 <- ""
maFo_rf <- sample_nb(
raster = in.raster,
nb_samples = seq(init.samples, init.samples, init.samples),
sample_type = sample_type,
nb_mean = nb_models,
nb_it = nb_it,
buffer = buffer,
reference = reference,
model = model,
area = area,
mtry = mtry,
last = last,
seed = seed,
init.seed = init.seed,
save_runs = save_runs,
parallel_mode = parallel_mode,
max_num_cores = max_num_cores
)
returns <- maFo_rf$returns
index <- maFo_rf$index
num_models <- maFo_rf$num_models
acc <- maFo_rf$acc
maFo_rf <- maFo_rf$obj
if (returns == 1) {
decision3 <-
readline(
paste(
"No Models - Adjust init.samples (actual: ",
init.samples,
"), abort (0) or auto (1) [.. or 0 or 1]: ",
sep = ""
)
)
if (decision3 == "0") {
print("User decided to abort the classification.")
return(NULL)
} else if (decision3 == "1") {
init.samples <- init.samples + 50
} else {
init.samples <- as.numeric(decision3)
}
} else if (returns == 2) {
decision3 <-
readline(
paste(
"No optimal classifier - Adjust init.samples/nb.models (actual ",
init.samples,
"/",
nb_models,
"), abort (0) or auto (1) [../.. or 0 or 1]: ",
sep = ""
)
)
if (decision3 == "0") {
print("User decided to abort the classification.")
return(NULL)
} else if (decision3 == "1") {
init.samples <- init.samples + 50
nb_models <- nb_models + 15
} else {
init.samples <- as.numeric(strsplit(decision3, split = "/")[[1]][1])
nb_models <-
as.numeric(strsplit(decision3, split = "/")[[1]][2])
}
}
}
########################
maFo[[rs]] <- maFo_rf
test[[rs]] <- maFo_rf@layer[[1]]
new.names[[rs]] <- index
new.acc[[rs]] <- acc
if (rs == multiTest) {
if (plot_on_browser == TRUE) {
if (.Platform$OS.type == "unix") {
grDevices::x11()
} else {
grDevices::windows()
}
attach(mtcars)
if (multiTest < 4) {
par(mfrow = c(multiTest, 1))
} else {
par(mfrow = c(round(multiTest/4), multiTest %% 4))
}
}
par(mar = c(2, 2, 2, 3), mfrow = n2mfrow(multiTest))
for (rr in 1:length(test)) {
if (plot_on_browser == FALSE) {
png(file = paste(outPath, 'multi_', rr, '.png', sep = ""), width = 600, height = 500, res = 72)
}
plot(
test[[rr]],
col = col(200),
main = "",
legend.shrink = 1)
mtext(side = 3,
paste(rr, classNames[new.names[[rr]]], sep = " "),
paste('Test ', rr, '- class ', classNames[new.names[[rr]]], sep = " "),
font = 2)
if (plot_on_browser == FALSE) {
dev.off()
IRdisplay::display_png(file = paste(outPath, 'multi_', rr, '.png', sep = ""))
}
}
}
distribution.taken = difftime(Sys.time(), distribution.start, units = "secs")
print(sprintf("Iplot 3 took %f", distribution.taken))
}
decision <-
readline("Which distribution is acceptable/ or sample again [../0]: ")
readline("Which distribution is acceptable or sample again (0) [.. or 0]: ")
if (plot_on_browser == FALSE) {
for (rr in 1:length(test)) {
fn <- paste(outPath, 'multi_', rr, '.png', sep = "")
if (file.exists(fn)) {
#Delete file if it exists
file.remove(fn)
}
}
}
}
maFo_rf <- maFo[[as.numeric(decision)]]
index <- new.names[[as.numeric(decision)]]
......@@ -202,32 +288,75 @@ multi_Class_Sampling <- function(in.raster,
##########################################################################
} else{
########################
sample_nb.start = Sys.time()
maFo_rf <- sample_nb(
raster = in.raster,
nb_samples = seq(init.samples, init.samples, init.samples),
sample_type = sample_type,
nb_mean = nb_models,
nb_it = nb_it,
buffer = buffer,
reference = reference,
model = model,
area = area,
mtry = mtry,
last = last,
seed = seed,
init.seed = init.seed,
save_runs = save_runs,
parallel_mode = parallel_mode,
max_num_cores = max_num_cores
)
sample_nb.taken = difftime(Sys.time(), sample_nb.start, units = "secs")
print(sprintf("Sample_nb 2 took %f", sample_nb.taken))
index <- maFo_rf$index
acc <- maFo_rf$acc
maFo_rf <- maFo_rf$obj
########################
returns <- 1
while (returns != 0) {
decision3 <- ""
maFo_rf <- sample_nb(
raster = in.raster,
nb_samples = seq(init.samples, init.samples, init.samples),
sample_type = sample_type,
nb_mean = nb_models,
nb_it = nb_it,
buffer = buffer,
reference = reference,
model = model,
area = area,
mtry = mtry,
last = last,
seed = seed,
init.seed = init.seed,
save_runs = save_runs,
parallel_mode = parallel_mode,
max_num_cores = max_num_cores
)
returns <- maFo_rf$returns
index <- maFo_rf$index
num_models <- maFo_rf$num_models