Newer
Older
lon_dim <- which(names(dim(Analogs_fields)) == lon_name)
lat_dim <- which(names(dim(Analogs_fields)) == lat_name)
Analogs_metrics <- Subset(metrics,
along = which(names(dim(metrics)) == 'time'),
indices = best)
analog_number <- as.numeric(1:nrow(Analogs_metrics))
dim(analog_number) <- c(nAnalog = length(analog_number))
dim(Analogs_dates) <- c(nAnalog = length(Analogs_dates))
return(list(AnalogsFields = Analogs_fields,
Analog = analog_number,
metric = Analogs_metrics,
dates = Analogs_dates))
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
}
BestAnalog <- function(position, nAnalogs = nAnalogs, AnalogsInfo = FALSE,
criteria = 'Large_dist') {
pos_dim <- which(names(dim(position)) == 'pos')
if (dim(position)[pos_dim] == 1) {
pos1 <- Subset(position, along = pos_dim, indices = 1)
if (criteria != 'Large_dist') {
warning("Dimension 'pos' in parameter 'position' has length 1,",
" criteria 'Large_dist' will be used.")
criteria <- 'Large_dist'
}
} else if (dim(position)[pos_dim] == 2) {
pos1 <- Subset(position, along = pos_dim, indices = 1)
pos2 <- Subset(position, along = pos_dim, indices = 2)
if (criteria == 'Local_cor') {
warning("Dimension 'pos' in parameter 'position' has length 2,",
" criteria 'Local_dist' will be used.")
criteria <- 'Local_dist'
}
} else if (dim(position)[pos_dim] == 3) {
pos1 <- Subset(position, along = pos_dim, indices = 1)
pos2 <- Subset(position, along = pos_dim, indices = 2)
pos3 <- Subset(position, along = pos_dim, indices = 3)
if (criteria != 'Local_cor') {
warning("Parameter 'criteria' is set to", criteria, ".")
}
} else {
stop("Parameter 'position' has dimension 'pos' of different ",
"length than expected (from 1 to 3).")
}
if (criteria == 'Large_dist') {
if (AnalogsInfo == FALSE) {
pos <- pos1[1]
} else {
pos <- pos1[1 : nAnalogs]
}
Eva Rifà
committed
} else if (criteria == 'Local_dist') {
pos1 <- pos1[1 : nAnalogs]
pos2 <- pos2[1 : nAnalogs]
best <- match(pos1, pos2)
Eva Rifà
committed
if (length(best) == 1) {
warning("Just 1 best analog matching Large_dist and ",
"Local_dist criteria")
}
Eva Rifà
committed
if (length(best) < 1 | is.na(best[1]) == TRUE) {
stop("no best analogs matching Large_dist and Local_dist criterias,
Eva Rifà
committed
please increase nAnalogs")
}
pos <- pos2[as.logical(best)]
pos <- pos[which(!is.na(pos))]
if (AnalogsInfo == FALSE) {
pos <- pos[1]
}else {
pos <- pos}
} else if (criteria == 'Local_cor') {
pos1 <- pos1[1 : nAnalogs]
pos2 <- pos2[1 : nAnalogs]
best <- match(pos1, pos2)
Eva Rifà
committed
if (length(best) == 1) {
warning("Just 1 best analog matching Large_dist and ",
"Local_dist criteria")
}
Eva Rifà
committed
if (length(best) < 1 | is.na(best[1]) == TRUE) {
stop("no best analogs matching Large_dist and Local_dist criterias,
Eva Rifà
committed
please increase nAnalogs")
}
pos <- pos1[as.logical(best)]
pos <- pos[which(!is.na(pos))]
pos3 <- pos3[1 : nAnalogs]
best <- match(pos, pos3)
Eva Rifà
committed
if (length(best) == 1) {
warning("Just 1 best analog matching Large_dist, Local_dist and ",
"Local_cor criteria")
}
Eva Rifà
committed
if (length(best) < 1 | is.na(best[1]) == TRUE) {
stop("no best analogs matching Large_dist, Local_dist and Local_cor
Eva Rifà
committed
criterias, please increase nAnalogs")
}
pos <- pos[order(best, decreasing = F)]
pos <- pos[which(!is.na(pos))]
if (AnalogsInfo == FALSE) {
pos <- pos[1]
} else{
pos <- pos
}
return(pos)
}
}
Select <- function(expL, obsL, expVar = NULL, obsVar = NULL,
criteria = "Large_dist", lonL = NULL, latL = NULL,
lonVar = NULL, latVar = NULL, region = NULL,
lon_name = 'lon', lat_name = 'lat') {
names(dim(expL)) <- replace_repeat_dimnames(names(dim(expL)),
names(dim(obsL)),
lon_name = lon_name,
lat_name = lat_name)
metric1 <- Apply(list(obsL), target_dims = list(c(lat_name, lon_name)),
fun = .select, expL, metric = "dist",
lon_name = lon_name, lat_name = lat_name)$output1
Eva Rifà
committed
metric1.original = metric1
if (length(dim(metric1)) > 1) {
dim_time_obs <- which(names(dim(metric1)) == 'time' |
Eva Rifà
committed
names(dim(metric1)) == 'ftime')
dim(metric1) <- c(dim(metric1), metric=1)
margins <- c(1 : (length(dim(metric1))))[-dim_time_obs]
pos1 <- apply(metric1, margins, order)
names(dim(pos1))[1] <- 'time'
metric1 <- apply(metric1, margins, sort)
names(dim(metric1))[1] <- 'time'
Eva Rifà
committed
names(dim(metric1.original)) = names(dim(metric1))
} else {
pos1 <- order(metric1)
dim(pos1) <- c(time = length(pos1))
metric1 <- sort(metric1)
dim(metric1) <- c(time = length(metric1))
Eva Rifà
committed
dim(metric1.original) = dim(metric1)
dim_time_obs = 1
}
if (criteria == "Large_dist") {
dim(metric1) <- c(dim(metric1), metric = 1)
dim(pos1) <- c(dim(pos1), pos = 1)
Eva Rifà
committed
dim(metric1.original) = dim(metric1)
return(list(metric = metric1, metric.original = metric1.original,
position = pos1))
}
if (criteria == "Local_dist" | criteria == "Local_cor") {
obs <- SelBox(obsL, lon = lonL, lat = latL, region = region,
londim = lon_name, latdim = lat_name)$data
exp <- SelBox(expL, lon = lonL, lat = latL, region = region,
londim = lon_name, latdim = lat_name)$data
metric2 <- Apply(list(obs), target_dims = list(c(lat_name, lon_name)),
fun = .select, exp, metric = "dist",
lon_name = lon_name, lat_name = lat_name)$output1
dim(metric2) <- c(dim(metric2), metric=1)
margins <- c(1 : (length(dim(metric2))))[-dim_time_obs]
pos2 <- apply(metric2, margins, order)
dim(pos2) <- dim(pos1)
names(dim(pos2))[1] <- 'time'
metric2 <- apply(metric2, margins, sort)
names(dim(metric2))[1] <- 'time'
if (criteria == "Local_dist") {
metric <- abind(metric1, metric2, along = length(dim(metric1))+1)
metric.original <- abind(metric1.original,metric2.original,
Eva Rifà
committed
along = length(dim(metric1))+1)
position <- abind(pos1, pos2, along = length(dim(pos1))+1)
names(dim(metric)) <- c(names(dim(pos1)), 'metric')
names(dim(position)) <- c(names(dim(pos1)), 'pos')
names(dim(metric.original)) = names(dim(metric))
Eva Rifà
committed
return(list(metric = metric, metric.original = metric.original,
position = position))
}
}
if (criteria == "Local_cor") {
obs <- SelBox(obsVar, lon = lonVar, lat = latVar, region = region,
londim = lon_name, latdim = lat_name)$data
exp <- SelBox(expVar, lon = lonVar, lat = latVar, region = region,
londim = lon_name, latdim = lat_name)$data
metric3 <- Apply(list(obs), target_dims = list(c(lat_name, lon_name)),
fun = .select, exp, metric = "cor",
lon_name = lon_name, lat_name = lat_name)$output1
Eva Rifà
committed
metric3.original = metric3
dim(metric3) <- c(dim(metric3), metric=1)
margins <- c(1 : (length(dim(metric3))))[-dim_time_obs]
pos3 <- apply(abs(metric3), margins, order, decreasing = TRUE)
names(dim(pos3))[1] <- 'time'
metricsort <- metric3[pos3]
Eva Rifà
committed
dim(metricsort) = dim(metric3)
names(dim(metricsort))[1] <- 'time'
metric <- abind(metric1, metric2, metricsort,
along = length(dim(metric1)) + 1)
metric.original <- abind(metric1.original, metric2.original,
metric3.original,
along = length(dim(metric1)) + 1)
position <- abind(pos1, pos2, pos3, along = length(dim(pos1)) + 1)
names(dim(metric)) <- c(names(dim(metric1)), 'metric')
names(dim(position)) <- c(names(dim(pos1)), 'pos')
names(dim(metric.original)) = names(dim(metric))
return(list(metric = metric, metric.original=metric.original,
position = position))
}
else {
stop("Parameter 'criteria' must to be one of the: 'Large_dist', ",
"'Local_dist','Local_cor'.")
}
}
.select <- function(exp, obs, metric = "dist",
lon_name = 'lon', lat_name = 'lat') {
result <- Apply(list(obs), target_dims = list(c(lat_name, lon_name)),
fun = function(x) {sqrt(sum((x - exp) ^ 2, na.rm = TRUE))})$output1
result <- Apply(list(obs), target_dims = list(c(lat_name, lon_name)),
fun = function(x) {cor(as.vector(x),
as.vector(exp),
Eva Rifà
committed
method = "spearman")})$output1
Eva Rifà
committed
.time_ref <- function(time_obsL,time_expL,excludeTime) {
sameTime = which(time_obsL %in% time_expL)
Eva Rifà
committed
result<- c(time_obsL[1:(sameTime - excludeTime - 1)],
time_obsL[(sameTime + excludeTime + 1):length(time_obsL)])
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
result
}
replace_repeat_dimnames <- function(names_exp, names_obs, lat_name = 'lat',
lon_name = 'lon') {
if (!is.character(names_exp)) {
stop("Parameter 'names_exp' must be a vector of characters.")
}
if (!is.character(names_obs)) {
stop("Parameter 'names_obs' must be a vector of characters.")
}
latlon_dim_exp <- which(names_exp == lat_name | names_exp == lon_name)
latlon_dim_obs <- which(names_obs == lat_name | names_obs == lon_name)
if (any(unlist(lapply(names_exp[-latlon_dim_exp],
function(x){x == names_obs[-latlon_dim_obs]})))) {
original_pos <- lapply(names_exp,
function(x) which(x == names_obs[-latlon_dim_obs]))
original_pos <- lapply(original_pos, length) > 0
names_exp[original_pos] <- paste0(names_exp[original_pos], "_exp")
}
return(names_exp)
}
replace_time_dimnames <- function(dataL, time_name = 'time',
Eva Rifà
committed
stdate_name = 'stdate', ftime_name='ftime') {
names_obs = names(dim(dataL))
if (!is.character(names_obs)) {
stop("Parameter 'names_obs' must be a vector of characters.")
}
time_dim_obs <- which(names_obs == time_name |
names_obs == stdate_name | names_obs == ftime_name)
if (length(time_dim_obs) > 1) {
stop ("more than 1 time dimension, please give just 1")
}
if (length(time_dim_obs) == 0) {
warning ("name of time dimension is not 'ftime' or 'time' or 'stdate'
or time dimension is null")
}
if (length(time_dim_obs) != 0) {
names_obs[time_dim_obs]= time_name
names(dim(dataL)) = names_obs