#' @title Rarefy ampvis2 object
#' @description This is just a wrapper of \code{\link[vegan]{rrarefy}} with convenient error messages and adjusted to work with ampvis2 objects.
#'
#' @param data (\emph{required}) Data list as loaded with \code{\link{amp_load}}.
#' @param rarefy (\emph{required}) Passed directly to \code{\link[vegan]{rrarefy}}.
#'
#' @return An ampvis2 object with rarefied OTU abundances.
#' @importFrom vegan rrarefy
#' @author Kasper Skytte Andersen \email{ksa@@bio.aau.dk}
amp_rarefy <- function(data, rarefy) {
  ### Data must be in ampvis2 format
  if (class(data) != "ampvis2") {
    stop("The provided data is not in ampvis2 format. Use amp_load() to load your data before using ampvis2 functions. (Or class(data) <- \"ampvis2\", if you know what you are doing.)", call. = FALSE)
  }

  set.seed(0) # for reproducibility

  reads <- colSums(data$abund)
  maxreads <- max(reads)
  minreads <- min(reads)
  if (is.numeric(rarefy)) {
    if (rarefy > maxreads) {
      stop("The chosen rarefy size is larger than the largest amount of reads in any sample (", as.character(maxreads), ").", call. = FALSE)
    } else if (rarefy < minreads) {
      data$abund <- suppressWarnings(vegan::rrarefy(t(data$abund), sample = rarefy)) %>%
        t() %>%
        as.data.frame()
      warning("The chosen rarefy size (", as.character(rarefy), ") is smaller than the smallest amount of reads in any sample (", as.character(minreads), ").", call. = FALSE)
    } else {
      data$abund <- suppressWarnings(vegan::rrarefy(t(data$abund), sample = rarefy)) %>%
        t() %>%
        as.data.frame()
      if (minreads < rarefy) {
        message("The following sample(s) have not been rarefied (less than ", as.character(rarefy), " reads):\n", paste(rownames(data$metadata[which(reads < rarefy), ]), collapse = ", "))
      }
    }
  } else if (!is.numeric(rarefy)) {
    stop("Argument rarefy must be numerical.", call. = FALSE)
  }
  return(data)
}

#' @title Tidy up taxonomy
#' @description Used internally in other ampvis functions.
#'
#' @param data (\emph{required}) Data list as loaded with \code{\link{amp_load}}.
#' @param tax_empty How to show OTUs without taxonomic information. One of the following:
#' \itemize{
#'    \item \code{"remove"}: Remove OTUs without taxonomic information.
#'    \item \code{"best"}: (\emph{default}) Use the best classification possible.
#'    \item \code{"OTU"}: Display the OTU name.
#'    }
#' @param tax_class Converts a specific phylum to class level instead, e.g. \code{"p__Proteobacteria"}.
#' @param tax_level The taxonomic level to remove OTUs with no assigned taxonomy, only used when \code{tax_empty = "remove"}. (\emph{default:} \code{"Genus"})
#'
#' @return A list with 3 dataframes (4 if reference sequences are provided).
#' @importFrom dplyr mutate
#' @author Kasper Skytte Andersen \email{ksa@@bio.aau.dk}
#' @author Mads Albertsen \email{MadsAlbertsen85@@gmail.com}
amp_rename <- function(data, tax_class = NULL, tax_empty = "best", tax_level = "Genus") {
  tax <- data[["tax"]]

  ## First make sure that all entries are strings
  tax[] <- lapply(tax, as.character)

  ## Change a specific phylum to class level
  if (!is.null(tax_class)) {
    for (i in 1:nrow(tax)) {
      if (!is.na(tax$Phylum[i]) & tax$Phylum[i] %in% tax_class) {
        tax$Phylum[i] <- tax$Class[i]
      }
    }
  }

  ## Remove QIIME taxonomy format prefixes across all levels
  tax[] <- lapply(tax, gsub, pattern = "^[dkpcofgs]_+", replacement = "")

  ## Check if there is a species level otherwise add it for consistency
  if (is.null(tax$Species)) {
    tax$Species <- ""
  }

  ## NA's as empty strings
  tax[is.na(tax)] <- ""

  ## How to handle empty taxonomic assignments
  if (tax_empty == "OTU") {
    for (i in 1:nrow(tax)) {
      if (tax[i, "Species"] == "") {
        tax[i, "Species"] <- rownames(tax)[i]
      }
      if (tax[i, "Genus"] == "") {
        tax[i, "Genus"] <- rownames(tax)[i]
      }
      if (tax[i, "Family"] == "") {
        tax[i, "Family"] <- rownames(tax)[i]
      }
      if (tax[i, "Order"] == "") {
        tax[i, "Order"] <- rownames(tax)[i]
      }
      if (tax[i, "Class"] == "") {
        tax[i, "Class"] <- rownames(tax)[i]
      }
      if (tax[i, "Phylum"] == "") {
        tax[i, "Phylum"] <- rownames(tax)[i]
      }
    }
  }

  ## Handle empty taxonomic strings
  rn <- rownames(tax) # damn rownames are silently dropped by mutate()
  if (tax_empty == "best") {
    tax <- mutate(tax, Kingdom, Kingdom = ifelse(Kingdom == "", "Unclassified", Kingdom)) %>%
      mutate(Phylum, Phylum = ifelse(Phylum == "", paste("k__", Kingdom, "_", rownames(tax), sep = ""), Phylum)) %>%
      mutate(Class, Class = ifelse(Class == "", ifelse(grepl("__", Phylum), Phylum, paste("p__", Phylum, "_", rownames(tax), sep = "")), Class)) %>%
      mutate(Order, Order = ifelse(Order == "", ifelse(grepl("__", Class), Class, paste("c__", Class, "_", rownames(tax), sep = "")), Order)) %>%
      mutate(Family, Family = ifelse(Family == "", ifelse(grepl("__", Order), Order, paste("o__", Order, "_", rownames(tax), sep = "")), Family)) %>%
      mutate(Genus, Genus = ifelse(Genus == "", ifelse(grepl("__", Family), Family, paste("f__", Family, "_", rownames(tax), sep = "")), Genus)) %>%
      mutate(Species, Species = ifelse(Species == "", ifelse(grepl("__", Genus), Genus, paste("g__", Genus, "_", rownames(tax), sep = "")), Species))
  }
  rownames(tax) <- rn

  if (tax_empty == "remove") {
    abund <- data[["abund"]]
    tax <- subset(tax, tax[, tax_level] != "")
    abund <- subset(abund, rownames(abund) %in% rownames(tax))
    data[["abund"]] <- abund
  }
  data[["tax"]] <- tax
  rownames(data[["tax"]]) <- rownames(tax)

  return(data)
}

#' @title Get data from the MiDAS field guide API
#' @description Gets all fields from the MiDAS field guide (\url{https://midasfieldguide.org}) returned in a list.
#'
#' @return A list with all fields.
#' @author Kasper Skytte Andersen \email{ksa@@bio.aau.dk}
getMiDASFGData <- function() {
  checkReqPkg("jsonlite")
  jsonlite::read_json("http://midasfieldguide.org/api/microbes/fieldguide")
}

#' @title Extract functional information about Genera from the MiDAS field guide
#' @description Extract field related to properties and metabolism of all Genera from a list obtained by \code{\link{getMiDASFGData}} and return in a data frame.
#'
#' @param FGList Data list obtained by \code{\link{getMiDASFGData}}.
#'
#' @importFrom data.table rbindlist
#'
#' @return A data frame where each row is a Genus and each column is a "function".
#' @author Kasper Skytte Andersen \email{ksa@@bio.aau.dk}
extractFunctions <- function(FGList) {
  functions <- lapply(FGList, function(x) {
    outList <- lapply(c(x[["properties"]], x[["metabolism"]]), function(y) {
      if (y[["In situ"]] == "Positive" |
          (any(y[["In situ"]] %in% c("Variable", "Not Assessed")) &
           y[["Other"]] == "Positive")) {
        return("POS")
      }
      if (y[["In situ"]] == "Negative" |
          (y[["In situ"]] == "Not Assessed" & y[["Other"]] == "Negative")) {
        return("NEG")
      }
      if (y[["In situ"]] == "Variable" |
          (y[["In situ"]] == "Not Assessed" & y[["Other"]] == "Variable")) {
        return("VAR")
      }
      if (all(c(y[["In situ"]], y[["Other"]]) %in% "Not Assessed")) {
        return("NT")
      }
    })
    c(
      "Genus" = gsub("^Ca ", "Ca_", x[["name"]]),
      "MiDAS" = "POS",
      outList
    )
  })
  outDF <- as.data.frame(data.table::rbindlist(functions, fill = TRUE))
  outDF[is.na(outDF)] <- "NT"
  return(outDF)
}

