r4urep coverage - 100.00%

Files
Source

#' @title Display file name
#' @description Display the file and a part of its path, depending of the number of layer chosen
#' @concept File
#' @param numberOfLayer the size of the path
#'                      (1 means just the file,
#'                       2 the folder which contains the file and the file, etc.)
#' @param separator the separator of the path
#' @param path the path
#'
#' @return the file name and a part of its path
#' @examples r4urep::displayFileName(path = "my/path/fileName.R")
#' @export
displayFileName <- function(numberOfLayer = 2, separator = "/", path) {
  splittedPath <- unlist(strsplit(path, split = separator))
  strToReturn <- "["
  for (i in (length(splittedPath) - numberOfLayer + 1):length(splittedPath)) {
    strToReturn <- paste0(strToReturn, separator, splittedPath[i])
  }
  return(paste0(strToReturn, "]"))
}

#' @title Save a rds file as a csv file
#' @description Save a rds file as a csv file
#' @concept File
#' @param pathRDS the rds file to save
#' @param pathCSV path of the csv file
#'
#' @return none
#' @export
saveRDSasCSV <- function(pathRDS, pathCSV) {
  utils::write.table(
    x = readRDS(pathRDS),
    file = pathCSV,
    row.names = FALSE,
    na = "",
    dec = ".",
    sep = ";",
    qmethod = c("double"))
}

#' @title Load table file
#' @description Load a table file into a dataframe
#' @concept File
#' @param path the path of the file to load
#' @param header Is there a header in the file (TRUE by default)
#' @param colFactor column number or name which are factors
#' @param renameIndex the index of the column to rename
#' @param renameValue the new name of the column (must correspond to the index)
#' @param reorderColumn the new order of the column (NULL by default)
#' @param sep type of separator (white space by default)
#' @param dec type of decimal (dot by default)
#'
#' @return the loaded dataframe
#' @export
loadTableFile <- function(path,
                          header = TRUE,
                          colFactor = c(),
                          renameValue = c(),
                          renameIndex = c(),
                          reorderColumn = NULL,
                          sep = "",
                          dec = ".") {
  dfToReturn <- utils::read.table(path, header, sep = sep, dec = dec)

  for (columnIndex in colFactor) {
    if (is.character(columnIndex))
      index <- which(colnames(dfToReturn) == columnIndex)
    else
      index <- columnIndex

    dfToReturn[, index] <- as.factor(dfToReturn[, index])
  }

  indexRenameValue <- 1
  for (columnIndex in renameIndex) {
    if (is.character(columnIndex))
      index <- which(colnames(dfToReturn) == columnIndex)
    else
      index <- columnIndex

    colnames(dfToReturn)[index] <- renameValue[indexRenameValue]
    indexRenameValue <- indexRenameValue + 1
  }

  if (!is.null(reorderColumn)) {
    dfToReturn <- dfToReturn[, reorderColumn]
  }

  return(dfToReturn)
}

#' @title Compute the distance to the identity line
#' @description Compute the distance between the identity line (1:1) and the point created by the x and y vectors
#' @concept Statistics
#' @param x the x-coordinates of the points
#' @param y the y-coordinates of the points
#' @param type type of distance we want to compute ("E" for Euclidian, "XY" for distance trough x or y axis)
#'
#' @return the vector of distance
#' @examples r4urep::computeDistanceToIdentityLine(x = c(1,2,3), y = c(3,1,8))
#' @export
computeDistanceToIdentityLine <- function(x, y, type = "E") {

  if (length(x) != length(y)) {
    stop("X and Y must have the same length")
  }

  if (!(type %in% c("E", "XY"))) {
    stop("type must be a valid option")
  }

  if (type == "E") {
    return(abs(x - y) / sqrt(2))
  }else if (type == "XY") {
    return(abs(x - y))
  }
}

#' @title Compute the weighted mean
#' @description Compute the weighted mean of data with given weights
#' @concept Statistics
#' @param data vector of data (one per weight) to compute the weighted mean
#' @param weights vector of weights corresponding to the data
#'
#' @return the weighted mean of the data
#' @examples r4urep::weightedMean(data = c(1, 4), w = c(2, 4))
#' @export
weightedMean <- function(data, weights) {
  if (length(data) != length(weights))
    stop("Impossible to compute the weighted mean for two vector of different size")

  return(sum(data * weights) / sum(weights))
}

