Allow user to give names to potentials

R/gibbsm.R

@@ -772,6 +772,7 @@ gibbsm <- function(configuration_list,
               coefficients_vector = fitted$coefficients_vector,
               aic = aic,
               bic = bic,
+              potential_names = parameters$potential_names,
               window = window,
               fit_algorithm = fitted$fit_algorithm,
               used_regularization = use_regularization,

R/model_parameters.R

@@ -161,13 +161,13 @@ make_default_model_parameters <- function(alpha,
                       might_contain_name = beta0)
 
   default_short_distances <- seq(from = 0, to = 0.1, length.out = length(short_range) + 1)[-1]
-  short_range <- lapply(seq_len(length(short_range)), function(i) {
+  short_range <- setNames(lapply(seq_len(length(short_range)), function(i) {
     s <- construct_if_missing(short_range[[i]], default_short_distances[i], number_types, matrix = TRUE)
     if(!isSymmetric(s)) {
       stop("One of the short-range interaction radii matrices is not symmetric.")
     }
     s
-  })
+  }), nm = names(short_range))
 
   medium_range <- construct_if_missing(medium_range, 0, number_types, matrix = TRUE)
   if(!isSymmetric(medium_range)) {
@@ -379,13 +379,13 @@ model_parameters <- function(window,
   }
 
   # Model is a list of length the number of potentials, missing values indicated by NULL
-  model <- lapply(model, function(x) {
+  model <- setNames(lapply(model, function(x) {
     if(is.null(x)) {
       "square_bump"
     } else {
       x
     }
-  })
+  }), nm = names(model))
 
   # Make covariates im objects with proper names.
   covariates <- coerce_to_named_im_objects(covariates, "unnamed_covariate", window)
@@ -409,6 +409,16 @@ model_parameters <- function(window,
                 "] and short_range: [", paste0(parameters$short_range, collapse = ", "), "]."))
   }
 
+  # See if there exists some potential names
+  potential_names <- if(!is.null(names(model))) {
+    names(model)
+  } else if(!is.null(names(parameters$short_range))) {
+    names(parameters$short_range)
+  } else {
+    NULL
+  }
+  parameters$potential_names <- potential_names
+
   # Set colnames and rownames
   parameters$alpha <- lapply(parameters$alpha, function(a) {
     colnames(a) <- rownames(a) <- parameters$types

R/potentials.R

@@ -19,11 +19,17 @@
 #'
 #' # Fit with gibbsm
 #'
-#' fit <- ppjsdm::gibbsm(configuration, short_range = c(matrix(0.05, 2, 2), matrix(0.1, 2, 2)), medium_range = matrix(0.2, 2, 2), long_range = matrix(0.3, 2, 2))
+#' fit <- ppjsdm::gibbsm(configuration, short_range = list(matrix(0.05, 2, 2), matrix(0.1, 2, 2)), medium_range = matrix(0.2, 2, 2), long_range = matrix(0.3, 2, 2))
 #'
 #' plot(ppjsdm::potentials(fit))
 #' plot(ppjsdm::potentials(fit, type1 = "A", type2 = "B"))
 #'
+#' # User wants to give names to the potentials
+#'
+#' fit <- ppjsdm::gibbsm(configuration, short_range = list(`0.05m potential` = matrix(0.05, 2, 2), `0.1m potential` = matrix(0.1, 2, 2)), medium_range = matrix(0.2, 2, 2), long_range = matrix(0.3, 2, 2))
+#'
+#' plot(ppjsdm::potentials(fit))
+#'
 potentials <- function(fit,
                        type1 = 1,
                        type2 = type1) {
@@ -38,7 +44,7 @@ potentials <- function(fit,
   alpha <- fit$coefficients$alpha
 
   # Construct the short-range potentials
-  short_potentials <- lapply(seq_len(length(model)), function(i) {
+  short_potentials <- setNames(lapply(seq_len(length(model)), function(i) {
     mod <- model[[i]]
     if(mod == "exponential") {
       function(x) alpha[[i]][type1, type2] * exp(-log(2) * x / short_range[[i]][type1, type2])
@@ -56,7 +62,7 @@ potentials <- function(fit,
     } else {
       stop(paste0("Short-range model not recognised: ", mod))
     }
-  })
+  }), nm = fit$potential_names)
 
   # Extract variables relevant to the medium-range potentials
   medium_range_model <- fit$parameters$medium_range_model
@@ -164,7 +170,14 @@ plot.potentials <- function(x, ...) {
     theme(legend.title = element_blank())
 
   for(i in seq_len(length(x$short))) {
-    assign(paste0("name", i), paste0("Short ", i))
+    if(is.null(names(x$short)[i])) {
+      assign(paste0("name", i), paste0("Short ", i))
+    } else if(names(x$short)[i] == "") { # Cannot put this as a conditional in the previous case due to no short-circuiting
+      assign(paste0("name", i), paste0("Short ", i))
+    } else {
+      assign(paste0("name", i), names(x$short)[i])
+    }
+
     g <- g + geom_line(aes_string(x = "x", y = paste0("short", i), colour = paste0("name", i)), size = 1, alpha = 0.8)
   }