#' @title Calculate weighted or unweighted UniFrac distances. Adopted from fastUniFrac() from phyloseq
#'
#' @param abund Abundance table with OTU counts, in \code{ampvis2} objects it is available with simply data$abund
#' @param tree Phylogenetic tree (rooted and with branch lengths) as loaded with \code{\link[ape]{read.tree}}.
#' @param weighted Calculate weighted or unweighted UniFrac distances.
#' @param normalise Should the output be normalised such that values range from 0 to 1 independent of branch length values? Note that unweighted UniFrac is always normalised. (\emph{default:} \code{TRUE})
#' @param num_threads The number of threads to be used for calculating UniFrac distances. If set to more than \code{1} then this is set by using \code{\link[doParallel]{registerDoParallel}}. (\emph{default:} \code{1})
#'
#' @importFrom ape is.rooted node.depth node.depth.edgelength reorder.phylo
#' @return A distance matrix of class \code{dist}.
#' @author Kasper Skytte Andersen \email{ksa@@bio.aau.dk}
unifrac <- function(abund,
                    tree,
                    weighted = FALSE,
                    normalise = TRUE,
                    num_threads = 1L) {
  checkReqPkg("doParallel")
  # foreach is installed with doParallel, but its namespace needs to be loaded
  checkReqPkg("foreach")

  # check tree
  if (!class(tree) == "phylo") {
    stop("The provided phylogenetic tree must be of class \"phylo\" as loaded with the ape::read.tree() function.", call. = FALSE)
  }
  if (!ape::is.rooted(tree)) {
    stop("Tree is not rooted!", call. = FALSE)
    # message("Tree is not rooted, performing a midpoint root")
    # tree <- phytools::midpoint.root(tree)
  }
  if (is.null(tree$edge.length)) {
    stop("Tree has no branch lengths, cannot compute UniFrac", call. = FALSE)
  }
  OTU <- as.matrix(abund)
  ntip <- length(tree$tip.label)
  if (ntip != nrow(OTU)) {
    stop("OTU table and phylogenetic tree do not match", call. = FALSE)
  }
  # if(!all(rownames(OTU) == tree$tip.label))
  #  OTU <- OTU[tree$tip.label, , drop = FALSE]
  node.desc <- matrix(tree$edge[order(tree$edge[, 1]), ][, 2], byrow = TRUE, ncol = 2)
  edge_array <- matrix(0,
                       nrow = ntip + tree$Nnode,
                       ncol = ncol(OTU),
                       dimnames = list(NULL, sample_names = colnames(OTU))
  )
  edge_array[1:ntip, ] <- OTU
  ord.node <- order(ape::node.depth(tree))[(ntip + 1):(ntip + tree$Nnode)]
  for (i in ord.node) {
    edge_array[i, ] <- colSums(edge_array[node.desc[i - ntip, ], , drop = FALSE], na.rm = TRUE)
  }
  edge_array <- edge_array[tree$edge[, 2], ]
  rm(node.desc)
  if (isFALSE(weighted)) {
    edge_occ <- (edge_array > 0) - 0
  }
  if (isTRUE(weighted) & isTRUE(normalise)) {
    z <- ape::reorder.phylo(tree, order = "postorder")
    tipAges <- ape::node.depth.edgelength(tree)
    tipAges <- tipAges[1:length(tree$tip.label)]
    names(tipAges) <- z$tip.label
    tipAges <- tipAges[rownames(OTU)]
  }
  samplesums <- colSums(OTU)
  if (num_threads == 1L) {
    foreach::registerDoSEQ()
  } else if (num_threads > 1) {
    doParallel::registerDoParallel(num_threads)
  }
  spn <- combn(colnames(OTU), 2, simplify = FALSE)
  distlist <- foreach::foreach(i = spn) %dopar% {
    A <- i[1]
    B <- i[2]
    AT <- samplesums[A]
    BT <- samplesums[B]
    if (isTRUE(weighted)) {
      wUF_branchweight <- abs(edge_array[, A] / AT - edge_array[, B] / BT)
      numerator <- sum(
        {
          tree$edge.length * wUF_branchweight
        },
        na.rm = TRUE
      )
      if (isFALSE(normalise)) {
        return(numerator)
      } else {
        denominator <- sum(
          {
            tipAges * (OTU[, A] / AT + OTU[, B] / BT)
          },
          na.rm = TRUE
        )
        return(numerator / denominator)
      }
    } else {
      edge_occ_AB <- edge_occ[, c(A, B)]
      edge_uni_AB_sum <- sum((tree$edge.length * edge_occ_AB)[rowSums(edge_occ_AB, na.rm = TRUE) < 2, ], na.rm = TRUE)
      uwUFpairdist <- edge_uni_AB_sum / sum(tree$edge.length[rowSums(edge_occ_AB, na.rm = TRUE) > 0])
      return(uwUFpairdist)
    }
  }
  UniFracMat <- matrix(NA_real_, ncol(OTU), ncol(OTU))
  rownames(UniFracMat) <- colnames(UniFracMat) <- colnames(OTU)
  matIndices <- do.call(rbind, spn)[, 2:1]
  if (!is.matrix(matIndices)) matIndices <- matrix(matIndices, ncol = 2)
  UniFracMat[matIndices] <- unlist(distlist)
  return(as.dist(UniFracMat))
}

#' Calculate Jensen-Shannon Divergence distances
#'
#' @param abund Abundance table with OTU counts, in \code{ampvis2} objects it is available with simply data$abund.
#' @param pseudocount Pseudocount to use instead of 0-divisions. (\emph{default:} \code{0.000001})
#'
#' @return A distance matrix of class \code{dist}.
# This is based on http://enterotype.embl.de/enterotypes.html
# Abundances of 0 will be set to the pseudocount value to avoid 0-value denominators
# Unfortunately this code is SLOOOOOOOOW
dist.JSD <- function(abund, pseudocount = 0.000001) {
  inMatrix <- t(abund)
  KLD <- function(x, y) sum(x * log(x / y))
  JSD <- function(x, y) sqrt(0.5 * KLD(x, (x + y) / 2) + 0.5 * KLD(y, (x + y) / 2))
  matrixColSize <- length(colnames(inMatrix))
  matrixRowSize <- length(rownames(inMatrix))
  colnames <- colnames(inMatrix)
  resultsMatrix <- matrix(0, matrixColSize, matrixColSize)

  inMatrix <- apply(inMatrix, 1:2, function(x) ifelse(x == 0, pseudocount, x))

  for (i in 1:matrixColSize) {
    for (j in 1:matrixColSize) {
      resultsMatrix[i, j] <- JSD(
        as.vector(inMatrix[, i]),
        as.vector(inMatrix[, j])
      )
    }
  }
  colnames -> colnames(resultsMatrix) -> rownames(resultsMatrix)
  as.dist(resultsMatrix) -> resultsMatrix
  attr(resultsMatrix, "method") <- "dist"
  return(resultsMatrix)
}

#' @title Find lowest taxonomic level
#' @description Finds the lowest taxonomic level of two given levels in \code{tax}. The hierarchic order of taxonomic levels is simply taken from the order of column names in \code{tax}
#'
#' @param tax_aggregate A character vector of one or more taxonomic levels (exactly as in the column names of \code{ampvis2obj$tax}), fx Genus or Species. (\emph{default:} \code{NULL})
#' @param tax_add A second character vector similar to \code{tax_aggregate}. (\emph{default:} \code{NULL})
#' @param tax The taxonomy table from an ampvis2 object (\code{ampvis2obj$tax})
#'
#' @return A length one character vector with the lowest taxonomic level.
#' @author Kasper Skytte Andersen \email{ksa@@bio.aau.dk}
getLowestTaxLvl <- function(tax, tax_aggregate = NULL, tax_add = NULL) {
  if (is.null(tax_aggregate) & is.null(tax_add)) {
    tax_aggregate <- colnames(tax)[ncol(tax)]
  }
  # find the lowest taxonomic level of tax_aggregate and tax_add
  taxlevels <- factor(
    x = colnames(tax),
    levels = colnames(tax)
  )
  lowestlevel <- as.character(taxlevels[max(as.numeric(c(
    taxlevels[which(taxlevels %in% tax_aggregate)],
    taxlevels[which(taxlevels %in% tax_add)]
  )))])
  return(lowestlevel)
}

#' @title Aggregate OTUs to a specific taxonomic level
#' @description Calculates the sum of OTUs per taxonomic level
#'
#' @param abund The OTU abundance table from an ampvis2 object (\code{ampvis2obj$abund})
#' @param tax The OTU abundance table from an ampvis2 object (\code{ampvis2obj$tax})
#' @param tax_aggregate Aggregate (sum) OTU's to a specific taxonomic level. (\emph{default:} \code{"OTU"})
#' @param tax_add Add additional (higher) taxonomic levels to the taxonomy string. The OTU's will be aggregated to whichever level of the \code{tax_aggregate} and \code{tax_add} vectors is the lowest. (\emph{default:} \code{NULL})
#' @param calcSums Whether to include the sums of read counts for each sample and taxonomic group. (\emph{default:} \code{TRUE})
#' @param format Output format, \code{"long"} or \code{"abund"}. \code{"abund"} corresponds to that of a read counts table with samples as columns and the aggregated taxa as rows.
#'
#' @importFrom data.table data.table melt
#' @return A data.table.
#' @author Kasper Skytte Andersen \email{ksa@@bio.aau.dk}
aggregate_abund <- function(abund,
                            tax,
                            tax_aggregate = "OTU",
                            tax_add = NULL,
                            calcSums = TRUE,
                            format = "long") {
  if (any(colnames(abund) %in% "Display")) {
    stop("A column is named \"Display\" in the OTU abundance table, please change it to continue", call. = FALSE)
  }

  # make sure all tax columns are of type character (nchar() does not allow factors)
  tax[] <- lapply(tax, as.character)

  # find the lowest taxonomic level of tax_aggregate and tax_add
  lowestTaxLevel <- getLowestTaxLvl(
    tax = tax,
    tax_aggregate = tax_aggregate,
    tax_add = tax_add
  )

  # Remove all OTUs that are not assigned at the chosen taxonomic level
  # and print a status message with the number of removed OTUs
  newtax <- tax[which(nchar(tax[[lowestTaxLevel]]) > 1 &
                        !is.na(tax[[lowestTaxLevel]]) &
                        !grepl("^\\b[dkpcofgs]*[_:;]*\\b$", tax[[lowestTaxLevel]])), ]
  newabund <- abund[rownames(newtax), , drop = FALSE]
  if (nrow(newtax) != nrow(tax)) {
    message(paste0(
      nrow(tax) - nrow(newtax),
      " OTUs (out of ",
      nrow(tax),
      ") with no assigned taxonomy at ",
      lowestTaxLevel,
      " level were removed before aggregating OTUs"
    ))
  }

  abundTax <- data.table::data.table(
    newabund,
    Display = apply(
      newtax[, c(tax_add, tax_aggregate), drop = FALSE],
      1,
      paste,
      collapse = "; "
    )
  )
  abundAggr <- data.table::melt(
    abundTax,
    id.vars = "Display",
    variable.name = "Sample",
    value.name = "Abundance",
    variable.factor = FALSE
  )
  if (isTRUE(calcSums)) {
    abundAggr[,
              Sum := sum(Abundance),
              keyby = .(Display, Sample)
    ]
  }
  if (format == "long") {
    out <- abundAggr
  } else if (format == "abund") {
    out <- as.data.frame(
      data.table::dcast(abundAggr,
                        Display ~ Sample,
                        value.var = "Abundance",
                        fun.aggregate = sum
      )
    )
    rownames(out) <- as.character(out[[1]])
    out <- out[, -1, drop = FALSE]
  } else {
    stop("format must be either \"long\" or \"abund\"")
  }
  return(out)
}