#' @title Compute the weighted variance
#' @description Compute the weighted variance of data with given weights
#' @concept Statistics
#' @param data vector of data (one per weight) to compute the weighted variance
#' @param weights vector of weights corresponding to the data
#'
#' @return the weighted variance of the data
#' @examples r4urep::weightedVariance(data = c(1, 4), w = c(2, 4))
#' @export
weightedVariance <- function(data, weights) {
  if (length(data) != length(weights))
    stop("Impossible to compute the weighted variance for two vector of different size")

  return(sum(((data - r4urep::weightedMean(data, weights))^2) * (weights / sum(weights))))
}

#' @title Compute the weighted skewness
#' @description Compute the weighted skewness of data with given weights
#' @concept Statistics
#' @param data vector of data (one per weight) to compute the weighted skewness
#' @param weights vector of weights corresponding to the data
#'
#' @return the weighted skewness of the data
#' @examples r4urep::weightedSkewness(data = c(1, 4), w = c(2, 4))
#' @export
weightedSkewness <- function(data, weights) {
  if (length(data) != length(weights))
    stop("Impossible to compute the weighted skewness for two vector of different size")

  a <- (data - r4urep::weightedMean(data, weights))^3
  b <- r4urep::weightedVariance(data, weights)^(3 / 2)
  c <- weights / sum(weights)
  sumValues <- sum(a / b * c)
  return(sumValues)
}

#' @title Compute the weighted kurtosis
#' @description Compute the weighted kurtosis of data with given weights
#' @concept Statistics
#' @param weights vector of weights corresponding to the data
#' @param data vector of data (one per weight) to compute the weighted kurtosis
#'
#' @return the weighted kurtosis of the data
#' @examples r4urep::weightedKurtosis(data = c(1, 4), w = c(2, 4))
#' @export
weightedKurtosis <- function(data, weights) {
  if (length(data) != length(weights))
    stop("Impossible to compute the weighted kurtosis for two vector of different size")

  a <- (data - r4urep::weightedMean(data, weights))^4
  b <- r4urep::weightedVariance(data, weights)^2
  c <- weights / sum(weights)
  sumValues <- sum(a / b * c)
  return(sumValues)
}

#' @title Compute the weighted mean, variance, skewness and kurtosis
#' @description Compute the weighted mean, variance, skewness and kurtosis of data with given weights
#' @concept Statistics
#' @param data the data
#' @param weights the vector or matrix of weights corresponding to the data (each row corresponding to an
#' iteration of data)
#'
#' @return the list of weighted mean, variance, skewness and kurtosis of the data
#' @examples r4urep::weightedMVSK(data = c(1,2,3),
#'                                      weights = matrix(data = c(1,1,1,2,1,3), nrow = 2,ncol = 3))
#' @export
weightedMVSK <- function(data, weights) {

  if (is.vector(weights)) {
    if (length(data) != length(weights)) {
      stop("Impossible to compute the weighted mean, variance,",
           " skewness and kurtosis for two vector of different size")
    }else {
      weights <- matrix(data = weights, nrow = 1, ncol = length(data))
    }
  } else if (length(data) != ncol(weights)) {
    stop("Impossible to compute the weighted mean, variance,",
         " skewness and kurtosis for data with incorrect size,",
         " data and weights must have the same column numbers !")
  }
  data <- matrix(data = data, nrow = 1, ncol = length(data))

  weights <- weights / rowSums(weights)

  mean <- (weights %*% t(data))

  diffDataMean <- data[rep(x = 1, times = nrow(mean)), ] - mean[, rep(x = 1, times = ncol(data))]

  mean <- mean[, 1]

  variance <- rowSums(diffDataMean^2 * weights)

  diffDataMeanOnSd <- diffDataMean / sqrt(variance)

  skewness <- rowSums(diffDataMeanOnSd^3 * weights)

  kurtosis <- rowSums(diffDataMeanOnSd^4 * weights)

  return(list(mean = mean, variance = variance, skewness = skewness, kurtosis = kurtosis))
}

