R/createFBTS.R

In rte-antares-rpackage/fbAntares:

#' @title Creation of time series of typical days for Antares studies
#' 
#' @description 
#' This function defines for each studied day in an Antares study the most 
#' representative typical flow-based day, and finally creates daily time series.
#' To establish this correlation, the inputs of the function must include 
#' a probability matrix (calculated for each set of typical days with the package 
#' \code{fbClust}) and the path to the Antares study to provide flow-based 
#' domains with. The probability matrix
#' will be used to compute a weighted draw among the possible typical days.
#'
#' @param opts \code{list} of simulation parameters returned by the function 
#' \link{setSimulationPath}. Link to the Antares study.
#'  By default, the value is \code{antaresRead::simOptions()}
#' @param probabilityMatrix \code{list}, correlation between climatic factors and 
#' flow-based typical days, such as returned by \code{fbClust::getProbability}. 
#' The columns names must be renamed to match Antares' inputs, use the function
#'  \link{setNamesProbabilityMatrix}. Initial format is : 
#'  area_variable (Ex: fr_load, de_solar ...)
#' @param multiplier \code{data.frame} enabling to convert load factors or normalised 
#' values into production/consumption in MW. 
#' Two columns:
#' \itemize{
#' \item variable : Name of variable (ex: \code{"fr@wind"})
#' \item coef : mutiplier coefficient, for example the installed capacity.
#' }
#' @param calendar \code{character}, path to a txt files with two columns,
#' a column Date in the format month-day and a column class with the classes
#' associated to the dates (summer, winter and interSeason).
#' @param firstDay \code{numeric} Type of the first day of the study (between 1 and 7). 
#' For example, if the first day is a
#' Wednesday, you must specify firstDay = 3. The first day can be directly calculated
#' by the function \link{identifyFirstDay}.
#' @param seed \code{numeric} fixed random seed, used for the weighted draw of the 
#' typical days. By default, the value is 123456
#' @param silent \code{boolean}, non display of a progress bar. By default, the value is FALSE.
#' @param outputPath \code{character}, path of the folder where the time series of 
#' typical flow-based output file (ts.txt) will be written. The current directory 
#' is chosen by default.
#' 
#' @examples
#'
#' \dontrun{
#' library(antaresRead)
#' library(data.table)
#'
#' matProb <- readRDS(system.file("testdata/MatProb.rds", package = "fbAntares"))
#' 
#' # Set the probabilityMatrix names and coefficients
#' matProb <- setNamesProbabilityMatrix(matProb, c("FR_load", "DE_wind", "DE_solar"),
#'                                    c("fr@load", "de@wind", "de@solar"))
#' 
#' multiplier <- data.frame(variable = c("fr@load", "de@wind", "de@solar"),
#'                          coef = c(1, 71900, 61900))
#' 
#' # Set the path to Antares study inputs 
#' # Change it for the path of a study you have on your computer
#' opts <- antaresRead::setSimulationPath("../../Pour Julien/blop/MT_base_nucM2_2023/", 
#' simulation = 17)
#' 
#' # calendar
#' # first day identified based on the input data of the 
#' # Antares study designated by opts
#' firstDay <- identifyFirstDay(opts) 
#' # calendar in a csv file with all dates of one year and their classes
#' calendar <- system.file("calendar/calendar.txt", package = "fbAntares")
#' 
#' # Generate flow-based time series
#' ts <- createFBTS(opts = opts, probabilityMatrix = matProb, multiplier = multiplier,
#'                  calendar = calendar, firstDay = firstDay, outputPath = getwd())
#' }
#'                  
#' @import data.table
#' @import pipeR
#' @export
createFBTS <- function(
  opts, probabilityMatrix, multiplier,
  # interSeasonBegin, interSeasonEnd, 
  firstDay, seed = 123456, silent = FALSE, outputPath = getwd(),
  calendar = system.file("calendar/calendar.txt", package = "fbAntares")){
  
  
  
  ##test params
  #multiplier file
  txtProgressBar <- setTxtProgressBar <- NULL
  
  if(!is.data.frame(multiplier)){
    stop("multiplier must be a data.frame")
  }
  if(!all(names(multiplier)%in%c("variable", "coef"))){
    stop("Error, names of multiplier must be : 'variable' and 'coef'")
  }
  
  ##Test probabilityMatrix
  lapply(probabilityMatrix, function(X){
    if(!all(multiplier$variable %in% names(X))){
      stop("All names contains in multiplier$variable must be present in probabilityMatrix")
    }
  })%>>%invisible()
  
  #interSeasonBegin
  # interSeasonBegin <- as.Date(interSeasonBegin)
  # interSeasonEnd <- as.Date(interSeasonEnd)
  #firstDay
  if(!firstDay%in%1:7)stop("firstDay must be between 1 and 7")
  
  
  #Seed
  set.seed(seed)
  #Name of climate variables
  sdC <- multiplier$variable
  sdC <- as.character(sdC)
  
  
  #Copy proba data
  quantiles <- copy(probabilityMatrix[[2]])
  proba <- copy(probabilityMatrix[[1]])
  
  
  
  
  ##Test data coherency between multiplier and names of probabilityMatrix
  if(!all(sdC%in%names(quantiles))){
    stop("all multiplier variables must be contain in probabilityMatrix columns names")
  }
  
  if(!all(sdC%in%names(proba))){
    stop("all multiplier variables must be contain in probabilityMatrix columns names")
  }
  
  if(!all(grepl("@", sdC))){
    stop("probability matrix names must be changes using
         the syntax area@variable (e.g. fr@load). See function setNamesProbabilityMatrix().")
  }
  
  
  for(i in sdC){
    quantiles[, c(i) := lapply(.SD, function(X){
      X * multiplier[multiplier$variable == i,]$coef
    }), .SDcols = c(i)]
  }
  
  #Time series format
  .formatTs <- function(TS){
    names(TS)[ncol(TS)] <- paste0(TS$area[1],"@", names(TS)[ncol(TS)])
    TS[,"area" := NULL]
    TS
  }
  
  #Load concern TS
  listTs <- lapply(strsplit(sdC, "@"), function(X){
    reg <- list(X[1])
    
    if(! X[2] %in% c("load", "ror", "wind", "solar")) stop(
      "Only solar, ror, wind and load are available")
    
    names(reg) <- X[2]
    reg$timeStep <- "daily"
    reg$showProgress <- !silent
    reg$opts <- opts
    TS <- do.call(antaresRead::readInputTS, reg)
    TS[[names(reg)[1]]] <-    TS[[names(reg)[1]]] / 24
    TS <- .formatTs(TS)
    TS
  })
  
  #Merge TS
  reduceMerge <- function(x, y)merge(x, y, by = c("timeId","time","day","month","tsId"))
  outTs <- Reduce(reduceMerge, listTs)
  outTs
  
  ##Creat virtual calendar
  dates <- unique(outTs$time)
  
  # calendar <- .getVirtualCalendar(
  # dates, interSeasonBegin, interSeasonEnd, firstDay)
  # calendar <- rbindlist(sapply(names(calendar), function(X){
  #   data.table(time = calendar[[X]], class = X)
  # }, simplify = FALSE))
  calendar <- .getVirtualCalendarV2(
    dates = dates, calendar = calendar, firstDay = firstDay)
  outTs <- merge(outTs, calendar, by = "time")
  quantiles$quantiles <- gsub("Q", "", quantiles$quantiles)
  ##Use for test
  #outTs <- outTs[sample(1:nrow(outTs), 3000)]
  outTs <- data.table(outTs)
  #Compute typical day, first version (a bit slow) compute is done row/row
  
  names(quantiles) <- gsub("@", "__", names(quantiles))
  names(proba) <- gsub("@", "__", names(proba))
  
  
  
  
  quantiles <- data.frame(quantiles)
  
  
  if(!silent)cat("Compute typical day\n")
  if(!silent)pb <- txtProgressBar(char = "=", style = 3)
  
  names(outTs) <- gsub("@", "__", names(outTs))
  
  sdC<- gsub("@", "__", sdC)
  
  # sdC
  
  nN <- nrow(outTs)
  outTs$typicalDay <- sapply(1:nrow(outTs), function(R){
    # if(R%%100==0)print(R)
    #Select usefull data
    # outTs1 <- outTs[R]
    
    if(!silent)setTxtProgressBar(pb, R/nN)
    oo <- as.list(outTs[R])
    clAs <- oo$class
    
    quantilesClass <- quantiles[quantiles$class == clAs,]
    
    #For all variables create mini request
    allReq <- sapply(sdC, function(Y){
      
      quantilesClassVar <- quantilesClass[,c("quantiles", Y)]
      
      #If no row
      if(nrow(quantilesClassVar)>0){
        quantilesClassVar <- quantilesClassVar[!is.na(quantilesClassVar[,Y]),]
      }
      
      mynmber <- oo[[Y]]
      #If no row
      if(nrow(quantilesClassVar) == 0){
        littleReq <- paste0(Y, "== '0_1'")
      }
      #If one row
      if(nrow(quantilesClassVar) == 1){
        if(mynmber < quantilesClassVar[[Y]]){
          littleReq <- paste0(Y, "== '0_", quantilesClassVar$quantiles, "'")
        }else{
          littleReq <- paste0(Y, "== '", quantilesClassVar$quantiles, "_1'")
        }
      }
      #If more row
      if(nrow(quantilesClassVar) > 1){
        if(mynmber < quantilesClassVar[[Y]][1]){
          littleReq <- paste0(Y, "== '0_", quantilesClassVar$quantiles[1], "'")
        } else if(mynmber > quantilesClassVar[[Y]][length(quantilesClassVar[[Y]])]){
          littleReq <- paste0(Y, "== '", quantilesClassVar$quantiles[
            nrow(quantilesClassVar)], "_1'")
        }else{
          firstSup <- which.min(mynmber > quantilesClassVar[[Y]])
          littleReq <- paste0(Y, "== '", quantilesClassVar$quantiles[firstSup-1], "_",  
                              quantilesClassVar$quantiles[firstSup], "'")
          
        }
      }
      return(littleReq)
    }, simplify = FALSE)
    
    #Make final request
    allReq <- unlist(allReq)
    allReq <- paste(allReq, collapse = " & ")
    allReq <- paste0(allReq, " & class == '", clAs ,"'")
    toSample <- proba[eval(parse(text = allReq)), .SD, 
                      .SDcols = c("idDayType", "probability")]
    
    #Sample typical day
    if(nrow(toSample) == 1){
      idJt <- toSample$idDayType
    }else{
      idJt <- sample(toSample$idDayType, 1, prob = toSample$probability)
    }
    idJt
  })
  
  #Formating TS output
  tsend <- outTs[, .SD, .SDcols = c("time", "tsId", "typicalDay")]
  tsend <- dcast(tsend, time~tsId, value.var = "typicalDay")
  
  setnames(tsend, "time", "Date")
  tsend$Date <- as.character(tsend$Date)
  write.table(tsend, paste0(outputPath, "/ts.txt"), sep = "\t", row.names = FALSE)
  print(paste0(outputPath, "/ts.txt"))
  tsend
}

#' @title Rename the probabilityMatrix variables
#' 
#' @description 
#' This function changes the name of the variables in the probabilityMatrix, 
#' created by \code{flowBasedClustering::getProbability} and 
#' used by \link{createFBTS}. Aim: rename the variables into a format consistent 
#' with Antares inputs ("area@variable"). For example, go to \link{createFBTS}.
#'
#' @param data \code{list}, probabilityMatrix whose columns to rename,
#' calculated with \code{flowBasedClustering::getProbability}.
#' @param oldName \code{character} vector of old variables names
#' @param newName \code{character} vector of new variables names
#' 
#' @export
setNamesProbabilityMatrix <- function(data, oldName, newName){
  setnames(data[[1]],oldName, newName)
  setnames(data[[2]],oldName, newName)
  data
}