abundAreCounts <- function(data) {
  ### Data must be in ampvis2 format
  is_ampvis2(data)

  # check if $abund contains read counts and not normalised counts or any decimals
  all(
    !isTRUE(attributes(data)$normalised),
    all(data$abund %% 1L == 0),
    !all(colSums(data$abund) == 100)
  )
}

#' @title Normalise read counts to 100, i.e. in percent relative abundance per sample
#'
#' @param data (\emph{required}) Data list as loaded with \code{\link{amp_load}}.
#'
#' @return A modifed ampvis2 object
normaliseTo100 <- function(data) {
  ### Data must be in ampvis2 format
  is_ampvis2(data)

  if (!abundAreCounts(data)) {
    warning("The data has already been normalised. Setting normalise = TRUE (the default) will normalise the data again and the relative abundance information about the original data of which the provided data is a subset will be lost.", call. = FALSE)
  }
  # normalise each sample to sample totals, skip samples with 0 sum to avoid NaN's
  tmp <- data$abund[, which(colSums(data$abund) != 0), drop = FALSE]
  if (nrow(tmp) == 1L) {
    # apply returns a vector and drops rownames if only 1 row, therefore set to 100 instead
    tmp[1L, ] <- 100L
  } else if (nrow(tmp) > 1L) {
    tmp <- as.data.frame(apply(tmp, 2, function(x) {
      x / sum(x) * 100
    }))
  }
  data$abund[, which(colSums(data$abund) != 0)] <- tmp
  attributes(data)$normalised <- TRUE
  return(data)
}

#' @title Filter species by a threshold in percent
#'
#' @param data (\emph{required}) Data list as loaded with \code{\link{amp_load}}.
#' @param filter_species Remove low abundant OTU's across all samples below this threshold in percent. (\emph{default}: \code{0})
#'
#' @importFrom ape drop.tip
#' @return An ampvis2 object
filter_species <- function(data, filter_species = 0) {
  ### Data must be in ampvis2 format
  is_ampvis2(data)

  if (is.numeric(filter_species)) {
    if (filter_species > 0) {
      # First transform to percentages
      abund_pct <- data$abund
      abund_pct[, which(colSums(abund_pct) != 0)] <- as.data.frame(apply(abund_pct[, which(colSums(abund_pct) != 0), drop = FALSE], 2, function(x) x / sum(x) * 100))
      rownames(abund_pct) <- rownames(data$abund) # keep rownames

      # Then filter low abundant OTU's where ALL samples have below the threshold set with filter_species in percent
      abund_subset <- abund_pct[!apply(abund_pct, 1, function(row) all(row <= filter_species)), , drop = FALSE] # remove low abundant OTU's
      data$abund <- data$abund[which(rownames(data$abund) %in% rownames(abund_subset)), , drop = FALSE]
      rownames(data$tax) <- data$tax$OTU

      # also filter taxonomy, tree, and sequences
      data$tax <- data$tax[which(rownames(data$tax) %in% rownames(abund_subset)), , drop = FALSE]

      if (!is.null(data$tree)) {
        data$tree <- ape::drop.tip(
          phy = data$tree,
          tip = data$tree$tip.label[!data$tree$tip.label %in% data$tax$OTU]
        )
      }

      if (!is.null(data$refseq)) {
        if (!is.null(names(data$refseq))) {
          # sometimes there is taxonomy alongside the OTU ID's. Anything after a ";" will be ignored
          names_stripped <- stringr::str_split(names(data$refseq), ";", simplify = TRUE)[, 1]
          data$refseq <- data$refseq[names_stripped %in% rownames(data$abund)]
        } else if (is.null(names(data$refseq))) {
          warning("DNA sequences have not been subsetted, could not find the names of the sequences in data$refseq.", call. = FALSE)
        }
      }
    }
  }
  return(data)
}

#' @title Check if data has class "ampvis2"
#' @description Checks if the object is of class "ampvis2".
#'
#' @param data Object to check
#'
#' @return Returns error if \code{!inherits(data, "ampvis2")}, otherwise \code{invisible(TRUE)}.
#' @author Kasper Skytte Andersen \email{ksa@@bio.aau.dk}
is_ampvis2 <- function(data) {
  if (!inherits(data, "ampvis2")) {
    stop("The provided data is not in ampvis2 format. Use amp_load() to load your data before using ampvis2 functions. (Or class(data) <- \"ampvis2\", if you know what you are doing.)", call. = FALSE)
  }
  invisible(TRUE)
}

#' @title Check for installed package
#' @description Returns error if a required package is not installed. Mostly used for checking whether packages listed under the Suggests field in the DESCRIPTION file is installed.
#'
#' @param pkg The package to check for, a character of length 1.
#' @param msg Optionally additional text appended (with \code{paste0}) to the default error message.
#'
#' @return Returns error and message if not installed, otherwise \code{invisible(TRUE)}
#' @author Kasper Skytte Andersen \email{ksa@@bio.aau.dk}
checkReqPkg <- function(pkg, msg = "") {
  stopifnot(is.character(pkg), length(pkg) == 1L, nchar(pkg) > 0)
  if (!requireNamespace(pkg, quietly = TRUE)) {
    stopifnot(is.character(msg))
    stop(
      paste0("Package '", pkg, "' is required but not installed.", msg),
      call. = FALSE
    )
  }
  require(pkg, quietly = TRUE, character.only = TRUE)
}

#' Replacement for ":::" to suppress R CMD CHECK warnings
# `%:::%` <- function(pkg, fun)
#  get(fun, envir = asNamespace(pkg), inherits = FALSE)


= La població d'Espanya i d'Europa

:author
  Alfons Rovira
:theme
  debian

= Població

((*Població absoluta*)): d'un territori és el nombre de persones que hi viuen.

= Factors

  * (('wait'))Relleu
  * (('wait'))Clima

= Raons

  * (('wait')) A on el relleu i el clima és més favorable major indústria i serveis.
  * (('wait')) Àrees de muntanya i d'interior. Clima més desfavorable. Poc poblades i activitats agràries.

= Densitat

  * ((*Densitat de població*)): nombre d'habitants que viuen en un kilòmetre quadrat de superfície.
  *  Espanya la densitat de població:  93,4 h/km (('sup:2'))

= Definicions

((*Demografia*)): Ciència que estudia la població, com es distribueix, com evoluciona la població en un lloc determinat.

= Definicions

((*Població urbana*)): Població que viu a municipis de més de ((*10.000*)) habitants.

= Definicions

((*Població absoluta*)): d'un territori és el nombre de persones que hi viuen.

= Definicions

((*Natalitat*)): nombre d'infants que naixen en un lloc durant un any.

= Definicions

((*Mortalitat*)): nombre d'persones que moren en un lloc durant un any.

= Definicions

((*Esperança de vida*)): mitjana d'anys que viu una població.

= Definicions

((*Creixement natural*)): diferència entre el total de naixements o natalitat i el total de defuncions o mortalitat.

= Definicions

((*Creixement real*)): creixement natural + saldo migratori

= Definicions

((*Saldo migratori*)): immigrants - emigrants

= Definicions

((*Població activa*)): població ocupada + població en atur

= Definicions

((*Població no activa*)): infants, estudinats, mestresses de casa i jubitalts.

= Definicions

((*Pirámide de població*)): és un gràfic que ordena els habitants d'un lloc per grups d'edat i sexe en un moment concret.

Parts:

  * Base: població jove
  * Tronc: població adulta
  * Cim: població anciana

= Causes de les migracions

  * (('wait'))((*Socials i econòmiques*)): pobresa, cerca de millors condicions de vida
  * (('wait'))((*Polítiques*)): guerres, conflictes racials, conflictes religiosos
  * (('wait'))((*Naturals*)): huracans, tsunameis, terratremols sequeres
  * (('wait'))((*Familiars*)): reagrupament familiar

= Definicions

((*Migració exterior*)): abandonament del país d'origen.