#' @title Compare a value to random values
#' @description Compute different statistics (standardized by the distribution of random  values).
#' @concept Statistics
#' @param observedValue the observed value
#' @param randomValues the random Values
#' @param significanceThreshold the array of values used to compute the quantile (c(0.025, 0.975) by default)
#' @return a list corresponding to :
#' - the observed value
#' - quantile values (minimum significance threshold)
#' - quantile values (maximum significance threshold)
#' - significance (observed value not in quantile values)
#' @examples nullModelDistributionStatistics(observedValue = 2, randomValues = c(1, 4, 5, 6, 8),
#' significanceThreshold = c(0.025,0.975))
#' @export
nullModelDistributionStatistics <- function(observedValue,
                                            randomValues,
                                            significanceThreshold = c(0.025, 0.975)) {
  meanRandom <- mean(randomValues)
  sdRandom <- stats::sd(randomValues)
  standardizedObserved  <- (observedValue - meanRandom) / sdRandom
  quant <- stats::quantile(x = randomValues,
                           probs = significanceThreshold)
  return(list(standardizedObserved,
              (quant[[1]] - meanRandom) / sdRandom,
              (quant[[2]] - meanRandom) / sdRandom,
              observedValue > quant[[2]] || observedValue < quant[[1]]))
}

1		#' @title Display file name
2		#' @description Display the file and a part of its path, depending of the number of layer chosen
3		#' @concept File
4		#' @param numberOfLayer the size of the path
5		#' (1 means just the file,
6		#' 2 the folder which contains the file and the file, etc.)
7		#' @param separator the separator of the path
8		#' @param path the path
9		#'
10		#' @return the file name and a part of its path
11		#' @examples r4urep::displayFileName(path = "my/path/fileName.R")
12		#' @export
13		displayFileName <- function(numberOfLayer = 2, separator = "/", path) {
14	1x	splittedPath <- unlist(strsplit(path, split = separator))
15	1x	strToReturn <- "["
16	1x	for (i in (length(splittedPath) - numberOfLayer + 1):length(splittedPath)) {
17	2x	strToReturn <- paste0(strToReturn, separator, splittedPath[i])
18		}
19	1x	return(paste0(strToReturn, "]"))
20		}
21
22		#' @title Save a rds file as a csv file
23		#' @description Save a rds file as a csv file
24		#' @concept File
25		#' @param pathRDS the rds file to save
26		#' @param pathCSV path of the csv file
27		#'
28		#' @return none
29		#' @export
30		saveRDSasCSV <- function(pathRDS, pathCSV) {
31	1x	utils::write.table(
32	1x	x = readRDS(pathRDS),
33	1x	file = pathCSV,
34	1x	row.names = FALSE,
35	1x	na = "",
36	1x	dec = ".",
37	1x	sep = ";",
38	1x	qmethod = c("double"))
39		}
40
41		#' @title Load table file
42		#' @description Load a table file into a dataframe
43		#' @concept File
44		#' @param path the path of the file to load
45		#' @param header Is there a header in the file (TRUE by default)
46		#' @param colFactor column number or name which are factors
47		#' @param renameIndex the index of the column to rename
48		#' @param renameValue the new name of the column (must correspond to the index)
49		#' @param reorderColumn the new order of the column (NULL by default)
50		#' @param sep type of separator (white space by default)
51		#' @param dec type of decimal (dot by default)
52		#'
53		#' @return the loaded dataframe
54		#' @export
55		loadTableFile <- function(path,
56		header = TRUE,
57		colFactor = c(),
58		renameValue = c(),
59		renameIndex = c(),
60		reorderColumn = NULL,
61		sep = "",
62		dec = ".") {
63	6x	dfToReturn <- utils::read.table(path, header, sep = sep, dec = dec)
64
65	6x	for (columnIndex in colFactor) {
66	2x	if (is.character(columnIndex))
67	1x	index <- which(colnames(dfToReturn) == columnIndex)
68		else
69	1x	index <- columnIndex
70
71	2x	dfToReturn[, index] <- as.factor(dfToReturn[, index])
72		}
73
74	6x	indexRenameValue <- 1
75	6x	for (columnIndex in renameIndex) {
76	2x	if (is.character(columnIndex))
77	1x	index <- which(colnames(dfToReturn) == columnIndex)
78		else
79	1x	index <- columnIndex
80
81	2x	colnames(dfToReturn)[index] <- renameValue[indexRenameValue]
82	2x	indexRenameValue <- indexRenameValue + 1
83		}
84
85	6x	if (!is.null(reorderColumn)) {
86	1x	dfToReturn <- dfToReturn[, reorderColumn]
87		}
88
89	6x	return(dfToReturn)
90		}

