From a842474fc94cde9cac04796dc03c9ddc87b10573 Mon Sep 17 00:00:00 2001 From: eduzenli Date: Tue, 2 May 2023 12:03:18 +0200 Subject: [PATCH 1/5] obs-cat probs are assumed NA for the obs grids with all NA --- R/LogisticReg.R | 51 +++++++++++++++++++++---------------------------- 1 file changed, 22 insertions(+), 29 deletions(-) diff --git a/R/LogisticReg.R b/R/LogisticReg.R index f569610..f655432 100644 --- a/R/LogisticReg.R +++ b/R/LogisticReg.R @@ -366,13 +366,23 @@ LogisticReg <- function(exp, obs, exp_lats, exp_lons, obs_lats, obs_lons, target } # convert observations to categorical predictands - obs_cat <- Apply(obs_ref, target_dims = sdate_dim, function(x) { - terc <- convert2prob(as.vector(x), prob = probs_cat) - apply(terc, 1, function(r) which (r == 1))}, - output_dims = sdate_dim, ncores = ncores)$output1 + +obs_cat <- Apply(obs_ref, target_dims = sdate_dim, function(x) { + if (!any(!is.na(x))) + { + rep(NA,length(x)) + } + else + { + terc <- convert2prob(as.vector(x), prob = probs_cat) + apply(terc, 1, function(r) which (r == 1)) + } + }, + output_dims = sdate_dim, ncores = ncores)$output1 + res <- Apply(list(predictor, obs_cat), target_dims = list(target_dims_predictor, sdate_dim), fun = function(x, y) - .log_reg(x = x, y = y, loocv = loocv), output_dims = c(sdate_dim, "category"), ncores = ncores)$output1 + .log_reg(x = x, y = y, loocv = loocv,probs_cat=probs_cat), output_dims = c(sdate_dim, "category"), ncores = ncores)$output1 if (return_most_likely_cat) { res <- Apply(res, target_dims = c(sdate_dim, "category"), .most_likely_category, @@ -439,8 +449,9 @@ LogisticReg <- function(exp, obs, exp_lats, exp_lons, obs_lats, obs_lons, target # if the data is all NA, force return return NA if (all(is.na(tmp_df)) | (sum(apply(tmp_df, 2, function(x) !all(is.na(x)))) == 1)) { - n <- nrow(tmp_df) - res <- matrix(NA, nrow = n, ncol = length(unique(tmp_df$y))) + n1 <- nrow(tmp_df) + n2<- length(probs_cat)+1 + res <- matrix(NA, nrow = n1, ncol = n2) } else { # training @@ -464,11 +475,11 @@ LogisticReg <- function(exp, obs, exp_lats, exp_lons, obs_lats, obs_lons, target if (loocv) { - lm1 <- lapply(1:nrow(df), function(j) ifelse(length(unique(df[-j,]$y))==1,NA,return(multinom(y ~ ., data = df[ -j, ])))) ## if all the observed categories are the same for the corresponding loocv step, assign NA to the relevant lm1 element. + lm1 <- lapply(1:nrow(df), function(j) multinom(y ~ ., data = df[ -j, ])) } else { - lm1 <- ifelse(length(unique(df$y))==1,list(NA),list(multinom(y ~ ., data = df))) + lm1 <- list(multinom(y ~ ., data = df)) } @@ -489,31 +500,20 @@ pred_lr <- function(df, lm1, loocv,probs_cat) { pred_vals_ls <-list() for (j in 1:nrow(df)) { - if(length(unique(df[-j,]$y))==1) - { - pred_vals_ls[[j]] <-NA ## if all the observed categories are the same for the corresponding loocv step, assign NA as predicted class (we need this step for the two-class cases. predict.multinom function provides the probability for the second category for two-class examples.we can obtain the prob of the first categort by 1-prob of second category) - } else{ pred_vals_ls[[j]] <- predict(lm1[[j]], df[j,], type = "probs") } - } pred_vals <- laply(pred_vals_ls, .fun = as.array) if( length(probs_cat)+1==2) { - - if (any(is.na(pred_vals))) ### if all the observed categories are the same for the corresponding loocv step, assign 100% probability to the observed categories for the relevant prediction. - { - ifelse(names(which.max(table(df$y)))==1,pred_vals[is.na(pred_vals)]<-0, - pred_vals[is.na(pred_vals)]<-1) - } pred_vals_dum<-array(NA,dim=c(nrow(df),2)) pred_vals_dum[,2]<-pred_vals pred_vals_dum[,1]<-1-pred_vals pred_vals<-pred_vals_dum colnames(pred_vals)<-c(1,2) - } - + } + } else { # type = class, probs @@ -523,13 +523,6 @@ pred_lr <- function(df, lm1, loocv,probs_cat) { if( length(probs_cat)+1==2) { - - if (any(is.na(pred_vals))) ### if all the observed categories are the same for the corresponding loocv step, assign 100% probability to the observed categories for the relevant prediction. - { - ifelse(names(which.max(table(df$y)))==1,pred_vals[is.na(pred_vals)]<-0, - pred_vals[is.na(pred_vals)]<-1) - } - pred_vals_dum<-array(NA,dim=c(nrow(df),2)) pred_vals_dum[,2]<-pred_vals pred_vals_dum[,1]<-1-pred_vals -- GitLab From a36ce01f009caa70ab7a07b369108eb51e5ea079 Mon Sep 17 00:00:00 2001 From: eduzenli Date: Wed, 3 May 2023 16:36:14 +0200 Subject: [PATCH 2/5] updated --- R/LogisticReg.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/LogisticReg.R b/R/LogisticReg.R index f655432..b8e2782 100644 --- a/R/LogisticReg.R +++ b/R/LogisticReg.R @@ -447,7 +447,7 @@ obs_cat <- Apply(obs_ref, target_dims = sdate_dim, function(x) { tmp_df <- data.frame(x = x, y = y) # if the data is all NA, force return return NA - if (all(is.na(tmp_df)) | (sum(apply(tmp_df, 2, function(x) !all(is.na(x)))) == 1)) { + if (all(is.na(tmp_df)) | (sum(apply(tmp_df, 2, function(x) !all(is.na(x)))) == 1) | all(is.na(tmp_df$y))) { n1 <- nrow(tmp_df) n2<- length(probs_cat)+1 -- GitLab From 7cb6e6fb5ba275957e4d9f0205a9e49b8ac496e5 Mon Sep 17 00:00:00 2001 From: Jaume Ramon Date: Thu, 11 May 2023 12:54:53 +0200 Subject: [PATCH 3/5] When given point observations, the observations are not interpolated. Until now, the observations were gridded and then interpolated to the points of interest. --- inst/examples/interpolation-bc.R | 26 ++++++++++++++++++++++++++ inst/examples/interpolation-lr.R | 11 +++++++++++ 2 files changed, 37 insertions(+) diff --git a/inst/examples/interpolation-bc.R b/inst/examples/interpolation-bc.R index 8287920..2d8ef6b 100644 --- a/inst/examples/interpolation-bc.R +++ b/inst/examples/interpolation-bc.R @@ -106,3 +106,29 @@ down_points_cal <- CST_Intbc(exp = exp, obs = obs, points = points, method_point down_points_qm <- CST_Intbc(exp = exp, obs = obs, points = points, method_point_interp = 'bilinear', target_grid = target_grid, bc_method = 'quantile_mapping', ncores = 4) +#------------------------------------ +# Downscaling to point locations given point observations +#------------------------------------ +points <- list(lat = c(36.1, 38.7), lon = c(-1.9, 0.8)) +obs_point <- Subset(obs, along = c("lat", "lon"), indices = list(1:2,1), drop = FALSE) +obs_point <- MergeDims(data = obs_point, merge_dims = c("lat", "lon"), rename_dim = 'location') +down_points2_sbc <- Intbc(exp = exp, obs = obs_point, exp_lats = attr(exp, "Variables")$dat1$lat, + exp_lons = attr(exp, "Variables")$dat1$lon, obs_lats = points$lat, + obs_lons = points$lon, points = points, method_point_interp = 'bilinear', + source_file_exp = attr(exp, "Files")[1,1,1], source_file_obs = NULL, + target_grid = target_grid, bc_method = 'simple_bias', ncores = 4) +down_points2_cal <- Intbc(exp = exp, obs = obs_point, exp_lats = attr(exp, "Variables")$dat1$lat, + exp_lons = attr(exp, "Variables")$dat1$lon, obs_lats = points$lat, + obs_lons = points$lon, points = points, method_point_interp = 'bilinear', + source_file_exp = attr(exp, "Files")[1,1,1], source_file_obs = NULL, + target_grid = target_grid, bc_method = 'calibration', ncores = 4) +down_points2_qm <- Intbc(exp = exp, obs = obs_point, exp_lats = attr(exp, "Variables")$dat1$lat, + exp_lons = attr(exp, "Variables")$dat1$lon, obs_lats = points$lat, + obs_lons = points$lon, points = points, method_point_interp = 'bilinear', + source_file_exp = attr(exp, "Files")[1,1,1], source_file_obs = NULL, + target_grid = target_grid, bc_method = 'quantile_mapping', ncores = 4) + + + + + diff --git a/inst/examples/interpolation-lr.R b/inst/examples/interpolation-lr.R index 21b4270..012dc3a 100644 --- a/inst/examples/interpolation-lr.R +++ b/inst/examples/interpolation-lr.R @@ -118,6 +118,17 @@ down_3_lsc <- CST_Intlr(exp = exp1, obs = obs1, target_grid = target_grid, lr_me down_3_nn <- CST_Intlr(exp = exp1, obs = obs1, target_grid = target_grid, lr_method = "4nn", int_method = "bilinear", predictors = NULL, loocv = TRUE, ncores = 4) +#---------------------------------- +# Downscaling to point locations with Intlr +#---------------------------------- +points <- list(lat = c(36.1, 38.7), lon = c(-1.9, 0.8)) +obs_point <- Subset(obs1, along = c("lat", "lon"), indices = list(1:2,1), drop = FALSE) +obs_point <- MergeDims(data = obs_point, merge_dims = c("lat", "lon"), rename_dim = 'location') +down_4_bas <- Intlr(exp = exp1, obs = obs_point, exp_lats = attr(exp1, "Variables")$dat1$lat, + exp_lons = attr(exp1, "Variables")$dat1$lon, obs_lats = points$lat, obs_lons = points$lon, + target_grid = target_grid, lr_method = "basic", points = points, method_point_interp = 'bilinear', + int_method = 'bilinear', predictors = NULL, source_file_exp = attr(exp1, "Files")[1,1,1], + source_file_obs = attr(obs1, "Files")[1,1,1], loocv = TRUE, ncores = 1) -- GitLab From 3a5aff720bf10b73c969551e51044cccf2cb1a08 Mon Sep 17 00:00:00 2001 From: Jaume Ramon Date: Fri, 12 May 2023 13:33:51 +0200 Subject: [PATCH 4/5] added the possibility of downscaling to point locations when the user passes point observations --- R/Intbc.R | 47 ++++++++++++++++++++++++++++---------------- R/Interpolation.R | 13 +++++++++++- R/Intlr.R | 27 +++++++++++++++++-------- R/LogisticReg.R | 50 +++++++++++++++++++++++++++++++---------------- 4 files changed, 94 insertions(+), 43 deletions(-) diff --git a/R/Intbc.R b/R/Intbc.R index 1cb558d..a436f90 100644 --- a/R/Intbc.R +++ b/R/Intbc.R @@ -82,9 +82,9 @@ CST_Intbc <- function(exp, obs, target_grid, bc_method, int_method = NULL, point res <- Intbc(exp = exp$data, obs = obs$data, exp_lats = exp$coords[[lat_dim]], exp_lons = exp$coords[[lon_dim]], obs_lats = obs$coords[[lat_dim]], obs_lons = obs$coords[[lon_dim]], target_grid = target_grid, int_method = int_method, bc_method = bc_method, points = points, - source_file = exp$attrs$source_files[1], method_point_interp = method_point_interp, - lat_dim = lat_dim, lon_dim = lon_dim, sdate_dim = sdate_dim, member_dim = member_dim, - region = region, ncores = ncores, ...) + source_file_exp = exp$attrs$source_files[1], source_file_obs = obs$attrs$source_files[1], + method_point_interp = method_point_interp, lat_dim = lat_dim, lon_dim = lon_dim, + sdate_dim = sdate_dim, member_dim = member_dim, region = region, ncores = ncores, ...) # Modify data, lat and lon in the origina s2dv_cube, adding the downscaled data exp$data <- res$data @@ -156,7 +156,9 @@ CST_Intbc <- function(exp, obs, target_grid, bc_method, int_method = NULL, point #''data' in exp and obs. Default set to "sdate". #'@param member_dim a character vector indicating the member dimension name in the element #''data' in exp and obs. Default set to "member". -#'@param source_file a character vector with a path to an example file of the exp data. +#'@param source_file_exp a character vector with a path to an example file of the exp data. +#'Only needed if the downscaling is to a point location. +#'@param source_file_obs a character vector with a path to an example file of the obs data. #'Only needed if the downscaling is to a point location. #'@param region a numeric vector indicating the borders of the region defined in obs. #'It consists of four elements in this order: lonmin, lonmax, latmin, latmax. lonmin refers @@ -187,7 +189,8 @@ CST_Intbc <- function(exp, obs, target_grid, bc_method, int_method = NULL, point #'@export Intbc <- function(exp, obs, exp_lats, exp_lons, obs_lats, obs_lons, target_grid, bc_method, int_method = NULL, points = NULL, method_point_interp = NULL, lat_dim = "lat", lon_dim = "lon", sdate_dim = "sdate", - time_dim = "time", member_dim = "member", source_file = NULL, region = NULL, ncores = NULL, ...) { + time_dim = "time", member_dim = "member", source_file_exp = NULL, source_file_obs = NULL, + region = NULL, ncores = NULL, ...) { if (!inherits(bc_method, 'character')) { stop("Parameter 'bc_method' must be of the class 'character'") @@ -209,14 +212,13 @@ Intbc <- function(exp, obs, exp_lats, exp_lons, obs_lats, obs_lons, target_grid, stop("Parameter 'member_dim' must be of the class 'character'") } - # Do not allow synonims for lat (latitude), lon (longitude) and time (sdate) dimension names - if (is.na(match(lon_dim, names(dim(exp)))) | is.na(match(lon_dim, names(dim(obs))))) { - stop("Missing longitude dimension in 'exp' and/or 'obs', or does not match the parameter ", + if (is.na(match(lon_dim, names(dim(exp))))) { + stop("Missing longitude dimension in 'exp', or does not match the parameter ", "'lon_dim'") } - if (is.na(match(lat_dim, names(dim(exp)))) | is.na(match(lat_dim, names(dim(obs))))) { - stop("Missing latitude dimension in 'exp' and/or 'obs', or does not match the parameter ", + if (is.na(match(lat_dim, names(dim(exp))))) { + stop("Missing latitude dimension in 'exp', or does not match the parameter ", "'lat_dim'") } @@ -235,9 +237,20 @@ Intbc <- function(exp, obs, exp_lats, exp_lons, obs_lats, obs_lons, target_grid, "Accepted methods are 'simple_bias', 'calibration', 'quantile_mapping'. The abbreviations ", "'sbc', 'cal', 'qm' can also be used.") } + + # When observations are pointwise + if (!is.null(points) & !is.na(match("location", names(dim(obs))))) { + point_obs <- T + # dimension aux in obs is needed + if (is.na(match("aux", names(dim(obs))))) { + obs <- InsertDim(obs, posdim = 1, lendim = 1, name = "aux") + } + } else { + point_obs <- F + } - if (!is.null(points) & is.null(source_file)) { - stop("No source file found. Source file must be provided in the parameter 'source_file'.") + if (!is.null(points) & (is.null(source_file_exp))) { + stop("No source file found. Source file must be provided in the parameter 'source_file_exp'.") } if (!is.null(points) & is.null(method_point_interp)) { @@ -260,18 +273,18 @@ Intbc <- function(exp, obs, exp_lats, exp_lons, obs_lats, obs_lons, target_grid, } exp_interpolated <- Interpolation(exp = exp, lats = exp_lats, lons = exp_lons, target_grid = target_grid, - method_remap = int_method, points = points, source_file = source_file, + method_remap = int_method, points = points, source_file = source_file_exp, lat_dim = lat_dim, lon_dim = lon_dim, method_point_interp = method_point_interp, region = region, ncores = ncores) # If after interpolating 'exp' data the coordinates do not match, the obs data is interpolated to # the same grid to force the matching if ((!.check_coords(lat1 = exp_interpolated$lat, lat2 = obs_lats, - lon1 = exp_interpolated$lon, lon2 = obs_lons)) | !is.null(points)) { + lon1 = exp_interpolated$lon, lon2 = obs_lons)) | !(point_obs)) { obs_interpolated <- Interpolation(exp = obs, lats = obs_lats, lons = obs_lons, target_grid = target_grid, - method_remap = int_method, points = points, source_file = source_file, - lat_dim = lat_dim, lon_dim = lon_dim, - method_point_interp = method_point_interp, region = region, ncores = ncores) + method_remap = int_method, points = points, source_file = source_file_obs, + lat_dim = lat_dim, lon_dim = lon_dim, method_point_interp = method_point_interp, + region = region, ncores = ncores) obs_ref <- obs_interpolated$data } else { obs_ref <- obs diff --git a/R/Interpolation.R b/R/Interpolation.R index e939e0c..4cf0c1e 100644 --- a/R/Interpolation.R +++ b/R/Interpolation.R @@ -688,7 +688,18 @@ Interpolation <- function(exp, lats, lons, points = NULL, source_file = NULL, me #----------------- is <- weights.df$i js <- weights.df$j - + + #----------------- + # If any of the indices happens to be 0, + # change it by 1 but give a warning + #----------------- + if (any(is == 0) | any(js == 0)) { + warning("Is the point location in the border of the region? The code can run but ", + "results will be less accurate than those obtained with a larger region." ) + is[is == 0] <- 1 + js[js == 0] <- 1 + } + #----------------- # Get indices of original is and js in unique(is),unique(js) that were requested #----------------- diff --git a/R/Intlr.R b/R/Intlr.R index b4b8a75..f31b7d3 100644 --- a/R/Intlr.R +++ b/R/Intlr.R @@ -259,13 +259,13 @@ Intlr <- function(exp, obs, exp_lats, exp_lons, obs_lats, obs_lons, lr_method, t stop("Parameter 'large_scale_predictor_dimname' must be of the class 'character'") } - if (is.na(match(lon_dim, names(dim(exp)))) | is.na(match(lon_dim, names(dim(obs))))) { - stop("Missing longitude dimension in 'exp' and/or 'obs', or does not match the parameter ", + if (is.na(match(lon_dim, names(dim(exp))))) { + stop("Missing longitude dimension in 'exp', or does not match the parameter ", "'lon_dim'") } - if (is.na(match(lat_dim, names(dim(exp)))) | is.na(match(lat_dim, names(dim(obs))))) { - stop("Missing latitude dimension in 'exp' and/or 'obs', or does not match the parameter ", + if (is.na(match(lat_dim, names(dim(exp))))) { + stop("Missing latitude dimension in 'exp', or does not match the parameter ", "'lat_dim'") } @@ -273,10 +273,21 @@ Intlr <- function(exp, obs, exp_lats, exp_lons, obs_lats, obs_lons, lr_method, t stop("Missing start date dimension in 'exp' and/or 'obs', or does not match the parameter ", "'sdate_dim'") } + + # When observations are pointwise + if (!is.null(points) & !is.na(match("location", names(dim(obs))))) { + point_obs <- T + # dimension aux in obs is needed + if (is.na(match("aux", names(dim(obs))))) { + obs <- InsertDim(obs, posdim = 1, lendim = 1, name = "aux") + } + } else { + point_obs <- F + } - if (!is.null(points) & (is.null(source_file_exp) | is.null(source_file_obs))) { - stop("No source files found. Source files for exp and obs must be provided in the parameters ", - "'source_file_exp' and 'source_file_obs', respectively.") + if (!is.null(points) & is.null(source_file_exp)) { + stop("No source file found. Source file for exp must be provided in the parameter ", + "'source_file_exp'.") } if (!is.null(points) & is.null(method_point_interp)) { @@ -344,7 +355,7 @@ Intlr <- function(exp, obs, exp_lats, exp_lons, obs_lats, obs_lons, lr_method, t # If after interpolating 'exp' data the coordinates do not match, the obs data is interpolated to # the same grid to force the matching if ((!.check_coords(lat1 = exp_interpolated$lat, lat2 = obs_lats, - lon1 = exp_interpolated$lon, lon2 = obs_lons)) | !is.null(points)) { + lon1 = exp_interpolated$lon, lon2 = obs_lons)) | !(point_obs)) { obs_interpolated <- Interpolation(exp = obs, lats = obs_lats, lons = obs_lons, target_grid = target_grid, points = points, method_point_interp = method_point_interp, source_file = source_file_obs, lat_dim = lat_dim, lon_dim = lon_dim, diff --git a/R/LogisticReg.R b/R/LogisticReg.R index f569610..e2bacd0 100644 --- a/R/LogisticReg.R +++ b/R/LogisticReg.R @@ -53,8 +53,6 @@ #''data' in exp and obs. Default set to "sdate". #'@param member_dim a character vector indicating the member dimension name in the element #''data' in exp and obs. Default set to "member". -#'@param source_file a character vector with a path to an example file of the exp data. -#'Only needed if the downscaling is to a point location. #'@param region a numeric vector indicating the borders of the region defined in obs. #'It consists of four elements in this order: lonmin, lonmax, latmin, latmax. lonmin refers #'to the left border, while lonmax refers to the right border. latmin indicates the lower @@ -108,8 +106,8 @@ CST_LogisticReg <- function(exp, obs, target_grid, int_method = NULL, log_reg_me int_method = int_method, log_reg_method = log_reg_method, points = points, method_point_interp = method_point_interp, lat_dim = lat_dim, lon_dim = lon_dim, sdate_dim = sdate_dim, member_dim = member_dim, - source_file = exp$attrs$source_files[1], region = region, loocv = loocv, - ncores = ncores) + source_file_exp = exp$attrs$source_files[1], source_file_obs = obs$attrs$source_files[1], + region = region, loocv = loocv, ncores = ncores) # Modify data, lat and lon in the origina s2dv_cube, adding the downscaled data exp$data <- res$data @@ -189,7 +187,9 @@ CST_LogisticReg <- function(exp, obs, target_grid, int_method = NULL, log_reg_me #''data' in exp and obs. Default set to "sdate". #'@param member_dim a character vector indicating the member dimension name in the element #''data' in exp and obs. Default set to "member". -#'@param source_file a character vector with a path to an example file of the exp data. +#'@param source_file_exp a character vector with a path to an example file of the exp data. +#'Only needed if the downscaling is to a point location. +#'@param source_file_obs a character vector with a path to an example file of the obs data. #'Only needed if the downscaling is to a point location. #'@param region a numeric vector indicating the borders of the region defined in obs. #'It consists of four elements in this order: lonmin, lonmax, latmin, latmax. lonmin refers @@ -224,10 +224,10 @@ CST_LogisticReg <- function(exp, obs, target_grid, int_method = NULL, log_reg_me #'probs_cat = c(1/3, 2/3)) #'@export LogisticReg <- function(exp, obs, exp_lats, exp_lons, obs_lats, obs_lons, target_grid, - int_method = NULL, log_reg_method = "ens_mean", probs_cat = c(1/3,2/3), + int_method = NULL, log_reg_method = "ens_mean", probs_cat = c(1/3,2/3), return_most_likely_cat = FALSE, points = NULL, method_point_interp = NULL, lat_dim = "lat", lon_dim = "lon", sdate_dim = "sdate", member_dim = "member", - source_file = NULL, region = NULL, loocv = FALSE, ncores = NULL) { + source_file_exp = NULL, source_file_obs = NULL, region = NULL, loocv = FALSE, ncores = NULL) { #----------------------------------- # Checkings @@ -260,8 +260,12 @@ LogisticReg <- function(exp, obs, exp_lats, exp_lons, obs_lats, obs_lons, target stop("Parameter 'member_dim' must be of the class 'character'") } - if (!is.null(source_file) & !inherits(source_file, 'character')) { - stop("Parameter 'source_file' must be of the class 'character'") + if (!is.null(source_file_exp) & !inherits(source_file_exp, 'character')) { + stop("Parameter 'source_file_exp' must be of the class 'character'") + } + + if (!is.null(source_file_obs) & !inherits(source_file_obs, 'character')) { + stop("Parameter 'source_file_obs' must be of the class 'character'") } if (!inherits(loocv, 'logical')) { @@ -288,8 +292,19 @@ LogisticReg <- function(exp, obs, exp_lats, exp_lons, obs_lats, obs_lons, target "'member_dim'") } - if (!is.null(points) & (is.null(source_file))) { - stop("No source files found. One source file for exp must be provided in the parameter 'source_file'.") + # When observations are pointwise + if (!is.null(points) & !is.na(match("location", names(dim(obs))))) { + point_obs <- T + # dimension aux in obs is needed + if (is.na(match("aux", names(dim(obs))))) { + obs <- InsertDim(obs, posdim = 1, lendim = 1, name = "aux") + } + } else { + point_obs <- F + } + + if (!is.null(points) & (is.null(source_file_exp))) { + stop("No source file found. Source file must be provided in the parameter 'source_file_exp'.") } if (!is.null(points) & is.null(method_point_interp)) { @@ -324,13 +339,14 @@ LogisticReg <- function(exp, obs, exp_lats, exp_lons, obs_lats, obs_lons, target } exp_interpolated <- Interpolation(exp = exp, lats = exp_lats, lons = exp_lons, target_grid = target_grid, - method_remap = int_method, points = points, source_file = source_file, + method_remap = int_method, points = points, source_file = source_file_exp, lat_dim = lat_dim, lon_dim = lon_dim, method_point_interp = method_point_interp, region = region, ncores = ncores) # compute ensemble mean anomalies if (log_reg_method == "ens_mean") { - predictor <- .get_ens_mean_anom(obj_ens = exp_interpolated$data, member_dim = member_dim, sdate_dim = sdate_dim, ncores = ncores) + predictor <- .get_ens_mean_anom(obj_ens = exp_interpolated$data, member_dim = member_dim, sdate_dim = sdate_dim, + ncores = ncores) target_dims_predictor <- sdate_dim } @@ -355,11 +371,11 @@ LogisticReg <- function(exp, obs, exp_lats, exp_lons, obs_lats, obs_lons, target # If after interpolating 'exp' data the coordinates do not match, the obs data is interpolated to # the same grid to force the matching if ((!.check_coords(lat1 = exp_interpolated$lat, lat2 = obs_lats, - lon1 = exp_interpolated$lon, lon2 = obs_lons)) | !is.null(points)) { + lon1 = exp_interpolated$lon, lon2 = obs_lons)) | !(point_obs)) { obs_interpolated <- Interpolation(exp = obs, lats = obs_lats, lons = obs_lons, target_grid = target_grid, - method_remap = int_method, points = points, source_file = source_file, - lat_dim = lat_dim, lon_dim = lon_dim, - method_point_interp = method_point_interp, region = region, ncores = ncores) + method_remap = int_method, points = points, source_file = source_file_obs, + lat_dim = lat_dim, lon_dim = lon_dim, method_point_interp = method_point_interp, + region = region, ncores = ncores) obs_ref <- obs_interpolated$data } else { obs_ref <- obs -- GitLab From 2c71957e4d7b95b76eb162f34b5bb9a71619571a Mon Sep 17 00:00:00 2001 From: eduzenli Date: Fri, 12 May 2023 15:26:24 +0200 Subject: [PATCH 5/5] dev-point-obs updates are merged with dev_logreg updates --- R/LogisticReg.R | 17 ++++++----------- 1 file changed, 6 insertions(+), 11 deletions(-) diff --git a/R/LogisticReg.R b/R/LogisticReg.R index b41df33..60681b9 100644 --- a/R/LogisticReg.R +++ b/R/LogisticReg.R @@ -384,17 +384,12 @@ LogisticReg <- function(exp, obs, exp_lats, exp_lons, obs_lats, obs_lons, target # convert observations to categorical predictands obs_cat <- Apply(obs_ref, target_dims = sdate_dim, function(x) { - if (!any(!is.na(x))) - { - rep(NA,length(x)) - } - else - { - terc <- convert2prob(as.vector(x), prob = probs_cat) - apply(terc, 1, function(r) which (r == 1)) - } - }, - output_dims = sdate_dim, ncores = ncores)$output1 + if (!any(!is.na(x))) { + rep(NA,length(x)) + } else { + terc <- convert2prob(as.vector(x), prob = probs_cat) + apply(terc, 1, function(r) which (r == 1))}}, + output_dims = sdate_dim, ncores = ncores)$output1 res <- Apply(list(predictor, obs_cat), target_dims = list(target_dims_predictor, sdate_dim), fun = function(x, y) -- GitLab