Nothing
# This file is a part of zonator package
# Copyright (C) 2012-2014 Joona Lehtomaki <joona.lehtomaki@gmai.com>. All rights
# reserved.
# This program is open source software; you can redistribute it and/or modify
# it under the terms of the FreeBSD License (keep this notice):
# http://en.wikipedia.org/wiki/BSD_licenses
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
# copy_zvariant -----------------------------------------------------------
#' @rdname copy_zvariant-methods
#' @aliases copy_zvariant
#'
setMethod("copy_zvariant", signature("Zvariant", "character", "character"),
function(x, name, dir) {
# Copying is effectively replacing the old variant name and path with the
# new ones in ALL locations affected (also within the actual configuration
# files). Get all the components that need replacing.
old_name <- x@name
old_bat_file <- x@bat.file
old_root <- dirname(old_bat_file)
old_spp_file <- x@call.params$spp.file
old_dat_file <- x@call.params$dat.file
old_spp_data <- x@spp.data
old_dat_data <- x@dat.data
old_call_params <- x@call.params
old_output_dir <- x@output.dir
new_name <- name
new_root <- dir
if (!dir.exists(new_root)) {
message("Creating new root directory at ", new_root)
dir.create(new_root, recursive = TRUE)
}
# Full path includes also dir
new_full_path <- file.path(new_root, new_name)
# Saving a Zvariant does create the necessary directories. Do this manually
dir.create(new_full_path, recursive = TRUE)
# Make a copy of the Zvariant object
new_x <- x
# Make all replacements
# Name
new_x@name <- new_name
# bat-file
new_bat_file <- paste0(new_full_path, ".bat")
new_x@bat.file <- new_bat_file
# spp-file
new_spp_file <- gsub(old_name, name, old_spp_file)
new_spp_file <- gsub(old_root, dir, old_spp_file)
new_x@call.params$spp.file <- new_spp_file
# dat-file
new_dat_file <- gsub(old_name, name, old_dat_file)
new_dat_file <- gsub(old_root, dir, old_dat_file)
new_x@call.params$dat.file <- new_dat_file
# spp data
new_spp_data <- old_spp_data
new_spp_data$filepath <- sapply(new_spp_data$filepath, file_path_relative_to,
old_bat_file, new_bat_file, USE.NAMES = FALSE)
new_x@spp.data <- new_spp_data
# dat data
# FIXME: Current implementation does not account for all the possible
# parameters that might need replacing in the dat file. Needs to be
# expanded.
new_dat_data <- old_dat_data
new_x@dat.data[['Settings']] <- lapply(new_dat_data[['Settings']],
function(x) gsub(old_name, new_name, x))
# call parameters
new_call_params <- old_call_params
new_call_params <- lapply(new_call_params,
function(x) {
x <- gsub(old_root, new_root, x)
x <- gsub(old_name, new_name, x)
return(x)
})
new_x@call.params <- new_call_params
# Output.dir
new_output_dir <- gsub(old_root, new_root, old_output_dir)
new_output_dir <- gsub(old_name, new_name, new_output_dir)
new_x@output.dir <- new_output_dir
dir.create(new_output_dir, recursive = TRUE)
# Reset results as these are not copied anyways
new_x@results <- new("Zresults", root = new_x@call.params$output.folder)
# Save everything
save_zvariant(new_x, overwrite = TRUE)
return(new_x)
})
# cost --------------------------------------------------------------------
#' @rdname cost-methods
#' @aliases cost,Zresults-method
#'
setMethod("cost", signature("Zvariant"), function(x) {
if (has_results(x)$curves) {
cost.data <- cost(results(x))
} else {
cost.data <- NA
warning("No results (curves) data available")
}
return(cost.data)
})
# curves ------------------------------------------------------------------
#' @rdname curves-methods
#' @aliases curves,Zresults-method
#'
setMethod("curves", c("Zvariant"), function(x, cols=NULL, groups=FALSE,
lost.lower=0.0, lost.upper=1.0) {
return(curves(results(x), cols, groups, lost.lower, lost.upper))
})
# featurenames ------------------------------------------------------------
#' @rdname featurenames-methods
#'
setMethod("featurenames", signature("Zvariant"), function(x) {
if (all(is.na(x@spp.data))) {
stop("No spp data found")
}
if (!"name" %in% names(x@spp.data)) {
stop("spp data doesn't have 'name' column defined")
}
return(x@spp.data$name)
})
# featurenames<- ----------------------------------------------------------
#' @name featurenames<-
#' @rdname featurenames-methods
#' @aliases featurenames<-,Zvariant,character-method
#'
setReplaceMethod("featurenames", c("Zvariant", "character"), function(x, value) {
# Check names
value <- check_names(value)
# Control for length, no cycling allowed
if (length(value) != nrow(x@spp.data)) {
stop(paste0("Character vector length (", length(value), " and object spp ",
"data length (", nrow(x@spp.data), " should be the same"))
}
x@spp.data$name <- value
# Also deal with the results data if available
if (any(dim(x@results@curves) != c(0, 0))) {
featurenames(x@results@curves) <- value
}
return(x)
})
# features_info -----------------------------------------------------------
#' @rdname features_info-methods
#' @aliases features_info,Zresults-method
#'
setMethod("features_info", c("Zvariant"), function(x) {
if (has_results(x)$features.info) {
return(results(x)@features.info)
} else {
warning("Features info data requested but not present in ", outdir(x))
}
})
# get_dat_param -----------------------------------------------------------
#' @rdname get_dat_param-methods
#'
setMethod("get_dat_param", signature("Zvariant"),
function(x, parameter, warn_missing=TRUE) {
# Only canocical parameters are accepted
if (!parameter %in% zparameters(just_names = TRUE)) {
stop("Requested parameter not valid Zonation parameter.")
}
# Check the current parameters. If requested parameter is valid Zonation
# parameter but not currently set, return NA.
current_params <- leaf_tags(x@dat.data, omit_sections = TRUE)
if (!parameter %in% names(current_params)) {
if (warn_missing) {
warning("Requested parameter valid Zonation parameter, but not set.")
}
return(NA)
}
# Return the correct parameter value
return(as.vector(current_params[parameter]))
})
# groups ------------------------------------------------------------------
#' @rdname groups-methods
#'
setMethod("groups", "Zvariant", function(x) {
if (any(dim(x@groups) != c(0, 0))) {
return(x@groups$output.group)
} else {
return(NA)
}
})
# groups<- ----------------------------------------------------------------
#' @name groups<-
#' @rdname groups-methods
#' @aliases groups<-,Zvariant,numeric-method
#'
setReplaceMethod("groups", c("Zvariant", "numeric"), function(x, value) {
# Check that the number of provided group codes matches with the number of
# features
nfeats <- nfeatures(x)
nreplacement <- length(value)
if (nfeats > nreplacement) {
stop("Too few replacement group IDs (", nreplacement, ") for variant ",
"features (", nfeats, ")")
} else if (nfeats < nreplacement) {
stop("Too many replacement group IDs (", nreplacement, ") for variant ",
"features (", nfeats, ")")
}
# If nothing has been assigned, assign values. If nothing changes, do nothing.
if (is.null(x@groups$output.group) | !all(x@groups$output.group == value)) {
# In case no groups dataframe has been populated, do that
if (nrow(x@groups) == 0L) {
# FIXME: not a good idea to define names(x@groups) in several places...
x@groups <- data.frame(output.group = value,
condition.group = -1,
retention.group = -1,
retention.mode = 1,
local.edge.correct.group = -1,
name = "")
} else {
x@groups$output.group <- value
}
# Update results curves data if it exists
#browser()
if (has_results(x)[["curves"]]) {
x@results@grp.curves <- regroup_curves(curves(x), sppweights(x), value)
}
# Change group names back to generic "group1", "group2" etc.
group.ids <- unique(value)
group.names <- paste0("group", group.ids)
names(group.names) <- group.ids
groupnames(x) <- group.names
}
return(x)
})
# groupnames --------------------------------------------------------------
#' @rdname groupnames-methods
#' @export
#'
setMethod("groupnames", "Zvariant", function(x) {
if (any(dim(x@groups) == c(0, 0))) {
return(NA)
}
# Get all the groups data
groups.data <- x@groups
# Get unique codes
groups.codes <- unique(groups.data$output.group)
groups.names <- sapply(groups.codes, function(y) {groups.data[which(groups.data$output.group == y),]$name[1]})
return(groups.names)
})
# groupnames<- ------------------------------------------------------------
#' @name groupnames<-
#' @rdname groupnames-methods
#' @aliases groupnames<-,Zvariant,character-method
#'
setReplaceMethod("groupnames", c("Zvariant", "character"), function(x, value) {
if (nrow(x@groups) == 0) {
stop("Variant has no groups to name")
}
# NAs are not allowed as group names
if (any(is.na(names(value)))) {
stop("Group names cannot include NAs")
}
# Actual coded values are vector names. Assume numeric and try to coerce.
keys <- as.numeric(names(value))
group.codes <- groups(x)
unique.group.codes <- unique(group.codes)
# Check that all group codes are actually found in the keys
if (!all(unique.group.codes %in% keys)) {
stop(paste("Group code(s)", paste(unique.group.codes[!unique.group.codes %in% keys],
collapse = ", "),
"not found in keys:",
paste(keys, collapse = ", ")))
}
# Subset only values that are used (there can be more)
value <- value[which(names(value) %in% unique.group.codes)]
# Get the actual character vector indexes based on the names
inds <- sapply(group.codes, function(y) {which(keys == y)})
# Index the value vector
x@groups$name <- value[inds]
if (has_results(x)$grp.curves) {
results.grp.names <- names(x@results@grp.curves)[3:length(x@results@grp.curves)]
# Each group has 5 columns
ngroups <- length(results.grp.names) / 5
if (length(value) != ngroups) {
stop(paste0("Character vector length (", length(value), ") and object ",
"results group curves header length (", ngroups,
") should be the same"))
}
for (i in 1:ngroups) {
group.id <- names(value[i])
group.name <- value[[i]]
results.grp.names <- gsub(paste0("group", group.id, "$"), group.name,
results.grp.names)
}
new.grp.names <- c(names(x@results@grp.curves)[1:2], results.grp.names)
names(x@results@grp.curves) <- new.grp.names
}
return(x)
})
# has_results -------------------------------------------------------------
#' @rdname has_results-methods
#'
setMethod("has_results", "Zvariant", function(x) {
return(has_results(x@results))
})
#' @rdname nfeatures-methods
#' @aliases nfeatures,Zvariant-method
#'
setMethod("nfeatures", "Zvariant", function(x) {
return(nrow(x@spp.data))
})
# outdir ------------------------------------------------------------------
#' @rdname outdir-methods
#'
setMethod("outdir", c("Zvariant"), function(x) {
return(x@output.dir)
})
# print -------------------------------------------------------------------
#' Print Zvariant information.
#'
#' Generic printing function
#'
#' @param x \code{ZVariant} object.
#'
#' @rdname print-methods
#'
#' @export
#'
#' @author Joona Lehtomaki \email{joona.lehtomaki@@gmail.com}
#'
setMethod('print' , c("Zvariant"), function(x) {
.printZvariant(x)
})
# rank_raster -------------------------------------------------------------
#' @rdname rank_raster-methods
#'
setMethod("rank_raster", c("Zvariant"), function(x) {
if (has_results(x)$rank) {
return(rank_raster(results(x)))
} else {
warning("Rank raster requested but not present in ", outdir(x))
}
})
# results -----------------------------------------------------------------
#' @rdname results-methods
#'
setMethod("results", c("Zvariant"), function(x) {
res <- unlist(has_results(x))
# Return results whenever there is at least 1 result item available
if (any(res)) {
return(x@results)
} else {
warning("Variant doesn't have results")
return(NA)
}
})
# save_zvariant -----------------------------------------------------------
#' @rdname save_zvariant-methods
#'
setMethod("save_zvariant", signature("Zvariant", "ANY", "ANY", "ANY"),
function(x, dir="", overwrite=FALSE, debug_msg=FALSE) {
if (dir == "") {
# Only use x@bat.file; x@name is derived from that and there's no
# syncing/checking between the two.
parent_dir <- dirname(x@bat.file)
} else {
if (dir.exists(dir)) {
parent_dir <- dir
bat_file <- file.path(parent_dir, basename(x@bat.file))
} else {
stop("dir doesn't exist.")
}
}
bat_file <- x@bat.file
spp_file <- x@call.params$spp.file
dat_file <- x@call.params$dat.file
variant_name <- gsub("\\.bat", "", basename(bat_file))
variant_dir <- file.path(parent_dir, variant_name)
# Check for overwriting. NOTE: there could more optional files that are
# overwritten (e.g. groups), but checking the mandatory files should be
# enough.
if (overwrite) {
# Delete old files
unlink(variant_dir, recursive = TRUE, force = TRUE)
if (debug_msg) message("Deleted existing variant dir ", variant_dir)
} else {
if (any(file.exists(c(bat_file, spp_file, dat_file)))) {
stop("Cannot save: at least some of the variant files exist and overwrite is off.")
}
}
# Create variant folder
dir.create(variant_dir)
if (debug_msg) message("Created variant directory ", variant_dir)
# dat-file
dat_to <- file.path(variant_dir, paste0(variant_name, ".dat"))
write_dat(x@dat.data, dat_to, overwrite = TRUE)
if (debug_msg) message("Wrote dat file ", dat_to)
# Write other files listed in dat-file.
#
# Groups
if (!is.na(get_dat_param(x, "use groups", warn_missing = FALSE))) {
groups_file <- get_dat_param(x, "groups file", warn_missing = FALSE)
if (is.na(groups_file)) {
warning("'use groups' is 1, but no groups file path is defined.")
} else {
groups_to <- file.path(parent_dir, groups_file)
groups_data <- x@groups
# Remove "name" field
groups_data <- groups_data[,!(names(groups_data) %in% c("name"))]
write.table(groups_data, file = groups_to, row.names = FALSE, sep = "\t",
col.names = FALSE, quote = FALSE)
if (debug_msg) message("Wrote groups file ", groups_to)
}
}
# spp-file
# Remove "name" and "group"
spp_data <- sppdata(x)
spp_data <- spp_data[,!(names(spp_data) %in% c("name", "group"))]
spp_to <- file.path(variant_dir, paste0(variant_name, ".spp"))
# Format weights and alpha to get a better layout. First, find out how many
# decimal places are needed.
weight_formatter <- paste0("%.", max(decimalplaces(spp_data$weight)), "f")
alpha_formatter <- paste0("%.", max(decimalplaces(spp_data$alpha)), "f")
spp_data$weight <- sprintf(weight_formatter, spp_data$weight)
spp_data$alpha <- sprintf(alpha_formatter, spp_data$alpha)
write.table(spp_data, file = spp_to, row.names = FALSE, col.names = FALSE,
quote = FALSE)
if (debug_msg) message("Wrote spp file ", spp_to)
# Create to output folder
output_dir <- file.path(variant_dir, paste0(variant_name, "_out"))
dir.create(output_dir, recursive = TRUE)
if (debug_msg) message("Created output directory ", output_dir)
# Create a bat file content
dat_relative <- gsub(paste0(parent_dir, .Platform$file.sep), "", dat_to)
spp_relative <- gsub(paste0(parent_dir, .Platform$file.sep), "", spp_to)
output_dir_relative <- gsub(paste0(parent_dir, .Platform$file.sep), "",
output_dir)
cmd_sequence <- x@call.params
cmd_sequence$dat.file <- dat_relative
cmd_sequence$spp.file <- spp_relative
cmd_sequence$output.folder <- file.path(output_dir_relative,
paste0(variant_name, ".txt"))
# Additional command switches for Zonation
cmd_sequence <- c("dos_call"="call", cmd_sequence)
cmd_sequence$grid.type <- "--grid-output-formats=compressed-tif"
cmd_sequence$image.type <- "--image-output-formats=png"
# Flatten the list
cmd_sequence <- unlist(cmd_sequence)
# Write bat-file
bat_to <- file.path(parent_dir, paste0(variant_name, ".bat"))
cat(paste0(paste(cmd_sequence, collapse = " "), "\n"), file = bat_to)
if (debug_msg) message("Wrote bat file ", bat_to)
message("Wrote variant '", variant_name, "' into ", variant_dir)
})
# set_dat_param -----------------------------------------------------------
#' @rdname set_dat_param-methods
#'
setMethod("set_dat_param", signature("Zvariant"), function(x, parameter, value) {
# Only canocical parameters are accepted
if (!parameter %in% zparameters(just_names = TRUE)) {
stop("Parameter not a valid Zonation parameter name.")
}
# Zonation dat-file (and thus x@dat.data) can only have 2 levels in the
# nested list: section and parameter. Hence we can safely loop through the
# list.
for (section_name in names(x@dat.data)) {
for (parameter_name in names(x@dat.data[[section_name]])) {
# Use zparameters() to match the section
x@dat.data[[zparameters()[[parameter]]]][[parameter]] <- value
}
}
x@results_dirty <- TRUE
return(x)
})
# show --------------------------------------------------------------------
#' Print Zvariant information.
#'
#' Generic printing function
#'
#' @param object \code{ZVariant} object.
#'
#' @author Joona Lehtomaki \email{joona.lehtomaki@@gmail.com}
#'
setMethod("show" , c("Zvariant"), function(object) {
.printZvariant(object)
})
# sppdata -----------------------------------------------------------------
#' @rdname sppdata-methods
#'
setMethod("sppdata", c("Zvariant"), function(x, group.names=FALSE) {
spp.data <- x@spp.data
if (nrow(x@groups) > 0) {
spp.names <- names(spp.data)
if (group.names == TRUE && "name" %in% names(x@groups)) {
spp.data <- cbind(spp.data, x@groups$name)
names(spp.data) <- c(spp.names, "group.name")
} else {
spp.data <- cbind(spp.data, x@groups$output.group)
names(spp.data) <- c(spp.names, "group")
}
}
return(spp.data)
})
# sppdata<- ---------------------------------------------------------------
#' @name sppdata<-
#' @rdname sppdata-methods
#' @aliases sppdata<-,Zvariant,data.frame-method
#'
setReplaceMethod("sppdata", c("Zvariant", "data.frame"), function(x, value) {
# Check the number and names of columns
if (ncol(value) != 7) {
stop("Incorrect number of columns in assigning spp data.")
}
if (!any(names(value) %in% names(x@spp.data))) {
stop("Incorrect column names in assigning spp data. Permitted names are: ",
paste(names(x@spp.data), collapse = ", "))
}
x@spp.data <- value
# spp data changed, results are no longer in sync if present
if (any(unlist(has_results(x)))) {
x@results_dirty <- TRUE
warning("sppdata has changed, results may not be in sync with the current state of the Zvariant object.")
}
# If groups are used, default the groups information
if (nrow(x@groups) > 0) {
nrows <- nrow(x@spp.data)
x@groups <- data.frame(output.group = rep(1, nrows),
condition.group = rep(-1, nrows),
retention.group = rep(-1, nrows),
retention.mode = rep(1, nrows),
local.edge.correct.group = rep(-1, nrows),
name = rep("group1", nrows))
}
return(x)
})
# sppweights --------------------------------------------------------------
#' @rdname sppweights-methods
#'
setMethod("sppweights", c("Zvariant"), function(x) {
return(x@spp.data$weight)
})
# sppweights<- ------------------------------------------------------------
#' @name sppweights<-
#' @rdname sppweights-methods
#' @aliases sppweights<-,Zvariant,numeric-method
#'
setReplaceMethod("sppweights", c("Zvariant", "numeric"), function(x, value) {
# Check that the number of weight items is correct
if (length(value) != nfeatures(x)) {
stop("The number of weights (", length(value),
") and the number of features (", nfeatures(x), ") is different.")
}
# Check that the type of weight items is correct
value <- suppressWarnings(as.numeric(value))
if (any(is.na(value))) {
stop("Weight vector elements must be coercible to unmeric.")
}
x@spp.data$weight <- value
return(x)
})
# .printZvariant ----------------------------------------------------------
.printZvariant <- function(x, ...) {
cat('name :', x@name, '\n')
cat('bat-file :', x@bat.file, '\n')
# Show max first 5 biodiversity feature names
spp_names <- featurenames(x)
if (length(spp_names) > 5) {
spp_names <- paste(c(spp_names[1:5], "..."), collapse = ", ")
} else {
spp_names <- paste(c(spp_names), collapse = ", ")
}
cat('features :', nrow(x@spp.data), paste0("[", spp_names, "]"), '\n')
# Show max first 5 group names
grp_names <- groupnames(x)
if (length(grp_names) > 5) {
grp_names <- paste(c(grp_names[1:5], "..."), collapse = ", ")
} else {
grp_names <- paste(c(grp_names), collapse = ", ")
}
cat('groups :', length(unique(groupnames(x))),
paste0("[", grp_names, "]"), '\n')
if (any(unlist(has_results(x)))) {
res_string <- paste0("yes (created: ", as.character(x@results@modified),
")")
} else {
res_string <- "no"
}
cat("has results:", res_string, '\n')
# Run configuration parameters
parameter_string <- c("parameters :")
for (section in names(x@dat.data)) {
parameter_string <- c(parameter_string,
paste0(" [", section, "]"))
for (parameter in names(x@dat.data[[section]])) {
parameter_string <- c(parameter_string,
paste0(" ", parameter, ": ",
x@dat.data[[section]][[parameter]]))
}
}
cat(paste0(parameter_string, collapse = "\n"))
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.