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 ...@@ -11,9 +11,9 @@ Description: Calculates samples and related classifiers for mapping gradual prob
License: GPL-3 License: GPL-3
Imports: Imports:
BH (<= 1.69.0-1), BH (<= 1.69.0-1),
sf (<= 0.8-1), sf,
sp (<= 1.4-1), sp,
rgdal (<= 1.4-8), rgdal,
raster, raster,
geojsonio, geojsonio,
maptools, maptools,
...@@ -33,6 +33,6 @@ LazyData: true ...@@ -33,6 +33,6 @@ LazyData: true
Roxygen: list(markdown = TRUE) Roxygen: list(markdown = TRUE)
RoxygenNote: 7.1.1 RoxygenNote: 7.1.1
Suggests: Suggests:
knitr, rmarkdown,
rmarkdown knitr
VignetteBuilder: knitr VignetteBuilder: knitr
...@@ -2,7 +2,15 @@ ...@@ -2,7 +2,15 @@
export(clip) export(clip)
export(iplot) export(iplot)
export(load_reference_as_shape)
export(load_reference_as_table)
export(load_timeseries_stack)
export(multi_Class_Sampling) export(multi_Class_Sampling)
export(plot_configuration)
export(plot_results) export(plot_results)
export(sample_nb)
export(save_class_tiff)
export(save_kml)
export(save_run)
export(write_Out_Samples) export(write_Out_Samples)
exportClasses(Habitat) exportClasses(Habitat)
...@@ -2,8 +2,8 @@ ...@@ -2,8 +2,8 @@
#' #'
#' Clips a raster object #' Clips a raster object
#' #'
#' @param raster #' @param raster raster object
#' @param shape #' @param shape shape object
#' #'
#' @return a raster object #' @return a raster object
#' @export #' @export
......
...@@ -18,11 +18,14 @@ ...@@ -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 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 parallel_mode run loops in parallel
#' @param max_num_cores maximum number of cores for parallelism #' @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: #' @return a list with 5 elements:
#' 1) An index #' 1) returns 0 succeeded, 1 increase init.samples, or 2 increase init.samples and nb_models
#' 2) Accuracy vector #' 2) An index
#' 3) A vector with a Habitat objects, each consisting of 7 slots: \cr #' 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@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@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@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 @@ ...@@ -32,6 +35,7 @@
#' run1@seeds - vector of seeds for random sampling (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 #' all files are saved with step number, the *.tif file is additionally saved with class names
#' @keywords internal #' @keywords internal
#' @export
################################################################################### ###################################################################################
...@@ -50,7 +54,10 @@ sample_nb <- function(raster, ...@@ -50,7 +54,10 @@ sample_nb <- function(raster,
init.seed, init.seed,
save_runs, save_runs,
parallel_mode, 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)) n_channel <- length(names(raster))
###velox ###velox
...@@ -72,7 +79,7 @@ sample_nb <- function(raster, ...@@ -72,7 +79,7 @@ sample_nb <- function(raster,
n <- nb_it n <- nb_it
sample_size <- r sample_size <- r
max_samples_per_class <- sample_size * 5 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) seed2 <- sample(c(1:1000000), size = nb_mean, replace = F)
} else { } else {
seed2 <- init.seed seed2 <- init.seed
...@@ -83,9 +90,11 @@ sample_nb <- function(raster, ...@@ -83,9 +90,11 @@ sample_nb <- function(raster,
dif <- matrix(NA, nrow = nb_mean, ncol = nrow(reference)) dif <- matrix(NA, nrow = nb_mean, ncol = nrow(reference))
channel <- 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)) switch <- matrix(NA, nrow = nb_mean, ncol = nrow(reference))
pb <- utils::txtProgressBar(min = 1, if (progress_bar == TRUE) {
max = nb_mean, pb <- utils::txtProgressBar(min = 1,
style = 3) max = nb_mean,
style = 3)
}
if (parallel_mode == TRUE) { if (parallel_mode == TRUE) {
cores = parallel::detectCores( logical = TRUE) cores = parallel::detectCores( logical = TRUE)
...@@ -145,7 +154,14 @@ sample_nb <- function(raster, ...@@ -145,7 +154,14 @@ sample_nb <- function(raster,
points_list[[k]] <- res$points points_list[[k]] <- res$points
models_list[[k]] <- res$models models_list[[k]] <- res$models
oobe[, k] <- res$oobe[, 1] 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, ...@@ -155,8 +171,14 @@ sample_nb <- function(raster,
length(which_models_null[which_models_null == FALSE]) == length(models_list)) { length(which_models_null[which_models_null == FALSE]) == length(models_list)) {
remove(points_list) remove(points_list)
remove(models_list) remove(models_list)
remove(ooe) out <- list(
stop("No Models - would you be so kind to increase init.samples, please") returns = 1,
index = NULL,
num_models = 0,
acc = NULL,
obj = NULL
)
return(out)
} }
if (length(which_models_null[which_models_null == FALSE]) > 0) { if (length(which_models_null[which_models_null == FALSE]) > 0) {
models <- models_list[which_models_null] models <- models_list[which_models_null]
...@@ -208,6 +230,12 @@ sample_nb <- function(raster, ...@@ -208,6 +230,12 @@ sample_nb <- function(raster,
} }
} }
m[l] <- max(dif[2,], na.rm = T) 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") loop.taken = difftime(Sys.time(), loop.start, units = "secs")
print(sprintf("Loop 1 took %f", loop.taken)) print(sprintf("Loop 1 took %f", loop.taken))
...@@ -215,17 +243,25 @@ sample_nb <- function(raster, ...@@ -215,17 +243,25 @@ sample_nb <- function(raster,
index <- which.max(dif[2,]) index <- which.max(dif[2,])
ch <- as.numeric(na.omit(channel[, index])) ch <- as.numeric(na.omit(channel[, index]))
if (length(ch) == 0) { if (length(ch) == 0) {
stop( out <- list(
"No optimal classifier - would you be so kind to adjust init.samples & nb_models, please" returns = 2,
index = NULL,
num_models = 0,
acc = NULL,
obj = NULL
) )
return(out)
} }
acc <- (round(m[l] ^ 2, 2) / 0.25) acc <- (round(m[l] ^ 2, 2) / 0.25)
cat("\n")
print(paste("class=", index, " difference=", (round(m[l] ^ 2, 2) / 0.25), print(paste("class=", index, " difference=", (round(m[l] ^ 2, 2) / 0.25),
sep = "")) sep = ""))
l <- l + 1 l <- l + 1
} }
close(pb) if (progress_bar == TRUE) {
close(pb)
}
if (save_runs == TRUE) { if (save_runs == TRUE) {
mod_all <- models mod_all <- models
...@@ -233,7 +269,9 @@ sample_nb <- function(raster, ...@@ -233,7 +269,9 @@ sample_nb <- function(raster,
mod_all = list() mod_all = list()
} }
models <- models[ch] 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] switch <- switch[ch, index]
points <- points_list[ch] points <- points_list[ch]
remove(points_list) remove(points_list)
...@@ -324,6 +362,12 @@ sample_nb <- function(raster, ...@@ -324,6 +362,12 @@ sample_nb <- function(raster,
remove(seed2) remove(seed2)
gc(full = TRUE) 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) return(out)
} }
...@@ -58,11 +58,11 @@ model_opt_r <- function(k, ...@@ -58,11 +58,11 @@ model_opt_r <- function(k,
} }
pbt <- spatialEco::point.in.poly(pbt, area)[, 1:n_channel] pbt <- spatialEco::point.in.poly(pbt, area)[, 1:n_channel]
#f <- which(is.na(pbt@data[1])) f <- which(is.na(pbt@data[1]))
#if (length(f) != 0) { if (length(f) != 0) {
# pbt <- pbt[-f,] pbt <- pbt[-f,]
#} }
pbt@data <- pbt@data[complete.cases(pbt@data[1]), ]
set.seed(seed2[k]) set.seed(seed2[k])
classes <- classes <-
...@@ -145,7 +145,7 @@ model_opt_r <- function(k, ...@@ -145,7 +145,7 @@ model_opt_r <- function(k,
as.data.frame(cbind(classes[d1], matrix(p1, ncol = 2))) as.data.frame(cbind(classes[d1], matrix(p1, ncol = 2)))
sp::coordinates(pbtn1) <- c("V2", "V3") sp::coordinates(pbtn1) <- c("V2", "V3")
#sp::proj4string(pbtn1) <- sp::proj4string(pbt) #sp::proj4string(pbtn1) <- sp::proj4string(pbt)
crs(pbtn1) <- crs(pbt) raster::crs(pbtn1) <- raster::crs(pbt)
poly <- rgeos::gBuffer(spgeom = pbtn1, poly <- rgeos::gBuffer(spgeom = pbtn1,
width = buffer, width = buffer,
...@@ -207,7 +207,7 @@ model_opt_r <- function(k, ...@@ -207,7 +207,7 @@ model_opt_r <- function(k,
as.data.frame(cbind(classes[d2], matrix(p2, ncol = 2))) as.data.frame(cbind(classes[d2], matrix(p2, ncol = 2)))
sp::coordinates(pbtn2) <- c("V2", "V3") sp::coordinates(pbtn2) <- c("V2", "V3")
#sp::proj4string(pbtn2) <- sp::proj4string(pbt) #sp::proj4string(pbtn2) <- sp::proj4string(pbt)
crs(pbtn2) <- crs(pbt) raster::crs(pbtn2) <- raster::crs(pbt)
poly <- rgeos::gBuffer(spgeom = pbtn2, poly <- rgeos::gBuffer(spgeom = pbtn2,
width = buffer, width = buffer,
......
This diff is collapsed.
...@@ -9,11 +9,27 @@ ...@@ -9,11 +9,27 @@
#' @param g green channel (integer) #' @param g green channel (integer)
#' @param b blue channel (integer) #' @param b blue channel (integer)
#' @param acc predictive accuracy (integer) #' @param acc predictive accuracy (integer)
#' @param num_models number of selected models
#' @param nb_models number of models (independent classifiers) for the specification in the legend
#' @param color color pallet
#' @param outPath file path for '.html export (character) #' @param outPath file path for '.html export (character)
#' @param plot_on_browser plot on the browser or inline in a notebook (default TRUE) #' @param plot_on_browser plot on the browser or inline in a notebook (default TRUE)
#' @return a leafLet map
#' #'
#' @export #' @export
iplot <- function(x, y, HaTy, r, g, b, acc, outPath, plot_on_browser = TRUE) { iplot <- function(x,
y,
HaTy,
r,
g,
b,
acc,
num_models,
nb_models,
color,
outPath,
plot_on_browser = TRUE) {
#x=layerInfo, y=RGB Image #x=layerInfo, y=RGB Image
############################################################################## ##############################################################################
if (exists("color") == F) { if (exists("color") == F) {
...@@ -113,7 +129,11 @@ iplot <- function(x, y, HaTy, r, g, b, acc, outPath, plot_on_browser = TRUE) { ...@@ -113,7 +129,11 @@ iplot <- function(x, y, HaTy, r, g, b, acc, outPath, plot_on_browser = TRUE) {
###### ######
rr <- x rr <- x
raster::values(rr) <- 1:raster::ncell(rr) raster::values(rr) <- 1:raster::ncell(rr)
x <- raster::calc(
x,
fun = function(y)
(y - num_models)
)
############################################################################## ##############################################################################
##[2] Create Leaflet Html output for Webbrowser ##[2] Create Leaflet Html output for Webbrowser
mv <- leaflet::leaflet(options = leaflet::leafletOptions(zoomControl = FALSE)) mv <- leaflet::leaflet(options = leaflet::leafletOptions(zoomControl = FALSE))
...@@ -149,15 +169,28 @@ iplot <- function(x, y, HaTy, r, g, b, acc, outPath, plot_on_browser = TRUE) { ...@@ -149,15 +169,28 @@ iplot <- function(x, y, HaTy, r, g, b, acc, outPath, plot_on_browser = TRUE) {
layerId = HaTy, layerId = HaTy,
prefix = "Habitat Type" prefix = "Habitat Type"
) )
if (num_models<11) {
mv <- leaflet::addLegend( mv <- leaflet::addLegend(
map = mv, map = mv,
"bottomright", "bottomright",
pal = pal, pal = pal,
values = raster::cellStats(x, "range"), labFormat = leaflet::labelFormat(suffix = " Models",
title = "Habitat Type Probability", transform = function(x) seq(0, num_models, 1)),
opacity = 1 values = c(0, num_models),
) title = paste("Number of models (", num_models," out of ", nb_models,")<br>predicting class ", HaTy, sep = ""),
opacity = 1
)
} else {
mv <- leaflet::addLegend(
map = mv,
"bottomright",
pal = pal,
labFormat = leaflet::labelFormat(suffix = " Models"),
values = c(0, num_models),
title = paste("Number of models (", num_models," out of ", nb_models,")<br>predicting class ", HaTy, sep = ""),
opacity = 1
)
}
mv <- leaflet::addLayersControl(map = mv, mv <- leaflet::addLayersControl(map = mv,
overlayGroups = c("RGB Composite", HaTy)) overlayGroups = c("RGB Composite", HaTy))
...@@ -168,7 +201,6 @@ iplot <- function(x, y, HaTy, r, g, b, acc, outPath, plot_on_browser = TRUE) { ...@@ -168,7 +201,6 @@ iplot <- function(x, y, HaTy, r, g, b, acc, outPath, plot_on_browser = TRUE) {
file = paste(outPath, 'leaflet.html', sep = ""), file = paste(outPath, 'leaflet.html', sep = ""),
append = TRUE append = TRUE
) )
rm(mv)
if (plot_on_browser == TRUE) { if (plot_on_browser == TRUE) {
utils::browseURL(paste(outPath, 'leaflet.html', sep = ""), utils::browseURL(paste(outPath, 'leaflet.html', sep = ""),
browser = "firefox") browser = "firefox")
...@@ -183,7 +215,6 @@ iplot <- function(x, y, HaTy, r, g, b, acc, outPath, plot_on_browser = TRUE) { ...@@ -183,7 +215,6 @@ iplot <- function(x, y, HaTy, r, g, b, acc, outPath, plot_on_browser = TRUE) {
htmlwidgets::saveWidget(mv, htmlwidgets::saveWidget(mv,
selfcontained = FALSE, selfcontained = FALSE,
paste(outPath, 'leaflet.html', sep = "")) paste(outPath, 'leaflet.html', sep = ""))
rm(mv)
cat( cat(
"<style>.leaflet-container {cursor: crosshair !important;}</style>", "<style>.leaflet-container {cursor: crosshair !important;}</style>",
file = paste(outPath, 'leaflet.html', sep = ""), file = paste(outPath, 'leaflet.html', sep = ""),
...@@ -201,6 +232,7 @@ iplot <- function(x, y, HaTy, r, g, b, acc, outPath, plot_on_browser = TRUE) { ...@@ -201,6 +232,7 @@ iplot <- function(x, y, HaTy, r, g, b, acc, outPath, plot_on_browser = TRUE) {
#cat("<style>.leaflet-clickable {cursor: crosshair !important;}</style>", #cat("<style>.leaflet-clickable {cursor: crosshair !important;}</style>",
# file = "leaflet.html", # file = "leaflet.html",
# append = TRUE) # append = TRUE)
return(mv)
} }
################################################################################ ################################################################################
......
...@@ -12,6 +12,30 @@ ...@@ -12,6 +12,30 @@
#' #'
#' @export #' @export
plot_results <- function(inPath, color = NULL) { plot_results <- function(inPath, color = NULL) {
# Compares the number of .kmz to that of .tif. If .tif files are missing the
# user's attention is drawn.
if (length(list.files(
inPath,
pattern = ".tif$",
all.files = FALSE,
include.dirs = TRUE,
no.. = TRUE
)) != length(list.files(
inPath,
pattern = ".kmz$",
all.files = FALSE,
include.dirs = TRUE,
no.. = TRUE
))) {
message("Make sure the number of the .tif files fits to the number of the .kmz files and that
there are no other files from previous runs.
If you have resumed a run, then the data of the aborted and the continued run needs
to be in the Results directory. You need them for plotting the classification map.")
return(NULL)
}
curr_wd <- getwd()
##3.a.1## ##3.a.1##
setwd(inPath) setwd(inPath)
files <- grep(list.files()[grep(list.files(), pattern = ".tif$")], files <- grep(list.files()[grep(list.files(), pattern = ".tif$")],
...@@ -158,4 +182,5 @@ plot_results <- function(inPath, color = NULL) { ...@@ -158,4 +182,5 @@ plot_results <- function(inPath, color = NULL) {
bty = "n" bty = "n"
) )
} }
setwd(curr_wd)
} }
#' Save a run
#'
#' Saves the run object for a step
#'
#' @param outPath output path
#' @param step step number
#' @param run the object to be saved
#'
#' @export
save_run <- function(outPath, step, run) {
save(run, file = paste(outPath, paste("Run", step, sep = ""), sep = ""))
}
#' Save Tif
#'
#' Saves the classification result into a tiff.
#'
#' @param outPath output path
#' @param step step number
#' @param classNames the names of the classes
#' @param index index of the class
#' @param raster the raster values
#' @param overwrite overwrite files or not
#'
#' @export
save_class_tiff <- function(outPath, step, classNames, index, raster, overwrite) {
raster::writeRaster(
raster,