version 1.0.5

cran · Feb 20, 2024 · 446cdbf · 446cdbf
1 parent eb5b8a9
commit 446cdbf
Show file tree

Hide file tree

Showing 6 changed files with 157 additions and 32 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,6 +1,6 @@
 Package: samplingin
 Title: Dynamic Survey Sampling Solutions
-Version: 1.0.4
+Version: 1.0.5
 Authors@R: 
     person("Choerul", "Afifanto", , "choerulafifanto@gmail.com", role = c("aut", "cre", "cph"))
 Description: A robust solution employing both systematic and PPS
@@ -15,8 +15,8 @@ Encoding: UTF-8
 LazyData: true
 RoxygenNote: 7.2.1
 NeedsCompilation: no
-Packaged: 2023-12-14 07:49:13 UTC; User
+Packaged: 2024-02-19 16:05:44 UTC; User
 Author: Choerul Afifanto [aut, cre, cph]
 Maintainer: Choerul Afifanto <choerulafifanto@gmail.com>
 Repository: CRAN
-Date/Publication: 2023-12-15 09:50:05 UTC
+Date/Publication: 2024-02-19 19:20:06 UTC
diff --git a/MD5 b/MD5
@@ -1,15 +1,15 @@
-b642a9b991db0108043d4ec8de1d1f88 *DESCRIPTION
+1d7e54f9895fbf65a8d3c6bd1778c93e *DESCRIPTION
 0a0864f9583c81707387e99a5d9b6205 *LICENSE
 9ca8510dff33972e0aecd72870dcbf83 *NAMESPACE
-300e519dc792250a769166c65d01c2d6 *NEWS.md
+745b861bcbc170ae9fed1b10d511e260 *NEWS.md
 1dd792b86cbd22c58d3b414c76895b90 *R/data.R
-6c99f077dc69186674f3dadcd1eb9801 *R/global.R
-54facb885d610dc3982041a4506532a2 *R/samplingin.R
+7a8a3c3718c251075c9b13dd7edd7141 *R/global.R
+57f72597730faa3bc80f8f4bc239ae5f *R/samplingin.R
 b607675a460f815c9e9341f4b711f668 *README.md
 36b7c180d46df42cdcfd4bc6d3584568 *data/alokasi_dt.rda
 52dad9ede25dd9a0ece1aa7182a5f6d6 *data/pop_dt.rda
 eaf28cc3ddfb8a5b6cc7508cb0eca3e9 *man/alokasi_dt.Rd
-3896a631ed872eef612def668c26ff05 *man/doSampling.Rd
+5f7ed7ac6a873709b187d0d2f73f0d14 *man/doSampling.Rd
 8ffcac8f5702dde07851f3b46c92833a *man/get_allocation.Rd
 be582494882c81e41c2cfdf56b210984 *man/pop_dt.Rd
 10a69c815bc7997021d957f4e85fdb99 *man/round_preserve_sum.Rd
diff --git a/NEWS.md b/NEWS.md
@@ -1,15 +1,59 @@
+# samplingin 1.0.5
+
+Changes in version 1.0.5
+
+Bug fixes
+
+* Resolving the error in which population is smaller than allocated size in PPS sampling.
+
+* Incorporating messages for both negative and zero allocations and implementing an error message specifically for negative allocations.
+
+* Optimizing processing time by excluding zero allocations from the allocation data frame.
+
+* Adding predetermined random number parameter on doSampling function
+
 # samplingin 1.0.4
 
+Changes in version 1.0.4
+
+Bug fixes
+
+* Commented if(verbose) cat(lis[["ar"]],"\n")
+
 # samplingin 1.0.3
 
+Changes in version 1.0.3
+
+Bug fixes
+
+* Changed `Imports` on DESCRIPTION
+
 # samplingin 1.0.2
 
+Changes in version 1.0.2
+
+Bug fixes
+
+* Improved implicit stratification sorting
+
+* Changed Description in `flags` parameter
+
 # samplingin 1.0.1
 
-# samplingin 1.0.0
+Changes in version 1.0.1
 
-# samplingin 0.0.1
+Bug fixes
 
-# samplingin 0.0.0.9000
+* Removed "Package for" in title
+
+* Added full sentences in description text
+
+* Added references describing the methods
+
+* Unwrapped examples and replaced \dontrun with \donttest because elapsed time > 5 secs
+
+* Added `verbose` parameter in doSampling
+
+# samplingin 1.0.0
 