1		#' @title Compute the distance to the identity line
2		#' @description Compute the distance between the identity line (1:1) and the point created by the x and y vectors
3		#' @concept Statistics
4		#' @param x the x-coordinates of the points
5		#' @param y the y-coordinates of the points
6		#' @param type type of distance we want to compute ("E" for Euclidian, "XY" for distance trough x or y axis)
7		#'
8		#' @return the vector of distance
9		#' @examples r4urep::computeDistanceToIdentityLine(x = c(1,2,3), y = c(3,1,8))
10		#' @export
11		computeDistanceToIdentityLine <- function(x, y, type = "E") {
12
13	4x	if (length(x) != length(y)) {
14	1x	stop("X and Y must have the same length")
15		}
16
17	3x	if (!(type %in% c("E", "XY"))) {
18	1x	stop("type must be a valid option")
19		}
20
21	2x	if (type == "E") {
22	1x	return(abs(x - y) / sqrt(2))
23	1x	}else if (type == "XY") {
24	1x	return(abs(x - y))
25		}
26		}

1		#' @title Compute the weighted mean
2		#' @description Compute the weighted mean of data with given weights
3		#' @concept Statistics
4		#' @param data vector of data (one per weight) to compute the weighted mean
5		#' @param weights vector of weights corresponding to the data
6		#'
7		#' @return the weighted mean of the data
8		#' @examples r4urep::weightedMean(data = c(1, 4), w = c(2, 4))
9		#' @export
10		weightedMean <- function(data, weights) {
11	25x	if (length(data) != length(weights))
12	1x	stop("Impossible to compute the weighted mean for two vector of different size")
13
14	24x	return(sum(data * weights) / sum(weights))
15		}
16
17		#' @title Compute the weighted variance
18		#' @description Compute the weighted variance of data with given weights
19		#' @concept Statistics
20		#' @param data vector of data (one per weight) to compute the weighted variance
21		#' @param weights vector of weights corresponding to the data
22		#'
23		#' @return the weighted variance of the data
24		#' @examples r4urep::weightedVariance(data = c(1, 4), w = c(2, 4))
25		#' @export
26		weightedVariance <- function(data, weights) {
27	13x	if (length(data) != length(weights))
28	1x	stop("Impossible to compute the weighted variance for two vector of different size")
29
30	12x	return(sum(((data - r4urep::weightedMean(data, weights))^2) * (weights / sum(weights))))
31		}
32
33		#' @title Compute the weighted skewness
34		#' @description Compute the weighted skewness of data with given weights
35		#' @concept Statistics
36		#' @param data vector of data (one per weight) to compute the weighted skewness
37		#' @param weights vector of weights corresponding to the data
38		#'
39		#' @return the weighted skewness of the data
40		#' @examples r4urep::weightedSkewness(data = c(1, 4), w = c(2, 4))
41		#' @export
42		weightedSkewness <- function(data, weights) {
43	5x	if (length(data) != length(weights))
44	1x	stop("Impossible to compute the weighted skewness for two vector of different size")
45
46	4x	a <- (data - r4urep::weightedMean(data, weights))^3
47	4x	b <- r4urep::weightedVariance(data, weights)^(3 / 2)
48	4x	c <- weights / sum(weights)
49	4x	sumValues <- sum(a / b * c)
50	4x	return(sumValues)
51		}
52
53		#' @title Compute the weighted kurtosis
54		#' @description Compute the weighted kurtosis of data with given weights
55		#' @concept Statistics
56		#' @param weights vector of weights corresponding to the data
57		#' @param data vector of data (one per weight) to compute the weighted kurtosis
58		#'
59		#' @return the weighted kurtosis of the data
60		#' @examples r4urep::weightedKurtosis(data = c(1, 4), w = c(2, 4))
61		#' @export
62		weightedKurtosis <- function(data, weights) {
63	5x	if (length(data) != length(weights))
64	1x	stop("Impossible to compute the weighted kurtosis for two vector of different size")
65
66	4x	a <- (data - r4urep::weightedMean(data, weights))^4
67	4x	b <- r4urep::weightedVariance(data, weights)^2
68	4x	c <- weights / sum(weights)
69	4x	sumValues <- sum(a / b * c)
70	4x	return(sumValues)
71		}
72
73		#' @title Compute the weighted mean, variance, skewness and kurtosis
74		#' @description Compute the weighted mean, variance, skewness and kurtosis of data with given weights
75		#' @concept Statistics
76		#' @param data the data
77		#' @param weights the vector or matrix of weights corresponding to the data (each row corresponding to an
78		#' iteration of data)
79		#'
80		#' @return the list of weighted mean, variance, skewness and kurtosis of the data
81		#' @examples r4urep::weightedMVSK(data = c(1,2,3),
82		#' weights = matrix(data = c(1,1,1,2,1,3), nrow = 2,ncol = 3))
83		#' @export
84		weightedMVSK <- function(data, weights) {
85
86	4x	if (is.vector(weights)) {
87	2x	if (length(data) != length(weights)) {
88	1x	stop("Impossible to compute the weighted mean, variance,",
89	1x	" skewness and kurtosis for two vector of different size")
90		}else {
91	1x	weights <- matrix(data = weights, nrow = 1, ncol = length(data))
92		}
93	2x	} else if (length(data) != ncol(weights)) {
94	1x	stop("Impossible to compute the weighted mean, variance,",
95	1x	" skewness and kurtosis for data with incorrect size,",
96	1x	" data and weights must have the same column numbers !")
97		}
98	2x	data <- matrix(data = data, nrow = 1, ncol = length(data))
99
100	2x	weights <- weights / rowSums(weights)
101
102	2x	mean <- (weights %*% t(data))
103
104	2x	diffDataMean <- data[rep(x = 1, times = nrow(mean)), ] - mean[, rep(x = 1, times = ncol(data))]
105
106	2x	mean <- mean[, 1]
107
108	2x	variance <- rowSums(diffDataMean^2 * weights)
109
110	2x	diffDataMeanOnSd <- diffDataMean / sqrt(variance)
111
112	2x	skewness <- rowSums(diffDataMeanOnSd^3 * weights)
113
114	2x	kurtosis <- rowSums(diffDataMeanOnSd^4 * weights)
115
116	2x	return(list(mean = mean, variance = variance, skewness = skewness, kurtosis = kurtosis))
117		}

