Newer
Older
londim = lon_name, latdim = lat_name)$data
Analogs_fields <- Subset(obsVar,
along = which(names(dim(obsVar)) == 'time'),
indices = best)
warning("Parameter 'obsVar' is NULL and the returned field ",
"will be computed from 'obsL' (same variable).")
} else {
obslocal <- SelBox(obsVar, lon = lonVar, lat = latVar,
region = region, londim = lon_name, latdim = lat_name)$data
Analogs_fields <- Subset(obslocal,
along = which(names(dim(obslocal)) == 'time'),
indices = best)
}
} else {
warning("One or more of the parameter 'region', 'lonVar' and 'latVar'",
" are NULL and the large scale field will be returned.")
if (is.null(obsVar)) {
Analogs_fields <- Subset(obsL, along = which(names(dim(obsL)) == 'time'),
indices = best)
} else {
Analogs_fields <- Subset(obsVar,
along = which(names(dim(obsVar)) == 'time'),
indices = best)
}
}
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))
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
}
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)])
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
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