= Definicions

((*Migració interior*)): moviment de la població dins d'un país.

= Conseqüències de les migracions

  * ((*Dinàmica de població*)): aportació de població i augment de la natalitat
  * ((*Economia*)): creixement econòmic
  * ((*Diversistat cultural*)): contacte amb noves cultures i costums

= Població europea

  * (('wait')) És irregular
  * (('wait')) Creixement dèbil
  * (('wait')) Envellida
  * (('wait')) Urbana
  * (('wait')) Amb molta immigració


/*	Neutron Scattering.r -- resources for "Neutron Scattering" XOP */

// Igor resources
#include "XOPStandardHeaders.r"

resource 'vers' (1) {                        /* XOP version info */
    0x01, 0x16, final, 0x00, 0,              /* version bytes and country integer */
    "1.22",
    "1.22, © 2000-2021 ILL/SANE, all rights reserved."
};

resource 'vers' (2) {                        /* Igor version info */
    0x08, 0x04, release, 0x00, 0,            /* version bytes and country integer */
    "8.04",
    "(for Igor Pro 8.04 or later)"
};

resource 'STR#' (1100) {					/* custom error messages */
	{
		/* [1] */
		"Neutron Scattering XOP requires Igor 8.04 or later.",
		/* [2] */
		"Null Counting Time.",
		/* [3] */
		"Null Count Rate.",
		/* [4] */
		"Null Monitor Value: Beam may not be opened !",
		/* [5] */
		"Infinite Flipping Ratio.",
		/* [6] */
		"Infinite Flipping Ratio Standard Deviation.",
		/* [7] */
		"Infinite Counting Time.",
		/* [8] */
		"Infinite Counting Time Standard Deviation.",
		/* [9] */
		"Undefined Detector Position.",
		/* [10] */
		"Infinite Asymmetry.",
		/* [11] */
		"Infinite Asymmetry Standard Deviation.",
		/* [12] */
		"Undefined Count Rate.",
		/* [13] */
		"Wrong lattice parameters - Det[G] = 0.",
	}
};

/* no menu item */

resource 'XOPI' (1100) {
    XOP_VERSION,                            // XOP protocol version.
    DEV_SYS_CODE,                           // Code for development system used to make XOP
    XOP_FEATURE_FLAGS,                      // Tells Igor about XOP features
    XOPI_RESERVED,                          // Reserved - must be zero.
    XOP_TOOLKIT_VERSION,                    // XOP Toolkit version.
};

resource 'XOPF' (1100) {
	{
		"CountRate",						/* function name */
		F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
			NT_FP64,
		},

		"CountRateSDev",					/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
			NT_FP64,
		},

		"CountRateDDT",						/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
			NT_FP64,
			NT_FP64,
			NT_FP64,
		},

		"CountRateDDTSDev",					/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
		},

		"CountRateMonitor",					/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
			NT_FP64,
		},

		"CountRateMonitorSDev",				/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
			NT_FP64,
		},

		"FlippingRatio",					/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
			NT_FP64,
			NT_FP64,
			NT_FP64,
		},

		"FlippingRatioSDev",				/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
		},

		"FlippingRatioOpt",					/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
		},

		"FlippingRatioOptSDev",				/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
		},

		"FlippingRatioOptDDT",				/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
		},

		"FlippingRatioOptDDTSDev",			/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
		},

		"OptCountingTimeTpp",				/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
		},

		"OptCountingTimeTbp",				/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
		},

		"OptCountingTimeTpm",				/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
		},

		"OptCountingTimeTbm",				/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
		},

		"OptCountingTimeTppSDev",			/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
		},

		"OptCountingTimeTbpSDev",			/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
		},

		"OptCountingTimeTpmSDev",			/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
		},

		"OptCountingTimeTbmSDev",			/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
		},

		"PeakCentringLin",					/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
		},

		"PeakCentringLinSDev",				/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
		},

		"PeakCentringGauss",				/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
		},

		"PeakCentringGaussSDev",			/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
		},

		"STLcubic",							/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
			NT_FP64,
			NT_FP64,
			NT_FP64,
		},

		"STLhexagonal",						/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
		},

		"STLrhombohedral",					/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
		},

		"STLtetragonal",					/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
		},

		"STLorthorhombic",					/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
		},

		"STLmonoclinicB",					/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
		},

		"STLmonoclinicC",					/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
		},

		"STLtriclinic",						/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
		},

		"Asymmetry",						/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
			NT_FP64,
			NT_FP64,
			NT_FP64,
		},

		"AsymmetrySDev",					/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
		},

		"AsymmetryOpt",						/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
		},

		"AsymmetryOptSDev",					/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
		},

		"AsymmetryOptDDT",					/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
		},

		"AsymmetryOptDDTSDev",				/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
		},

		"He3Efficiency",					/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
            NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
		},

		"He3EfficiencySDev",				/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
            NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,						/* parameter types */
			NT_FP64,
            NT_FP64,
			NT_FP64,
			NT_FP64,
		},

		"He3Efficiency2",					/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
			NT_FP64,
			NT_FP64,
			NT_FP64,
		},

		"He3Efficiency2SDev",				/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
			NT_FP64,
			NT_FP64,
			NT_FP64,
		},

		"He3Transmission",					/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
			NT_FP64,
			NT_FP64,
            NT_FP64,
			NT_FP64,
		},

		"He3TransmissionSDev",				/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
			NT_FP64,
			NT_FP64,
			NT_FP64,
            NT_FP64,
			NT_FP64,						/* parameter types */
			NT_FP64,
            NT_FP64,
			NT_FP64,
			NT_FP64,
		},

		"He3Polarisation",					/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
            NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
		},

		"He3PolarisationSDev",				/* function name */
        F_UTIL | F_EXTERNAL,                /* function category */
		NT_FP64,							/* return value type */
		{
			NT_FP64,						/* parameter types */
            NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,						/* parameter types */
			NT_FP64,
			NT_FP64,
            NT_FP64,
			NT_FP64,
			NT_FP64,
			NT_FP64,
		},
	}
};