1		#' @title Compare a value to random values
2		#' @description Compute different statistics (standardized by the distribution of random values).
3		#' @concept Statistics
4		#' @param observedValue the observed value
5		#' @param randomValues the random Values
6		#' @param significanceThreshold the array of values used to compute the quantile (c(0.025, 0.975) by default)
7		#' @return a list corresponding to :
8		#' - the observed value
9		#' - quantile values (minimum significance threshold)
10		#' - quantile values (maximum significance threshold)
11		#' - significance (observed value not in quantile values)
12		#' @examples nullModelDistributionStatistics(observedValue = 2, randomValues = c(1, 4, 5, 6, 8),
13		#' significanceThreshold = c(0.025,0.975))
14		#' @export
15		nullModelDistributionStatistics <- function(observedValue,
16		randomValues,
17		significanceThreshold = c(0.025, 0.975)) {
18	1x	meanRandom <- mean(randomValues)
19	1x	sdRandom <- stats::sd(randomValues)
20	1x	standardizedObserved <- (observedValue - meanRandom) / sdRandom
21	1x	quant <- stats::quantile(x = randomValues,
22	1x	probs = significanceThreshold)
23	1x	return(list(standardizedObserved,
24	1x	(quant[[1]] - meanRandom) / sdRandom,
25	1x	(quant[[2]] - meanRandom) / sdRandom,
26	1x	observedValue > quant[[2]] \|\| observedValue < quant[[1]]))
27		}