R/imputation_sample.R

In imperativa/imputationSample: Package untuk Memilih Sampel Imputasi

#' @title Memilih sampel imputasi
#' @description Memilih sampel imputasi dari filter yang telah dibuat dengan total weight tertentu
#' @param x Dataset yang digunakan.
#' @param filters Filter yang telah dibuat dengan fungsi \code{\link{create_filter}}.
#' @param weight_aggregate Besaran agregat weight dari sampel terpilih yang diinginkan.
#' @param weight_col Kolom yang digunakan sebagai weight dalam pemilihan sampel apabila tersedia.
#' @param iter Jumlah iterasi pengacakan dan pengambilan sampel yang diinginkan (semakin tinggi maka weight akan semakin sesuai).
#' @param sample_flag Identitas dari sampel yang dihasilkan.
#' @return Data yang telah diberi flag untuk sampel terpilih yang selanjutnya dapat diubah atributnya menggunakan fungsi \code{\link{mutate_sample}}.
#' @examples
#' # Membuat filter berbeda
#' filter_1 = create_filter(NAMA_PROV == "ACEH", KLASIFIKASI == 1)
#' filter_2 = create_filter(NAMA_PROV == "RIAU" | NAMA_PROV == "SUMATERA BARAT", KLASIFIKASI == 2)
#' imputation_sample(x = sakernas_dummy, filters = filter_1, weight_aggregate = 10000, weight_col = Weight_R, sample_flag = "aceh_1")
#' imputation_sample(x = sakernas_dummy, filters = filter_2, weight_aggregate = 5000, weight_col = Weight_R, sample_flag = "riau_sumbar_2")
#'
#' # Membandingkan hasil sampel dengan jumlah iterasi berbeda
#' my_filter = create_filter(NAMA_PROV == "SUMATERA BARAT", KLASIFIKASI == 2)
#' imputation_sample(x = sakernas_dummy, filters = my_filter, weight_aggregate = 73955, weight_col = Weight_R, iter = 1)
#' imputation_sample(x = sakernas_dummy, filters = my_filter, weight_aggregate = 73955, weight_col = Weight_R, iter = 100)
#' @export
imputation_sample <- function(x, filters, weight_aggregate, weight_col, iter = 1, sample_flag = "1") {
  weight_col <- dplyr::enquo(weight_col)

  if (!"temp_id" %in% colnames(x)) {
    x$temp_id <- 1:nrow(x)
  }

  if (!"flag" %in% colnames(x)) {
    x$flag <- NA # Create default column for flagging
  } else {
    all_flags = unique(x$flag)
    if (sample_flag %in% all_flags) {
      stop('Flag sudah ada untuk sampel lain, silakan buat flag baru dengan mengatur parameter flag (contoh: sample_flag = "aceh_desa_perempuan"')
    }
  }

  x_filtered <- x %>%
    dplyr::filter(!!!filters)

  if (weight_aggregate < x_filtered %>% select(!!weight_col) %>% min()) {
    stop("Total weight yang dimasukan terlalu kecil")
  }

  n_all <- nrow(x)
  n_filtered <- nrow(x_filtered)
  limit <- weight_aggregate
  candidates <- list()

  for (i in 1:iter) {
    x_iter <- x_filtered %>%
      dplyr::sample_frac() %>%
      select(!!weight_col, temp_id)

    left <- n_filtered
    groups <- list()
    j <- 1

    while (left > 0) {
      cums <- cumsum(x_iter[[1]]) # Weight column
      indexes <- cums <= limit
      last <- sum(indexes)

      group <- x_iter[[2]][indexes] # Temporary id column
      group_sum <- cums[last]

      if (last != 0) {
        x_iter <- x_iter[!indexes,]
        groups[[j]] <- list(member = group, n = length(group), sum = group_sum)
        j <- j + 1
      } else {
        x_iter <- x_iter[-1, ]
      }

      left <- nrow(x_iter)
    }

    groups_final = min(which(sapply(groups, "[[", "sum") == max(sapply(groups, "[[", "sum"))))
    candidates[[i]] <- groups[[groups_final]]
  }
  candidates_final = min(which(sapply(candidates, "[[", "sum") == max(sapply(candidates, "[[", "sum"))))

  modified <- FALSE
  x[x$temp_id %in% candidates[[candidates_final]]$member, "flag"] <- sample_flag
  x$temp_id <- NULL

  message(paste(n_filtered, "data berhasil difilter dari", n_all, "data yang ada"))
  message(paste(candidates[[candidates_final]]$n, " sampel terpilih dari ", iter, " iterasi dengan total weight: ",
                candidates[[candidates_final]]$sum, " (", round(candidates[[candidates_final]]$sum / weight_aggregate * 100, 4),
                "%)\n", sep = ""))
  message(paste("Sampel terpilih telah ditandai dengan flag: ", sample_flag, ". Silakan periksa kolom flag", sep = ""))
  return(x)
}