#' @exportClass Node
#' @name Node
#' @rdname Node
#' @aliases Node-class
#' @title The Node class
#'
#' @description
#' This class is part of the \pkg{HNUORTools}. It represents
#' the base class for every locateable class in an
#' \dfn{Operations-Research (OR)}-context.
#'
#' @details Find here the defined slots for this class.
#'      @section Slots:
#'          \describe{
#'              \item{\code{id}:}{
#'                  Object of class \code{"character"}, containing data from id.
#'                  \strong{Should be unique}.
#'                  The default value will be caluclated randomly.
#'              }
#'              \item{\code{label}:}{
#'                  Object of class \code{"character"}, containing the label of
#'                  the \code{\link{Node}}.
#'                  The default value will be caluclated randomly.
#'              }
#'              \item{\code{x}:}{
#'                  Object of class \code{"numeric"}, containing the x-coordinate
#'                  of the \code{\link{Node}}.
#'                  The default value will be caluclated randomly.
#'              }
#'              \item{\code{y}:}{
#'                  Object of class \code{"numeric"}, containing the y-coordinate
#'                  of the \code{\link{Node}}.
#'                  The default value will be caluclated randomly.
#'              }
#'          }
#'
#' @seealso The classes are derived from this class and the following Methods can be used with this class.:
#'      @section Creating objects of type \code{\link{Node}}:
#'          \describe{
#'              \item{Creating an \code{S4-Object}}{
#'                  \code{new("Node", ...)}
#'              }
#'              \item{Converting from a \code{data.frame}}{
#'                  \code{as.Node{<data.frame>}}
#'                  See also below in the Methods-Section.
#'              }
#'              \item{Converting from a \code{list}}{
#'                  \code{as.Node{<list>}}
#'                  See also below in the Methods-Section.
#'              }
#'          }
#'      @section Methods:
#'          \describe{
#'              \item{\code{as.list(node, ...)}}{
#'                  Converts a \code{\link{Node}} into a \code{\link{list}}.
#'                  \code{...} are user-defined (not used) parameters.
#'              }
#'              \item{\code{as.data.frame(node, ...)}}{
#'                  Converts a \code{\link{Node}} into a \code{\link{data.frame}}.
#'                  \code{as.data.frame} accepts the optional parameter \code{withrownames} of class \code{"logical"} (default is \code{TRUE}).
#'                  If \code{withrownames == TRUE} the returned \code{\link{data.frame}} will recieve the \code{id} as rowname.
#'                  \code{...} are user-defined (not used) parameters.
#'
#'              }
#'              \item{\code{as.Node(obj)}}{
#'                  Converts an object of class \code{\link{data.frame}} or of class \code{\link{list}} into a \code{\link{Node}}.
#'              }
#'              \item{\code{is.Node(obj)}}{
#'                  Checks if the object \code{obj} is of type \code{\link{Node}}.
#'              }
#'              \item{\code{\link{getDistance}}}{
#'                  Calculating the distance between two \code{\link{Node}s}
#'                  (As the classes \code{\link{Customer}} and \code{\link{Warehouse}}
#'                  depend on \code{\link{Node}}, distances can be calculated between any of these objects).
#'              }
#'              \item{\code{\link{getpolar}}}{
#'                  Calculating the polar-angle to the x-Axis of a link,
#'                  connecting two \code{\link{Node}s}
#'                  (As the classes \code{\link{Customer}} and \code{\link{Warehouse}}
#'                  depend on \code{\link{Node}}, polar-angles can be calculated between any of these objects).
#'              }
#'          }
#'
#'      @section Derived Classes:
#'          \describe{
#'              \item{\code{\link{Customer}}}{
#'                  This class extends the \code{\link{Node}}-Class
#'                  with attributes for according to customers for OR-Problems.
#'              }
#'              \item{\code{\link{Warehouse}}}{
#'                  This class extends the \code{\link{Node}}-Class
#'                  with attributes for according to warehouses for OR-Problems.
#'              }
#'              \item{\code{\link{Link}}}{
#'                  This class is constructed by two entities of the \code{\link{Node}}-Class
#'                  representing the origin and destination of \code{\link{Link}} for OR-Problems.
#'              }
#'          }
#'      @section To be used for:
#'          \describe{
#'              \item{SPP}{
#'                   Shortest-Path-Problem
#'              }
#'              \item{TSP}{
#'                  Travelling Salesman Problem
#'              }
#'          }
#'
#' @note
#'      for citing use: Felix Lindemann (2014). HNUORTools: Operations Research Tools. R package version 1.1-0. \url{http://felixlindemann.github.io/HNUORTools/}.
#'
#' @author Dipl. Kfm. Felix Lindemann \email{felix.lindemann@@hs-neu-ulm.de}
#'
#' Wissenschaftlicher Mitarbeiter
#' Kompetenzzentrum Logistik
#' Buro ZWEI, 17
#'
#' Hochschule fur angewandte Wissenschaften
#' Fachhochschule Neu-Ulm | Neu-Ulm University
#' Wileystr. 1
#'
#' D-89231 Neu-Ulm
#'
#'
#' Phone   +49(0)731-9762-1437
#' Web      \url{www.hs-neu-ulm.de/felix-lindemann/}
#'          \url{http://felixlindemann.blogspot.de}
#' @examples
#' # create a new Node with specific values
#' x<- new("Node", x= 10, y=20, id="myid", label = "mylabel")
#' x
#' # create from data.frame
#' df<- data.frame(x=10,y=20)
#' new("Node", df)
#' as(df, "Node")
#' as.Node(df)
#' #create some nodes
#' n1 <- new("Node",x=10,y=20, id ="n1")
#' n2 <- new("Node",x=13,y=24, id ="n1")
#' # calculate Beeline distance
#' #getDistance(n1,n2) # should result 5
#' #getDistance(n1,n2, costs = 2) # should result 10
setClass(
	Class = "Node",
    representation=representation(
    	id     = "character",
        label  = "character",
    	x      = "numeric",
    	y      = "numeric"
    ),
    validity = function(object){

        N <- length(object@id)
        if(length(object@label) != N)
            return("Invalid Object of Type 'Node': the length of the attributes 'id' and 'label' differ!")
        if(length(object@x) != N)
            return("Invalid Object of Type 'Node': the length of the attributes 'id' and 'x' differ!")
        if(length(object@y) != N)
            return("Invalid Object of Type 'Node': the length of the attributes 'id' and 'y' differ!")

        if( sum(is.null(object@x)) + sum( is.na(object@x)) > 0 )
            return(paste("Invalid Object of Type 'Node': Error with value x: Value is not initialized", class(object@x)))

        if( sum(is.null(object@y)) + sum( is.na(object@y)) > 0)
            return(paste("Invalid Object of Type 'Node': Error with value y: Value is not initialized", class(object@y)))

        if( class(object@x)!="numeric" )
            return(paste("Invalid Object of Type 'Node': Error with value x: expected numeric datatype, but obtained", class(object@x)))

        if( class(object@y)!="numeric" )
            return(paste("Invalid Object of Type 'Node': Error with value y: expected numeric datatype, but obtained", class(object@y)))

        return(TRUE)
    }
)
################################### initialize - Method ###################################################
#' @title initialize Method
#' @name initialize
#' @aliases initialize,Node-method
#' @rdname initialize-methods
#' @param data can of type \code{\link{data.frame}} or \code{\link{list}}
setMethod("initialize", signature="Node", function(.Object, data=NULL, ...) {

    li <- list(...)
    N<-1
    if(is.null(li$showwarnings))  li$showwarnings <- FALSE
    if(!is.null(data)){

        if(class(data) =="list") {
          data <- as.data.frame(data)
        }
        if(class(data) =="data.frame") {
            N<-nrow(data)
            li$id    <- data$id
            li$label <- data$label
            li$x     <- data$x
            li$y     <- data$y

        } else{
            stop("Error: argument data should be of type 'data.frame'!")
        }
    }
    if(is.null(li$x)) {
        li$x <- as.numeric(runif(N,0,100))
        w <- paste("x-Coordinate simulated (x= ",li$x,").")
        if(li$showwarnings) warning(w)
    }
    if(is.null(li$y)) {
        li$y <- as.numeric(runif(N,0,100))
        w <- paste("y-Coordinate simulated (y= ",li$y,").")
        if(li$showwarnings) warning(w)
    }
    if(is.null(li$id)) {
        tmp.id <-NULL
        for(i in 1:N){
            tmp.id <- c(tmp.id, UUIDgenerate())
        }
        li$id <- tmp.id
        w <- paste("Random ID (",li$id,") provided. Uniqueness should be given.")
        if(li$showwarnings) warning(w)
    }
    if(is.null(li$label)) {
        li$label <- li$id
    }
    .Object@id     <- as.character(li$id)
    .Object@label  <- as.character(li$label)

    .Object@x      <- as.numeric(  li$x)
    .Object@y      <- as.numeric(  li$y)

    validObject(.Object)

    return(.Object )
})
################################### extract - Method ###################################################

#' @title Extract Methods
#' @name $
#' @aliases $,Node-method
#' @rdname Extract-methods-1
#' @param name Name of Attribute.
setMethod("$","Node",function(x,name) {return(slot(x,name))})
#' @title Extract Methods
#' @name [
#' @aliases [,Node-method
#' @rdname Extract-methods-2
#' @param i Row Index
#' @param j Name or Column index
#' @param drop Optional value for Drop-Levels.
setMethod("[", "Node",
    function(x, i, j, drop){
        N <- length(x)
        if(min(i) <=0) stop("Index i out of bound. it must be positive non zero.")
        if(max(i) >N) stop("Index i out of bound. it must not be larger than the total length.")

        if(!missing(j)){
            if(class(j) == "character"){
                return(slot(x,j)[i])
            }
            if(class(j) == "integer"){
                return(slot(x,j)[i])
            }
        }
        df <- as.data.frame(x)[i,]
        return (new("Node", df))
    }
)
################################### Set - Method ###################################################

#' @title Set Methods
#' @name $<-
#' @aliases $<-,Node-method
#' @rdname Set-methods-1
#' @param name Name of parameter to change
#' @param value new Value.
setMethod("$<-","Node",function(x,name,value) {
  slot(x,name,check=TRUE) <- value
  valid<-validObject(x)
  return(x)
})

#' @title Set Methods
#' @name [<-
#' @aliases [<-,Node-method
#' @rdname Set-methods-2
#' @param x The Node
#' @param i row-Index
#' @param j Name or Column index
setReplaceMethod("[",signature(x="Node"),
    function(x,i,j,value){
        N <- length(x)
        if(min(i) <=0) stop("Index i out of bound. It must be positive non zero.")
        if(max(i) >N)  stop("Index i out of bound. It must not be larger than the total length.")
        if(length(value)!=length(i)) stop("The replacement length is not equal to the number of elements to be replaced.")

        if(is(value, "Node")){

            # copy original values to tmp vectors
            tmp <- as.data.frame(x)

            #replace the item(s) regarding to i
            tmp$id[i]    <- value@id
            tmp$label[i] <- value@label
            tmp$x[i]     <- value@x
            tmp$y[i]     <- value@y

            # return new item
            return (new("Node", tmp))
        } else {
            if(missing(j)) {
                # call the function recursivly
                # might throw an error if the conversion is not supported.
                x[i] <- as.Node(value)
            }else{
                if(class(j) == "character"){
                    slot(x,j)[i]     <- value
                }else if(class(j) == "integer" | class(j) == "numeric"){
                    slot(x,slotNames(x)[j])[i]  <- value
                }else{
                    warning(paste("no changes have been made. the provided value of j (class:",class(j), "value:",j,") was not recocnized."))
                }
            }
            valid<-validObject(x)
            return(x)
        }
    }
)

################################### as... - Method ###################################################
#local Methods
as.Node.list       = function(x, ...){return(new("Node", data=x))}
as.Node.data.frame = function(x, ...){return(new("Node", data=x))}
#local convert message
as.data.frame.Node = function(x, ...){
    li<-list(...)
    if(is.null(li$withrownames)) li$withrownames <- FALSE
    df<-data.frame(id=x@id, label = x@label, x= x@x, y= x@y)
    if(li$withrownames) rownames(df)<-x@id
    return (df)
}
as.list.Node = function(x, ...){list(id=x@id, label = x@label, x= x@x, y= x@y)}

#' @export
setGeneric("as.Node",       function(x, ...) standardGeneric( "as.Node"))

#' @title Convert Objects to Nodes
#' @name as.Node
#' @param x an  Object to convert.
#' @param ... optional parameters
#' @aliases as.Node,list-method
#' @rdname as.Node-methods
setMethod("as.Node",     signature(x = "list"),       as.Node.list)

#' @title Convert Objects to Nodes
#' @name as.Node
#' @aliases as.Node,data.frame-method
#' @rdname as.Node-methods
setMethod("as.Node",    signature(x = "data.frame"),  as.Node.data.frame)

