tests/replica/replica_make_nng.R

In scclust: Size-Constrained Clustering

get_simple_nng <- function(distances,
                           num_nn,
                           radius,
                           primary_data_points) {
  num_data_points <- ncol(distances)
  nng <- matrix(FALSE, ncol = num_data_points, nrow = num_data_points)

  if (is.null(primary_data_points)) {
    lookup <- 1:num_data_points
  } else {
    lookup <- which(primary_data_points)
  }

  invisible(lapply(lookup, function(i) {
    nn <- order(distances[i, ])[1:num_nn]
    if (is.null(radius) || distances[i, nn[num_nn]] <= radius) {
      nng[nn, i] <<- TRUE
    }
  }))

  nng
}


get_type_nng <- function(distances,
                         type_labels,
                         type_size_constraints,
                         total_size_constraint,
                         radius,
                         primary_data_points) {
  num_data_points <- ncol(distances)
  nng <- matrix(FALSE, ncol = num_data_points, nrow = num_data_points)

  if (is.null(primary_data_points)) {
    lookup <- 1:num_data_points
  } else {
    lookup <- which(primary_data_points)
  }

  for (t in 1:length(type_size_constraints)) {
    if (type_size_constraints[t] > 0) {
      new_lookup <- lookup
      of_type <- which(type_labels == (t - 1))
      for (i in lookup) {
        type_dist <- as.numeric(distances[i, of_type])
        type_dist_order <- order(type_dist)[1:type_size_constraints[t]]
        if (!is.null(radius) && type_dist[type_dist_order[type_size_constraints[t]]] > radius) {
          nng[, i] <- FALSE
          new_lookup <- setdiff(new_lookup, i)
        } else {
          nng[of_type[type_dist_order], i] <- TRUE
        }
      }
      lookup <- new_lookup
    }
  }

  extra_con <- total_size_constraint - sum(type_size_constraints)
  if (extra_con > 0) {
    for (i in lookup) {
      unconnected <- which(!nng[, i])
      type_dist <- as.numeric(distances[i, unconnected])
      type_dist_order <- order(type_dist)[1:extra_con]
      if (!is.null(radius) && type_dist[type_dist_order[extra_con]] > radius) {
        nng[, i] <- FALSE
      } else {
        nng[unconnected[type_dist_order], i] <- TRUE
      }
    }
  }

  nng
}