Skip to content

Commit

Permalink
closed : #1
Browse files Browse the repository at this point in the history 
closed : #2
Ajout des faces fixes, résolutions au moins temporaire de zone à lien, + modifs en tout genre
  • Loading branch information
@JulienBretteville
JulienBretteville committed Aug 6, 2019
1 parent adab3f2 commit ac27f58
Show file tree
Hide file tree
Showing 10 changed files with 268 additions and 60 deletions.
2 changes: 2 additions & 0 deletions NAMESPACE
View file
Original file line number Diff line number Diff line change
Expand Up @@ -30,7 +30,9 @@ importFrom(grDevices,chull)
importFrom(stats,cutree)
importFrom(stats,dist)
importFrom(stats,hclust)
importFrom(stats,kmeans)
importFrom(stats,rnorm)
importFrom(stats,runif)
importFrom(utils,combn)
importFrom(utils,read.table)
importFrom(utils,write.table)
58 changes: 41 additions & 17 deletions R/classifPtdf.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -5,12 +5,13 @@
#'
#' @param PTDF \code{data.frame | data.table}, PTDF
#' @param nbClust \code{numeric}, number of cluster
#'
#' @importFrom stats kmeans
#' @importFrom utils read.table
#' @noRd
#'
giveBClassif <- function(PTDF, nbClust = 36)
giveBClassif <- function(PTDF, nbClust = 36, fixFaces, col_ptdf)
{

addFixFaces <- zone <- Ind <- NULL
PTDFKm <- PTDF[, .SD, .SDcols = colnames(PTDF)[grep("ptdf", colnames(PTDF))]]

# normalize the values in order to make the clustering
Expand All @@ -23,7 +24,8 @@ giveBClassif <- function(PTDF, nbClust = 36)

resKm <- kmeans(PTDFKm, centers = 5000, nstart = 20)

res <- cutree(hclust(dist(resKm$centers, method = "euclidean"), method = "ward.D"), nbClust)
res <- cutree(hclust(dist(resKm$centers, method = "euclidean"),
method = "ward.D"), nbClust)

dtresKm <- data.table(Ind =1:length(resKm$cluster) ,resKm = resKm$cluster)
dtresCah <- data.table(resKm = as.numeric(names(res)), res)
Expand All @@ -38,18 +40,40 @@ giveBClassif <- function(PTDF, nbClust = 36)



##### Explication nécessaire de la partie affectRow et de l'intérêt des faces fixes
##### car de meilleurs résultats sans l'utiliser
affectRow <- function(centers, valueVect)
{
conCernRow <- which.min(colSums((t(as.matrix(centers[, .SD, .SDcols = paste0(
"ptdf", c("BE", "DE", "FR", "AT"))])) - c(valueVect))^2))
centers[conCernRow, paste0(
"ptdf", c("BE", "DE", "FR", "AT")) := as.list(valueVect)]
##### Début test modif
addFixFaces <- function(centers, fixFaces) {
centers <- rbindlist(list(centers, rbindlist(lapply(1:nrow(fixFaces), function(X) {

ptdfnotnull <- col_ptdf[grepl(fixFaces[X, zone], col_ptdf)]
ptdfnull <- col_ptdf[!grepl(fixFaces[X, zone], col_ptdf)]
func <- fixFaces[X, func]
valfunc <- ifelse(func == "min", -1, 1)

dt <- read.table(text = "", col.names = c(ptdfnotnull, ptdfnull))
dt[1, ] <- c(valfunc, rep(0, length(ptdfnull)))
setDT(dt)
setcolorder(dt, colnames(centers))
dt
}))))
}
affectRow(centers, c(-1,0,0,0))
affectRow(centers, c(0,-1,0,0))
affectRow(centers, c(0,0,-1,0))
affectRow(centers, c(0,1,0,0))
centers[,paste0("ptdf", c("BE", "DE", "FR", "AT"))]
if (!is.null(fixFaces)) {
if (nrow(fixFaces) >= 1) {
centers <- addFixFaces(centers = centers, fixFaces = fixFaces)
}
}
centers
##### Fin test modif

# affectRow <- function(centers, valueVect)
# {
# conCernRow <- which.min(colSums((t(as.matrix(centers[, .SD, .SDcols = paste0(
# "ptdf", c("BE", "DE", "FR", "AT"))])) - c(valueVect))^2))
# centers[conCernRow, paste0(
# "ptdf", c("BE", "DE", "FR", "AT")) := as.list(valueVect)]
# }
# affectRow(centers, c(-1,0,0,0))
# affectRow(centers, c(0,-1,0,0))
# affectRow(centers, c(0,0,-1,0))
# affectRow(centers, c(0,1,0,0))
# centers[, paste0("ptdf", c("BE", "DE", "FR", "AT"))]
}
60 changes: 47 additions & 13 deletions R/computeFB.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -34,6 +34,12 @@
#' @param hubDrop \code{list}, list of hubs in the ptdf, with the ones which should
#' sustracted to the others as the names of the arrays which themself contain the ones which
#' be sustracted
#' @param fixFaces \code{data.table} data.table if you want to use fix faces for the creation
#' of the flowbased models. If you want to do it, the data.table has the following form :
#' data.table(func = c("min", "min", "max", "min"), zone = c("BE", "FR", "DE", "DE")).
#' func is the direction of the fix faces and zone is the area of this direction.
#' If you give for example min and DE, there will be a fix face at the minimum import
#' value of Germany.
#' @param areaName \code{character} The name of the area of your study, possible values are
#' cwe_at (default), cwe and other. If you choose other, you have to give a csv file
#' which explains how your area work.
Expand Down Expand Up @@ -67,10 +73,12 @@ computeFB <- function(PTDF = system.file("testdata/2019-07-18ptdfraw.csv", packa
outputName = paste0(getwd(), "/antaresInput"),
reports = TRUE,
areaName = "cwe_at", areacsv = NULL,
dayType = "All", hour = "All", nbFaces = 36,
dayType = "All", hour = "All", nbFaces = 75,
verbose = 1,
nbLines = 10000, maxiter = 10, thresholdIndic = 90, quad = F,
hubDrop = list(NL = c("BE", "DE", "FR", "AT")), seed = 123456)
hubDrop = list(NL = c("BE", "DE", "FR", "AT")),
fixFaces = NULL,
seed = 123456)
{
if (!is.null(seed)) {
set.seed(seed)
Expand All @@ -93,7 +101,19 @@ computeFB <- function(PTDF = system.file("testdata/2019-07-18ptdfraw.csv", packa
# univ <- .univ(nb = 500000, bInf = -10000, bSup = 10000,
# col_ptdf = col_ptdf, seed = seed)

face <- giveBClassif(PTDF, nbClust = nbFaces)
##### début test
if (!is.null(fixFaces)) {
if (nrow(fixFaces) > 0) {
.crtlFixFaces(fixFaces = fixFaces, col_ptdf = col_ptdf)

}
nbCl <- nbFaces-nrow(fixFaces)
} else {
nbCl <- nbFaces
}
##### fin test

face <- giveBClassif(PTDF, nbClust = nbCl, fixFaces = fixFaces, col_ptdf = col_ptdf)
face <- round(face, 2)
if(dayType == "All"){
dayType <- unique(PTDF$idDayType)
Expand All @@ -119,12 +139,29 @@ computeFB <- function(PTDF = system.file("testdata/2019-07-18ptdfraw.csv", packa
A <- PTDF[Period == combi[X, hour] &
idDayType == combi[X, dayType], .SD,
.SDcols = c("idDayType", "Period", col_ptdf, "ram")]

VERTRawDetails <- getVertices(A)
VERTRawDetails[, c("Date", "Period") := NULL]
VERTRawDetails[, c("idDayType", "Period") := list(combi[X, dayType], combi[X, hour])]
setcolorder(VERTRawDetails, c("idDayType", "Period"))

B <- copy(face)
B[, c("ram", "idDayType", "Period") := list(100, unique(A$idDayType), unique(A$Period))]
B[, c("ram", "idDayType", "Period") := list(1000, unique(A$idDayType), unique(A$Period))]
# B[, c("ram", "idDayType", "Period") := list(100, unique(A$idDayType), unique(A$Period))]
####### début test
if (!is.null(fixFaces)) {
if (nrow(fixFaces) > 0) {
dtFixRam <- .getFixRams(fixFaces, VERTRawDetails)
B[(nrow(B)-nrow(dtFixRam)+1):nrow(B), ram := abs(dtFixRam$ram)]
}
}
####### fin test
setcolorder(B, colnames(A))
res <- getBestPolyhedron(
A = A, B = B, nbLines = nbLines, maxiter = maxiter,
thresholdIndic = thresholdIndic, quad = quad, verbose = verbose)
thresholdIndic = thresholdIndic, quad = quad, verbose = verbose,
fixFaces = fixFaces, VERTRawDetails = VERTRawDetails)

res[, Face := NULL]
error <- evalInter(A, res)
if(verbose >= 2) {
Expand All @@ -138,10 +175,6 @@ computeFB <- function(PTDF = system.file("testdata/2019-07-18ptdfraw.csv", packa
VERTDetails[, c("idDayType", "Period") := list(combi[X, dayType], combi[X, hour])]
setcolorder(VERTDetails, c("idDayType", "Period"))

VERTRawDetails <- getVertices(A)
VERTRawDetails[, c("Date", "Period") := NULL]
VERTRawDetails[, c("idDayType", "Period") := list(combi[X, dayType], combi[X, hour])]
setcolorder(VERTRawDetails, c("idDayType", "Period"))

out <- data.table(Period = combi[X, hour], idDayType = combi[X, dayType],
PTDFDetails = list(res), PTDFRawDetails = list(PTDFRawDetails),
Expand All @@ -153,16 +186,17 @@ computeFB <- function(PTDF = system.file("testdata/2019-07-18ptdfraw.csv", packa
######### OK





######### OK

##Output
allFaces <- rbindlist(sapply(1:nrow(combi), function(X){

nam <- 1:nrow(antaresFace)
nam <- ifelse(nchar(nam) == 1, paste0("0", nam), nam)
maxnchar <- max(nchar(nam))
nam <- ifelse(nchar(nam)==1, paste0(0, nam), nam)
if(maxnchar == 3) {
nam <- ifelse(nchar(nam)==2, paste0(0, nam), nam)
}
data.table(Id_day = combi[X, dayType], Id_hour = combi[X, hour],
vect_b = flowbased[idDayType == combi[X, dayType] &
Period == combi[X, hour],
Expand Down
46 changes: 42 additions & 4 deletions R/crtlFunctions.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -8,7 +8,7 @@
if (nbLines <= 0) {
stop(paste("You should ask for at least one line, currently :", nbLines))
}
if (dim <= 2) {
if (dim < 2) {
stop(paste("You should ask for at least two-dimensions lines, currently :",
dim))
}
Expand Down Expand Up @@ -92,8 +92,12 @@
B <- face[, .SD, .SDcols = col_ptdf]
names(B) <- gsub("ptdf", "", names(B))
nam <- as.character(1:nrow(B))
maxnchar <- max(nchar(nam))
nam <- ifelse(nchar(nam)==1, paste0(0, nam), nam)

if(maxnchar == 3) {
nam <- ifelse(nchar(nam)==2, paste0(0, nam), nam)
}


if (areaName == "cwe_at") {
coefAntares <- data.table(Name = paste0("FB", nam),
Expand All @@ -116,8 +120,8 @@
stop(paste("The value of areaName must be one of the following :",
"cwe, cwe_at, other,", "currently :", areaName))
}


}

.ctrlHubDrop <- function(hubDrop, PTDF) {
Expand Down Expand Up @@ -164,3 +168,37 @@
}



.crtlFixFaces <- function(fixFaces, col_ptdf) {
col <- colnames(fixFaces)
if(!all(col == c("func", "zone"))) {
stop(paste("The colnames of fixFaces must be func and zone in this order.",
"Currently :", paste(col, collapse = ", ")))
}
valfunc <- unique(fixFaces$func)
valzone <- unique(fixFaces$zone)
if(!all(valfunc %in% c("min", "max"))) {
stop(paste("The values of func in fixFaces must be min or max, currently :",
paste(valfunc, collapse = ", ")))
}
if(!all(valzone %in% gsub("ptdf", "", col_ptdf))) {
stop(paste("The values of zone in fixFaces must be in the ptdf colnames, which are :",
paste(gsub("ptdf", "", col_ptdf), collapse = ", "), "currently :",
paste(valzone, collapse = ", ")))
}
}

.getFixRams <- function(fixFaces, VERTRawDetails) {
zone <- NULL
dtFixRam <- rbindlist(lapply(1:nrow(fixFaces), function(X) {
func <- fixFaces[X, func]
if (func == "min") {
ramVal <- VERTRawDetails[get(fixFaces[X, zone]) == min(get(fixFaces[X, zone])),
get(fixFaces[X, zone])]
} else if (func == "max") {
ramVal <- VERTRawDetails[get(fixFaces[X, zone]) == max(get(fixFaces[X, zone])),
get(fixFaces[X, zone])]
}
data.table(zone = fixFaces[X, zone], ram = ramVal)
}))
}
Loading

0 comments on commit ac27f58

Please sign in to comment.