#' @title Convert Objects to lists
#' @name as.list
#' @param x the Node
#' @aliases as.list,Node-method
#' @rdname as.list-methods
setMethod("as.list",        signature(x = "Node"),        as.list.Node)

#' @title Convert Objects to data.frames
#' @name as.data.frame
#' @param x the Node
#' @aliases as.data.frame,Node-method
#' @rdname as.data.frame-methods
setMethod("as.data.frame",  signature(x = "Node"),        as.data.frame.Node)

setAs("data.frame", "Node", def=function(from){return(as.Node.data.frame(from))})
setAs("list", "Node", def=function(from){return(as.Node.list(from))})
################################### is... - Method ###################################################

#' @title Checks if an Object is as Node
#' @export
#' @name is.Node
#' @param x the Node
#' @param ... optional Parameters (not supported)
setGeneric("is.Node",       function(x, ...) standardGeneric( "is.Node"))

#' @aliases is.Node,Node-method
#' @rdname is.Node
setMethod( "is.Node", "Node", function(x, ...){
    return(is(x ,"Node"))
})

#' @title How many Nodes are included?
#' @name length
#' @param x the Nodes
#' @aliases length,Node-method
#' @rdname length
setMethod("length", "Node",
    function(x){
        N <- length(x@id)
        return(N)
    }
)

#' @aliases getDistance,Node,Node-method
#' @rdname getDistance
#' @examples
#' # w1 <- new("Node", x=0, y=0)
#' # c1 <- new("Node",  x=3, y=4)
#' # getDistance(w1,c1) # should result 5.
#' # getDistance(w1,c1,costfactor=3) # should result 15.
setMethod( "getDistance", signature = c("Node", "Node"),
    function(n0,n1,   ...) {
        li<-list(...)

        p0<-c(n0$x,n0$y)
        p1<-c(n1$x,n1$y)

        value <- getDistance(p0,p1, ...)

        return(value)
    }
)

#' @aliases getpolar,Node,Node-method
#' @rdname getpolar
#' @examples
#' # w1 <- new("Node", x=0, y=0)
#' # c1 <- new("Node",  x=1, y=1)
#' # getpolar(w1,c1,deg=TRUE) # should result 45.
setMethod("getpolar", signature=c("Node", "Node"),
    function(n0,n1,   ...) {
        li<-list(...)
        validObject(n0)
        validObject(n1)

        p0<-c(n0$x,n0$y)
        p1<-c(n1$x,n1$y)

        value <- getpolar(p0,p1, ...)

        return(value)
    }
)


##
# Copyright (c) 2015, Intel Corporation
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions are met:
#
#     * Redistributions of source code must retain the above copyright notice,
#       this list of conditions and the following disclaimer.
#     * Redistributions in binary form must reproduce the above copyright
#       notice, this list of conditions and the following disclaimer in the
#       documentation and/or other materials provided with the distribution.
#     * Neither the name of Intel Corporation nor the names of its contributors
#       may be used to endorse or promote products derived from this software
#       without specific prior written permission.
#
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
# DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
# CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
# OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
# OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
#
##
# @file
# This file is part of SeisSol.
#
# @author Alex Breuer (breuer AT mytum.de, http://www5.in.tum.de/wiki/index.php/Dipl.-Math._Alexander_Breuer)
#
# @section LICENSE
# Copyright (c) 2014, SeisSol Group
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions are met:
#
# 1. Redistributions of source code must retain the above copyright notice,
#    this list of conditions and the following disclaimer.
#
# 2. Redistributions in binary form must reproduce the above copyright notice,
#    this list of conditions and the following disclaimer in the documentation
#    and/or other materials provided with the distribution.
#
# 3. Neither the name of the copyright holder nor the names of its
#    contributors may be used to endorse or promote products derived from this
#    software without specific prior written permission.
#
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
#
# @section DESCRIPTION
# Performance model for SeisSol setups.

computeMeshStatistics <- function( i_meshName,
                                   i_pathToCsvFile,
                                   i_performanceParameters,
                                   i_outputFileTable,
                                   i_outputFilePlot ) {
  message( 'reading mesh', i_pathToCsvFile )
  l_meshStatistics <- read.csv( file = i_pathToCsvFile,
                                header = TRUE )

  #
  # compute data to send and receive in MPI-communication
  #
  # mpi-information per time step in GB, regular mpi faces
  l_meshStatistics$mpi_send <- (l_meshStatistics$mpi_copy_elements*i_performanceParameters$dofs_size)/1024^3
  # mpi-information per time step in GB, dr mpi face come on top
  #TODO here need a more accurate number, DR is really complex depending on the neighour realitions:
  #TODO DR-DR coupling, DR-WP coupling, for now let's overestimate (2* for time derivatives instead of time integrated)
  l_meshStatistics$mpi_send <- l_meshStatistics$mpi_send + ((2*l_meshStatistics$mpi_dr_faces*i_performanceParameters$dofs_size)/1024^3)
  # now get time
  l_meshStatistics$mpi_send <- l_meshStatistics$mpi_send/i_performanceParameters$network_bandwidth

  # receiving is asymmetric to sending :-/
  l_meshStatistics$mpi_recv <- (l_meshStatistics$mpi_ghost_elements*i_performanceParameters$dofs_size)/1024^3
  l_meshStatistics$mpi_recv <- l_meshStatistics$mpi_recv + ((2*l_meshStatistics$mpi_dr_faces*i_performanceParameters$dofs_size)/1024^3)
  l_meshStatistics$mpi_recv <- l_meshStatistics$mpi_recv/i_performanceParameters$network_bandwidth

  # compute timings for
  # * local integration copy layer
  # * local integration interior
  # * neigh integration copy layer
  # * neigh integration interior
  # * additional flux computation for dunamic rupture faces
  # TODO: we might want to substract outflow boundary conditions
  # Please note we incease the time by 10% for the copy layers since they are very small
  # and therefore run at lower performance
  l_meshStatistics$local_integration_copy           <- l_meshStatistics$mpi_copy_elements*i_performanceParameters$local_integration*1.1
  l_meshStatistics$local_integration_interior       <- l_meshStatistics$interior_elements*i_performanceParameters$local_integration
  l_meshStatistics$neigh_integration_copy           <- l_meshStatistics$mpi_copy_elements*i_performanceParameters$neigh_integration*1.1
  l_meshStatistics$neigh_integration_interior       <- l_meshStatistics$interior_elements*i_performanceParameters$neigh_integration
  l_meshStatistics$dynamic_rupture_fluxes           <- l_meshStatistics$dynamic_rupture_faces*i_performanceParameters$dynamic_rupture

  # compute MPI wait time (recv)
  l_meshStatistics$wait_recv                        <- pmax(l_meshStatistics$mpi_recv -
                                                            l_meshStatistics$local_integration_copy -
                                                            l_meshStatistics$local_integration_interior -
                                                            l_meshStatistics$neigh_integration_interior , 0)

  # compute MPI wait time (send)
  # this assumes that waitforCopyLayerSends() is posted before receiveGhostLayer()
  # this is not true, but the error intorudced by this is very minor!
  l_meshStatistics$wait_send                        <- pmax(l_meshStatistics$mpi_send -
                                                            l_meshStatistics$neigh_integration_copy -
                                                            l_meshStatistics$local_integration_interior -
                                                            l_meshStatistics$neigh_integration_interior -
                                                            l_meshStatistics$dynamic_rupture_fluxes -
                                                            l_meshStatistics$wait_recv , 0)

  # let's sum the waits up
  l_meshStatistics$time_communication_wait          <- l_meshStatistics$wait_recv +
                                                       l_meshStatistics$wait_send

  #let's sum everyting up, and we are done
  l_meshStatistics$time_total                       <- l_meshStatistics$local_integration_copy +
                                                       l_meshStatistics$local_integration_interior +
                                                       l_meshStatistics$neigh_integration_copy +
                                                       l_meshStatistics$neigh_integration_interior +
                                                       l_meshStatistics$dynamic_rupture_fluxes +
                                                       l_meshStatistics$wait_recv +
                                                       l_meshStatistics$wait_send

  #message( 'summary mesh statistics')
  #print( summary( l_meshStatistics ) )

  message( 'writing csv' )
  write.csv( x=l_meshStatistics, file=i_outputFileTable)

  message( 'plotting information' )
  pdf( file = i_outputFilePlot,
       paper = 'a4r',
       width=20,
       height=10)

  # overview boxplots
  par( mfrow=c(1,9) )
  boxplot(l_meshStatistics$local_integration_copy,         main='local copy'      )
  boxplot(l_meshStatistics$local_integration_interior,     main='local interior'  )
  boxplot(l_meshStatistics$neigh_integration_interior,     main='neigh interior'  )
  boxplot(l_meshStatistics$neigh_integration_copy,         main='neigh copy'      )
  boxplot(l_meshStatistics$dynamic_rupture_fluxes,         main='dyn. rupt.'      )
  boxplot(l_meshStatistics$mpi_recv,                       main='recv time'       )
  boxplot(l_meshStatistics$mpi_recv,                       main='send time'       )
  boxplot(l_meshStatistics$time_communication_wait,        main='wait time'       )
  boxplot(l_meshStatistics$time_total,                     main='total time'      )

  # detailed plot of every characteristic value
  #for( l_name in names(l_meshStatistics[-1]) ) {
  #  layout( matrix(c(1,2), 2, 2, byrow = TRUE),
  #          widths=c(4,1) )
  #  plot( x=l_meshStatistics$partition,
  #        y=l_meshStatistics[,l_name],
  #        xlab="partition",
  #        ylab=l_name )
  #  boxplot(l_meshStatistics[l_name])
  #}
  dev.off()

  return( max(l_meshStatistics$time_total) )
}

