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,
......
This diff is collapsed.
......@@ -9,11 +9,27 @@
#' @param g green channel (integer)
#' @param b blue channel (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 plot_on_browser plot on the browser or inline in a notebook (default TRUE)
#' @return a leafLet map
#'
#' @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
##############################################################################
if (exists("color") == F) {
......@@ -113,7 +129,11 @@ iplot <- function(x, y, HaTy, r, g, b, acc, outPath, plot_on_browser = TRUE) {
######
rr <- x
raster::values(rr) <- 1:raster::ncell(rr)
x <- raster::calc(
x,
fun = function(y)
(y - num_models)
)
##############################################################################
##[2] Create Leaflet Html output for Webbrowser
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) {
layerId = HaTy,
prefix = "Habitat Type"
)
mv <- leaflet::addLegend(
map = mv,
"bottomright",
pal = pal,
values = raster::cellStats(x, "range"),
title = "Habitat Type Probability",
opacity = 1
)
if (num_models<11) {
mv <- leaflet::addLegend(
map = mv,
"bottomright",
pal = pal,
labFormat = leaflet::labelFormat(suffix = " Models",
transform = function(x) seq(0, num_models, 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,
overlayGroups = c("RGB Composite", HaTy))
......@@ -168,7 +201,6 @@ iplot <- function(x, y, HaTy, r, g, b, acc, outPath, plot_on_browser = TRUE) {
file = paste(outPath, 'leaflet.html', sep = ""),
append = TRUE
)
rm(mv)
if (plot_on_browser == TRUE) {
utils::browseURL(paste(outPath, 'leaflet.html', sep = ""),
browser = "firefox")
......@@ -183,7 +215,6 @@ iplot <- function(x, y, HaTy, r, g, b, acc, outPath, plot_on_browser = TRUE) {
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 = ""),
......@@ -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>",
# file = "leaflet.html",
# append = TRUE)
return(mv)
}
################################################################################
......
......@@ -12,6 +12,30 @@
#'
#' @export
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##
setwd(inPath)
files <- grep(list.files()[grep(list.files(), pattern = ".tif$")],
......@@ -158,4 +182,5 @@ plot_results <- function(inPath, color = NULL) {
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,
filename = paste(outPath,
paste("step_",
step,
paste("_", classNames[index], sep = ""),
".tif",
sep = ""),
sep = ""),
format = "GTiff",
overwrite = overwrite)
}
#' Save KML
#'
#' Saves the classification result into a KML file.
#'
#' @param outPath output path
#' @param step step number
#' @param raster the raster values
#' @param overwrite overwrite files or not
#'
#' @export
save_kml <- function(outPath, step, raster, overwrite) {
kml <- raster::projectRaster(raster,
crs = "+proj=longlat +datum=WGS84",
method = 'ngb')
raster::KML(kml, paste(outPath, paste("step_", step, sep = ""), sep = ""), overwrite = overwrite)
}
\ No newline at end of file
#' Load time series stack
#'
#' It loads a time series stack from a .tif file
#'
#' @param satellite_series_path path to the time series stack .tif file
#' @param sat_crs_str string with the CRS projection, e.g., '+proj=utm +zone=32 +datum=WGS84 +units=m +no_defs'
#'
#' @return a raster object
#' @export
load_timeseries_stack <- function(satellite_series_path, sat_crs_str = "") {
series <- raster::brick(satellite_series_path)
if (is.na(raster::crs(series))) {
if (sat_crs_str == "") {
stop("Please either set Satellite's time series projection before loading the file or pass the CRS string as argument: sat_crs_str='+proj=utm +zone=32 +datum=WGS84 +units=m +no_defs' ")
} else {
sp::proj4string(series) <- sat_crs_str
}
}
return(series)
}
#' Load reference data as a table
#'
#' It loads reference data from a .txt file.
#'
#' @param table_path path to the reference data table .txt file
#'
#' @return reference spectra as a data.frame
#' @export
load_reference_as_table <- function(table_path) {
ref <- read.table(table_path, header = TRUE)
return(ref)
}
#' Extract reference data with a shapefile
#'
#' It extracts from the Satellite time series stack using a shapefile the reference data.
#'
#' @param shp_path path to the shapefile (.shp file)
#' @param satellite_series_path path to the time series stack .tif file
#' @param shp_crs_str string with the CRS projection, e.g., '+proj=utm +zone=33 +datum=WGS84 +units=m +no_defs'
#'
#' @return reference spectra as a data.frame
#' @export
load_reference_as_shape <- function(shp_path, satellite_series_path, shp_crs_str = "") {
shp <- rgdal::readOGR(shp_path)
series <- raster::brick(satellite_series_path)
if (is.na(sp::is.projected(shp))) {
if (shp_crs_str == "") {
stop("Please either set shapefile's projection before loading the file or pass the CRS string as argument: shp_crs_str='+proj=utm +zone=33 +datum=WGS84 +units=m +no_defs' ")
} else {
sp::proj4string(shp) <- shp_crs_str
}
}
if (!raster::compareCRS(series, shp)) {
shp <- sp::spTransform(shp,raster::crs(series))
}
ref <- as.data.frame(raster::extract(series,shp))
return(ref)
}
#' Plot configuration
#'
#' It helps the user to choose three wavebands for the background plot.
#' Through a plot the user can also verify where the reference points are located.
#'
#' @param shp_path path to the shapefile (.shp file)
#' @param satellite_series_path path to the time series stack .tif file
#' @param plot_rgb triple with red, green and blue wavebands index in the satellite time series stack
#' @param shp_crs_str string with the CRS projection, e.g., '+proj=utm +zone=33 +datum=WGS84 +units=m +no_defs'
#'
#' @export
plot_configuration <- function(shp_path, satellite_series_path, plot_rgb, shp_crs_str = ""){
shp_crs_str = '+proj=utm +zone=33 +datum=WGS84 +units=m +no_defs'
shp <- rgdal::readOGR(shp_path)
series <- raster::brick(satellite_series_path)
if (is.na(sp::is.projected(shp))) {
if (shp_crs_str == "") {
stop("Please either set shapefile's projection before loading the file or pass the CRS string as argument: shp_crs_str='+proj=utm +zone=33 +datum=WGS84 +units=m +no_defs' ")
} else {
sp::proj4string(shp) <- shp_crs_str
}
}
if (!raster::compareCRS(series, shp)) {
shp <- sp::spTransform(shp,raster::crs(series))
}
raster::plotRGB(series, r = plot_rgb["r"], g = plot_rgb["g"], b = plot_rgb["b"], stretch = "lin", axes = TRUE)
raster::plot(shp, pch = 21, bg = "red", col = "yellow", ex = 1.9, lwd = 2.5, add = TRUE)
}
......@@ -7,7 +7,9 @@
clip(raster, shape)
}
\arguments{
\item{shape}{}
\item{raster}{raster object}