-* Added a `NEWS.md` file to track changes to the package.
+* This is a new release.
diff --git a/R/global.R b/R/global.R
@@ -8,5 +8,5 @@
 utils::globalVariables(
   c("VMIN", "VMAX", "INDEX","certainty","npop","flags","tanggal",
     "ncertainty","k","cert_now","nsam_tot","sisa","nsam","tmp_strata",
-    "alokasi_n","fsqrt","sfsqrt","alok0","alok","alok_p","n_primary","n_secondary")
+    "alokasi_n","fsqrt","sfsqrt","alok0","alok","alok_p","n_primary","n_secondary","jml")
 )
diff --git a/R/samplingin.R b/R/samplingin.R
@@ -230,6 +230,7 @@ createInterval = function(pop, method, strata, auxVar=NA, groupByVar=c("kdprov",
 #' @param method method of sampling : `"systematic"` (the default) or `"pps"`
 #' @param auxVar auxiliary variable for pps sampling (`method = "pps"`)
 #' @param seed seed
+#' @param predetermined_rn predetermined random number variable on allocation dataframe, the default value is NULL, random number will be generated randomly
 #' @param verbose verbose (`TRUE` as default)
 #'
 #' @return list of population data (`"pop"`), selected samples (`"dsampel"`), and details of sampling process (`"rincian"`)
@@ -238,6 +239,8 @@ createInterval = function(pop, method, strata, auxVar=NA, groupByVar=c("kdprov",
 #'
 #' \donttest{
 #' library(samplingin)
+#' library(magrittr)
+#' library(dplyr)
 #'
 #' # PPS Sampling
 #' dtSampling_pps = doSampling(
@@ -279,9 +282,33 @@ createInterval = function(pop, method, strata, auxVar=NA, groupByVar=c("kdprov",
 #'
 #' # Details of sampling process
 #' rincian = dtSampling_sys$rincian
+#'
+#' #' Systematic Sampling with predetermined random number (predetermined_ar parameter)
+#'
+#' alokasi_dt_rn = alokasi_dt %>% rowwise() %>% mutate(ar = runif(n(),0,1))
+#'
+#' dtSampling_sys = doSampling(
+#'    pop = pop_dt
+#'    , alloc = alokasi_dt_rn
+#'    , nsampel = "n_primary"
+#'    , type = "U"
+#'    , ident = c("kdprov")
+#'    , method = "systematic"
+#'    , predetermined_rn = "ar"
+#'    , seed = 4321
+#' )
+#'
+#' # Population data with flag sample
+#' pop_dt = dtSampling_sys$pop
+#'
+#' # Selected Samples
+#' dsampel = dtSampling_sys$dsampel
+#'
+#' # Details of sampling process
+#' rincian = dtSampling_sys$rincian
 #' }
 doSampling = function(pop, alloc, nsampel, type, strata=NULL, ident=c("kdprov","kdkab"), implicitby = NULL, method="systematic",
-                      auxVar=NA, seed=1, verbose = TRUE){
+                      auxVar=NA, seed=1, predetermined_rn = NULL, verbose = TRUE){
   # Warning apabila syarat tidak terpenuhi
   if( length(method)==0 | length(method)>1 | !(method %in% c("systematic", "pps"))){
     stop("Please select one method. systematic or pps")
@@ -310,18 +337,18 @@ doSampling = function(pop, alloc, nsampel, type, strata=NULL, ident=c("kdprov","
     sortVar = c(ident, strata, implicitby)
     if(verbose){
       if(!null_strata){
-        message("sort by: ",ident,", ",strata," and ",implicitby,"\n")
+        message("sort by: ",paste(ident, collapse = ", "),", ",paste(strata, collapse = ", ")," and ",paste(implicitby, collapse = ", "),"\n")
       }else{
-        message("sort by: ",ident," and ",implicitby,"\n")
+        message("sort by: ",paste(ident, collapse = ", ")," and ",paste(implicitby, collapse = ", "),"\n")
       }
     }
   }else{
     sortVar = c(ident, strata)
     if(verbose){
       if(!null_strata){
-        message("no implicit stratification variable chosen, sort by: ",ident," and ",strata,"\n")
+        message("no implicit stratification variable chosen, sort by: ",paste(ident, collapse = ", ")," and ",paste(strata, collapse = ", "),"\n")
       }else{
-        message("no implicit stratification variable chosen, sort by: ",ident,"\n")
+        message("no implicit stratification variable chosen, sort by: ",paste(ident, collapse = ", "),"\n")
       }
     }
   }
@@ -347,14 +374,40 @@ doSampling = function(pop, alloc, nsampel, type, strata=NULL, ident=c("kdprov","
 
   # flagS = match("FLAGS", colnames(pop))
 
+  # filter out null allocation
+
+  alokasi_minus = alloc %>%
+    filter(eval(parse(text = nsampel)) < 0)
+
+  alokasi_nol = alloc %>%
+    filter(eval(parse(text = nsampel)) == 0)
+
+  if(verbose){
+    message("Negative allocation: ",nrow(alokasi_minus),"\n")
+
+    if(nrow(alokasi_minus)>0){
+      stop("Allocation cannot be negative")
+    }
+
+    message("Zero allocation: ",nrow(alokasi_nol),"\n")
+
+    if(nrow(alokasi_nol)>0){
+      message("Removing Zero allocation\n")
+    }
+  }
+
+  alloc = alloc %>%
+    filter(eval(parse(text = nsampel)) > 0)
+
   switch (method,
           "systematic" = {
             pop = createInterval(pop, method, strata, groupByVar = groupByVar)
 
             # Rekap populasi berdasarkan group
             mRek = pop %>%
               group_by(.dots = groupByVar) %>%
-              summarise(npop = n())
+              summarise(npop = n()) %>%
+              ungroup()
 
             # Membuat rincian penarikan sampel seperti
             # alokasi sampel per group,
@@ -364,8 +417,9 @@ doSampling = function(pop, alloc, nsampel, type, strata=NULL, ident=c("kdprov","
             set.seed(seed)
 
             rincian = left_join(alloc, mRek, by=groupByVar) %>%
+              mutate_at(c("npop"), ~replace(., is.na(.), 0)) %>%
               mutate(
-                ar = runif(n(),0,1),
+                ar = ifelse(is.null(predetermined_rn), runif(n(),0,1), eval(parse(text = predetermined_rn))),
                 npop=ifelse(!is.na(npop),npop,0),
                 k = npop/eval(parse(text = nsampel)),
                 sisa=9999) %>%
@@ -478,7 +532,8 @@ doSampling = function(pop, alloc, nsampel, type, strata=NULL, ident=c("kdprov","
             # Membuat rekap hasil penarikan sampel
             rek = dsampel %>%
               group_by(.dots = groupByVar) %>%
-              summarise(jml=n())
+              summarise(jml=n()) %>%
+              ungroup()
 
             # Join rincian dengan hasil penarikan sampel
             rincian = left_join(rincian, rek) %>%
@@ -540,9 +595,10 @@ doSampling = function(pop, alloc, nsampel, type, strata=NULL, ident=c("kdprov","
               # seed digunakan untuk menetapkan angka random
               set.seed(seed)
               rincian = left_join(alloc, mRek, by=groupByVar) %>%
+                mutate_at(c("npop","numobs","ncertainty"), ~replace(., is.na(.), 0)) %>%
                 mutate(
-                  ar = runif(n(),0,1),
-                  k  = npop/eval(parse(text = nsampel)),
+                  ar = ifelse(is.null(predetermined_rn), runif(n(),0,1), eval(parse(text = predetermined_rn))),
+                  k  = ifelse(npop>0, npop/eval(parse(text = nsampel)), NA),
                   sisa=9999,
                   nsam = eval(parse(text = nsampel)) - ncertainty
                 )
@@ -591,13 +647,6 @@ doSampling = function(pop, alloc, nsampel, type, strata=NULL, ident=c("kdprov","
               }
             }
 
-            rincian = rincian %>%
-              mutate(
-                sisa = ifelse(is.na(nsam), nsam_tot, sisa)
-                , nsam = ifelse(is.na(nsam), nsam_tot, nsam)
-              ) %>%
-              mutate_at(c("npop"), ~replace(., is.na(.), 0))
-
             # Proses penarikan sampel per rincian alokasi
             for(i in 1:nrow(rincian)){
               if(rincian[i,nsampel] == 0) next
@@ -731,10 +780,13 @@ doSampling = function(pop, alloc, nsampel, type, strata=NULL, ident=c("kdprov","
             # Membuat rekap hasil penarikan sampel
             rek = dsampel %>%
               group_by(.dots = groupByVar) %>%
-              summarise(jml=n())
+              summarise(jml=n()) %>%
+              ungroup()
 
-            # Join rincian dengan hasil penarikan sampel
+            # Join rincian dengan hasil penarikan sampel dan update variabel sisa
             rincian = left_join(rincian, rek) %>%
+              mutate_at(c("jml"), ~replace(., is.na(.), 0)) %>%
+              mutate(sisa = eval(parse(text = nsampel)) - jml) %>%
               as.data.frame()
 
             pop = pop %>%

diff --git a/man/doSampling.Rd b/man/doSampling.Rd