printWeakScaling <- function( i_machineList,
                                   i_nodeCounts,
                                   i_meshID ) {
  for( l_machine in i_machineList ) {
    l_runtime = list()
    for( l_nodes in i_nodeCounts ) {
      l_runtime = c( l_runtime, l_expectedSimulationTime[[paste(i_meshID, '_', l_nodes, '_', l_machine, sep='')]] )
    }
    l_runtime <- l_runtime[[1]] / unlist(l_runtime)

    print(l_machine)
    print(unlist(i_nodeCounts))
    print(l_runtime)

    pdf(paste('scaling_', i_meshID, '_', l_machine,'.pdf', sep=''))
    plot( x=i_nodeCounts, l_runtime, ylab='parallel efficiency (weak-scaling)', main=l_machine )
    dev.off()
  }
}

printStrongScaling <- function( i_machineList,
                                   i_nodeCounts,
                                   i_meshID ) {
  for( l_machine in i_machineList ) {
    l_runtime = list()
    for( l_nodes in i_nodeCounts ) {
      l_runtime = c( l_runtime, l_expectedSimulationTime[[paste(i_meshID, '_', l_nodes, '_', l_machine, sep='')]] * ( l_nodes / i_nodeCounts[[1]]) )
    }
    l_runtime <- l_runtime[[1]] / unlist(l_runtime)

    print(l_machine)
    print(unlist(i_nodeCounts))
    print(l_runtime)

    pdf(paste('scaling_', i_meshID, '_', l_machine,'.pdf', sep=''))
    plot( x=i_nodeCounts, l_runtime, ylab='parallel efficiency (strong-scaling)', main=l_machine )
    dev.off()
  }
}

l_config = list ( mesh_names = list( #'statistics_cubes_1024',
                                     #'statistics_cubes_2048',
                                     #'statistics_cubes_4096',
                                     #'statistics_cubes_9216',
                                     #'statistics_Landers191M_02_05_02_512',
                                     #'statistics_Landers191M_02_05_02_768',
                                     #'statistics_Landers191M_02_05_02_1024',
                                     #'statistics_Landers191M_02_05_02_1536',
                                     #'statistics_Landers191M_02_05_02_3072',
                                     #'statistics_Landers191M_02_05_02_2048',
                                     #'statistics_Landers191M_02_05_02_4096',
                                     #'statistics_Landers191M_02_05_02_6144',
                                     #'statistics_Landers191M_02_05_02_9216',
                                     #'statistics_Landers191M_02_05_02_12288',
                                     #'statistics_Landers191M_02_05_02_24756',
                                     'statistics_LOH1_small_1',
                                     'statistics_LOH1_small_2',
                                     'statistics_LOH1_small_4',
                                     'statistics_LOH1_small_8',
                                     'statistics_LOH1_small_16',
                                     'statistics_LOH1_small_32',
                                     'statistics_LOH1_small_64',
                                     'statistics_LOH1_small_128',
                                     'statistics_LOH1_small_256',
                                     'statistics_LOH1_small_512',
                                     'statistics_LOH1_small_1024'),

                  statistics_directory = 'mesh_statistics',

                  performance_parameters = list( supermuc = list( basisFunctions       = 56,
                                                                  quantities           = 9,
                                                                  dofs_size            = 56*9*8,
                                                                  network_bandwidth    = 0.4,                   # unidirectionl, TODO: missing reference point
                                                                  neigh_integration = 0.00000131,               # 1250 elements per core, seissol proxy, random
                                                                  local_integration   = 0.00000244,             # 1250 elements per core, seissol proxy, random
                                                                  dynamic_rupture      = 109.33 /  22798 / 1000 )   # TODO: missing reference point
                                                                                )
                 )

l_expectedSimulationTime = list()

message( 'lets go' )
for( l_machine in list('supermuc') ) {
  for( l_meshName in l_config$mesh_names ) {
    message( 'analyzing: ', l_meshName )
    l_expectedSimulationTime[[paste(l_meshName,'_',l_machine, sep='')]] =
     computeMeshStatistics( i_meshName              = l_meshName,
                            i_pathToCsvFile         = paste(l_config$statistics_directory,'/',l_meshName,'.csv', sep=''),
                            i_performanceParameters = (l_config$performance_parameters)[[l_machine]],
                            i_outputFileTable       = paste(l_meshName,'_',l_machine,'.csv', sep=''),
                            i_outputFilePlot        = paste(l_meshName,'_',l_machine,'.pdf', sep='') )
  }
}

#message( 'generating weak-scaling plot for cubes' )
#printWeakScaling( list('supermuc'), list( 1024, 2048, 4096, 9216 ), 'statistics_cubes' )

#message( 'generating strong-scaling plot for Landers' )
#printStrongScaling( list('supermuc'), list( 768, 1024, 1536, 2048, 3072, 4096, 6144, 9216, 12288, 24756 ), 'statistics_Landers191M_02_05_02' )

message( 'generating strong-scaling plot for LOH1' )
printStrongScaling( list('supermuc'), list( 1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024 ), 'statistics_LOH1_small' )


#' @exportClass Customer
#' @name Customer
#' @rdname Customer
#' @aliases Customer-class
#' @title The Customer class
#'
#' @description
#' This class is part of the \pkg{HNUORTools}. It represents
#' the base class for every locateable class in an
#' \dfn{Operations-Research (OR)}-context.
#'
#' @details Find here the defined slots for this class.
#'      @section Slots:
#'        \describe{
#'              \item{\code{demand}:}{
#'                  Object of class \code{"numeric"}, containing the amount for the demand.
#'                  The default value cannot be negative.
#'              }
#'              \item{\code{isDummy}:}{
#'                  Object of class \code{"logical"}, indicating if a customer was added
#'                  in an algorithm (e.g. TPP-Column-Minimum-Method) in order to avoid
#'                  degenerated soulutions.
#'              }
#'        }
#'      @section Slots (from \code{\link{Node}}):
#'          \describe{
#'              \item{\code{id}:}{
#'                  Object of class \code{"character"}, containing data from id.
#'                  \strong{Should be unique}.
#'                  The default value will be caluclated randomly.
#'              }
#'              \item{\code{label}:}{
#'                  Object of class \code{"character"}, containing the label of
#'                  the \code{\link{Customer}}.
#'                  The default value will be caluclated randomly.
#'              }
#'              \item{\code{x}:}{
#'                  Object of class \code{"numeric"}, containing the x-coordinate
#'                  of the \code{\link{Customer}}.
#'                  The default value will be caluclated randomly.
#'              }
#'              \item{\code{y}:}{
#'                  Object of class \code{"numeric"}, containing the y-coordinate
#'                  of the \code{\link{Customer}}.
#'                  The default value will be caluclated randomly.
#'              }
#'          }
#'
#' @seealso The classes are derived from this class and the following Methods can be used with this class.:
#'      @section Creating objects of type \code{\link{Customer}}:
#'          \describe{
#'              \item{Creating an \code{S4-Object}}{
#'                  \code{new("Customer", ...)}
#'              }
#'              \item{Converting from a \code{data.frame}}{
#'                  \code{as.Customer{<data.frame>}}
#'                  See also below in the Methods-Section.
#'              }
#'              \item{Converting from a \code{list}}{
#'                  \code{as.Customer{<list>}}
#'                  See also below in the Methods-Section.
#'              }
#'          }
#'      @section Methods:
#'          \describe{
#'              \item{\code{as.list(Customer, ...)}}{
#'                  Converts a \code{\link{Customer}} into a \code{\link{list}}.
#'                  \code{...} are user-defined (not used) parameters.
#'              }
#'              \item{\code{as.data.frame(Customer, ...)}}{
#'                  Converts a \code{\link{Customer}} into a \code{\link{data.frame}}.
#'                  \code{as.data.frame} accepts the optional parameter \code{withrownames} of class \code{"logical"} (default is \code{TRUE}).
#'                  If \code{withrownames == TRUE} the returned \code{\link{data.frame}} will recieve the \code{id} as rowname.
#'                  \code{...} are user-defined (not used) parameters.
#'
#'              }
#'              \item{\code{as.Customer(obj)}}{
#'                  Converts an object of class \code{\link{data.frame}} or of class \code{\link{list}} into a \code{\link{Customer}}.
#'              }
#'              \item{\code{is.Customer(obj)}}{
#'                  Checks if the object \code{obj} is of type \code{\link{Customer}}.
#'              }
#'              \item{\code{\link{getDistance}}}{
#'                  Calculating the distance between two \code{\link{Node}s}
#'                  (As the classes \code{\link{Customer}} and \code{\link{Warehouse}}
#'                  depend on \code{\link{Node}}, distances can be calculated between any of these objects).
#'              }
#'              \item{\code{\link{getpolar}}}{
#'                  Calculating the polar-angle to the x-Axis of a link,
#'                  connecting two \code{\link{Node}s}
#'                  (As the classes \code{\link{Customer}} and \code{\link{Warehouse}}
#'                  depend on \code{\link{Node}}, polar-angles can be calculated between any of these objects).
#'              }
#'          }
#'
#'      @section Derived Classes:
#'         None.
#'      @section To be used for:
#'          \describe{
#'              \item{WLP}{
#'                   Warehouse-Location-Problem
#'              }
#'              \item{TPP}{
#'                  Transportation Problem
#'              }
#'              \item{VRP}{
#'                  Vehicle Routing Problem
#'              }
#'          }
#'
#' @note
#'      for citing use: Felix Lindemann (2014). HNUORTools: Operations Research Tools. R package version 1.1-0. \url{http://felixlindemann.github.io/HNUORTools/}.
#'
#' @author Dipl. Kfm. Felix Lindemann \email{felix.lindemann@@hs-neu-ulm.de}
#'
#' Wissenschaftlicher Mitarbeiter
#' Kompetenzzentrum Logistik
#' Buro ZWEI, 17
#'
#' Hochschule fur angewandte Wissenschaften
#' Fachhochschule Neu-Ulm | Neu-Ulm University
#' Wileystr. 1
#'
#' D-89231 Neu-Ulm
#'
#'
#' Phone   +49(0)731-9762-1437
#' Web      \url{www.hs-neu-ulm.de/felix-lindemann/}
#'          \url{http://felixlindemann.blogspot.de}
#' @examples
#' # create a new Customer with specific values
#' x<- new("Customer", x= 10, y=20, id="myid", label = "mylabel", demand = 20)
#' x
#' # create from data.frame
#' df<- data.frame(x=10,y=20, demand = 30)
#' new("Customer", df)
#' as(df, "Customer")
#' as.Customer(df)
#' #create some Customers
#' n1 <- new("Customer",x=10,y=20, demand = 30, id ="n1")
#' n2 <- new("Customer",x=13,y=24, demand = 40, id ="n2")
#' # calculate Beeline distance
#' #getDistance(n1,n2) # should result 5
#' #getDistance(n1,n2, costs = 2) # should result 10
setClass(
  Class = "Customer",
  representation=representation(
    demand="numeric",
    isDummy = "logical"
  ),
  contains = "Node",
  validity = function(object){

    df <- as.data.frame(object)
    node <- as.Node(df)
    if(validObject(node)){
      N <- length(object@id)
      if(length(object@demand) != N)
        return("Invalid Object of Type 'Customer': the length of the attributes 'id' and 'demand' differ!")
      if(length(object@isDummy) != N)
        return("Invalid Object of Type 'Customer': the length of the attributes 'id' and 'isDummy' differ!")

      if( sum(is.null(object@demand)) + sum( is.na(object@demand)) > 0 )
        return(paste("Invalid Object of Type 'Customer': Error with value demand: Value is not initialized", class(object@demand)))

      if( sum(is.null(object@isDummy)) + sum( is.na(object@isDummy)) > 0)
        return(paste("Invalid Object of Type 'Customer': Error with value isDummy: Value is not initialized", class(object@isDummy)))

      if( class(object@demand)!="numeric" )
        return(paste("Invalid Object of Type 'Customer': Error with value demand: expected numeric datatype, but obtained", class(object@demand)))

      if( class(object@isDummy)!="logical" )
        return(paste("Invalid Object of Type 'Customer': Error with value isDummy: expected logical datatype, but obtained", class(object@isDummy)))

      if(min(object@demand)<0)
          return(paste("Invalid Object of Type 'Customer': Error with value demand: at least one value is negative. Only positive Values are allowed."))

      return(TRUE)

    }else{
      return (FALSE)
    }
  }
)
################################### initialize - Method ###################################################
#' @title initialize Method
#' @name initialize
#' @aliases initialize,Customer-method
#' @rdname initialize-methods
setMethod("initialize", signature="Customer", function(.Object, data=NULL, ...) {

  li <- list(...)
  if(is.null(li$showwarnings))  li$showwarnings <- FALSE

  #init from parent Node-Object.
  N<-1

  if(!is.null(data)){

    if(class(data) =="list") {
      data <- as.data.frame(data)
    }
    if(class(data) =="data.frame") {
      N<-nrow(data)
      li$isDummy  <- data$isDummy
      li$demand   <- data$demand

    } else{
      stop("Error: argument data should be of type 'data.frame'!")
    }
  }
  if(is.null(li$demand) | length(li$demand) ==0) {
    li$demand <- as.numeric(sample(30:100,N,replace=TRUE))
    w <- paste("y-Coordinate simulated (y= ",li$demand,").")
    if(li$showwarnings) warning(w)
  }
  if(is.null(li$isDummy)) {
    li$isDummy <- rep(FALSE,N)
  }

  .Object@demand  <- as.numeric(  li$demand)
  .Object@isDummy <- as.logical(  li$isDummy)

  .Object<-callNextMethod(.Object,data,...)
  validObject(.Object)

  return(.Object )
})
################################### extract - Method ###################################################
#' @title Extract Methods
#' @name [
#' @aliases [,Customer-method
#' @rdname Extract-methods-2
setMethod("[", "Customer",
          function(x, i, j, drop){
            N <- length(x)
            if(min(i) <=0) stop("Index i out of bound. it must be positive non zero.")
            if(max(i) >N) stop("Index i out of bound. it must not be larger than the total length.")

            if(!missing(j)){
              if(class(j) == "character"){
                return(slot(x,j)[i])
              }
              if(class(j) == "integer"){
                return(slot(x,j)[i])
              }
            }
            df <- as.data.frame(x)[i,]
            return (new("Customer", df))
          }
)
################################### Set - Method ###################################################

#' @title Set Methods
#' @name [<-
#' @aliases [<-,Customer-method
#' @rdname Set-methods-2
#' @param x The Customer
#' @param i row-Index
#' @param j Name or Column index
setReplaceMethod("[",signature(x="Customer"),
                 function(x,i,j,value){
                   N <- length(x)
                   if(min(i) <=0) stop("Index i out of bound. It must be positive non zero.")
                   if(max(i) >N)  stop("Index i out of bound. It must not be larger than the total length.")
                   if(length(value)!=length(i)) stop("The replacement length is not equal to the number of elements to be replaced.")

                   if(is(value, "Customer")){

                     #replace the item(s) regarding to i
                     x$id[i]    <- value@id
                     x$label[i] <- value@label
                     x$x[i]     <- value@x
                     x$y[i]     <- value@y
                     x$demand[i]     <- value@demand
                     x$isDummy[i]     <- value@isDummy

                     # return new item
                     return (x)
                   } else {
                     if(missing(j)) {
                       # call the function recursivly
                       # might throw an error if the conversion is not supported.
                       x[i] <- as.Customer(value)
                     }else{
                       if(class(j) == "character"){
                         slot(x,j)[i]     <- value
                       }else if(class(j) == "integer" | class(j) == "numeric"){
                         slot(x,slotNames(x)[j])[i]  <- value
                       }else{
                         warning(paste("no changes have been made. the provided value of j (class:",class(j), "value:",j,") was not recocnized."))
                       }
                     }
                     valid<-validObject(x)
                     return(x)
                   }
                 }
)

################################### as... - Method ###################################################
#local Methods
as.Customer.list       = function(x, ...){return(new("Customer", data=x))}
as.Customer.data.frame = function(x, ...){return(new("Customer", data=x))}
#local convert message
as.data.frame.Customer = function(x, ...){
  li<-list(...)
  if(is.null(li$withrownames)) li$withrownames <- FALSE
  df<-data.frame(id=x@id, label = x@label, x= x@x, y= x@y, demand=x@demand, isDummy = x@isDummy)
  if(li$withrownames) rownames(df)<-x@id
  return (df)
}
as.list.Customer = function(x, ...){list(id=x@id, label = x@label, x= x@x, y= x@y, demand=x@demand, isDummy = x@isDummy)}

#' @export
setGeneric("as.Customer",       function(x, ...) standardGeneric( "as.Customer"))

#' @title Convert Objects to Customers
#' @name as.Customer
#' @param x an  Object to convert.
#' @param ... optional parameters
#' @aliases as.Customer,list-method
#' @rdname as.Customer-methods
setMethod("as.Customer",     signature(x = "list"),       as.Customer.list)

#' @title Convert Objects to Customers
#' @name as.Customer
#' @aliases as.Customer,data.frame-method
#' @rdname as.Customer-methods
setMethod("as.Customer",    signature(x = "data.frame"),  as.Customer.data.frame)

#' @title Convert Objects to lists
#' @name as.list
#' @aliases as.list,Customer-method
#' @rdname as.list-methods
setMethod("as.list",        signature(x = "Customer"),        as.list.Customer)

#' @title Convert Objects to data.frames
#' @name as.data.frame
#' @aliases as.data.frame,Customer-method
#' @rdname as.data.frame-methods
setMethod("as.data.frame",  signature(x = "Customer"),        as.data.frame.Customer)

setAs("data.frame", "Customer", def=function(from){return(as.Customer.data.frame(from))})
setAs("list", "Customer", def=function(from){return(as.Customer.list(from))})
################################### is... - Method ###################################################

#' @title Checks if an Object is as Customer
#' @export
#' @name is.Customer
#' @aliases is.Customer
#' @param x the object to be checked for class \code{\link{Customer}}
#' @param ... optional Parameters (not supported)
setGeneric("is.Customer",       function(x, ...) standardGeneric( "is.Customer"))

#' @aliases is.Customer,Customer-method
#' @rdname is.Customer
setMethod( "is.Customer", "Customer", function(x, ...){return(is(x ,"Customer"))})

#' @title How many Customers are included?
#' @name length
#' @aliases length,Customer-method
#' @rdname length
setMethod("length", "Customer",
          function(x){
            N <- length(x@id)
            return(N)
          }
)