Address NULLable accessors

Ironholds · Sep 13, 2017 · 98daa6d · 98daa6d
1 parent c5e6c3b
commit 98daa6d
Show file tree

Hide file tree

Showing 10 changed files with 140 additions and 27 deletions.
diff --git a/R/RcppExports.R b/R/RcppExports.R
@@ -243,6 +243,10 @@ set_component_ <- function(urls, component, new_value) {
     .Call(`_urltools_set_component_`, urls, component, new_value)
 }
 
+rm_component_ <- function(urls, component) {
+    .Call(`_urltools_rm_component_`, urls, component)
+}
+
 #'@title Encode or Decode Internationalised Domains
 #'@description \code{puny_encode} and \code{puny_decode} implement
 #'the encoding standard for internationalised (non-ASCII) domains and

diff --git a/R/accessors.R b/R/accessors.R
@@ -32,6 +32,9 @@ scheme <- function(x){
 #'@rdname scheme
 #'@export
 setGeneric("scheme<-", useAsDefault = function(x, value){
+  if(is.null(value)){
+    return(rm_component_(x, 0))
+  }
   return(set_component_(x, 0, value))
 })
 
@@ -64,6 +67,9 @@ domain <- function(x){
 #'@rdname domain
 #'@export
 setGeneric("domain<-", useAsDefault = function(x, value){
+  if(is.null(value)){
+    return(rm_component_(x, 1))
+  }
   return(set_component_(x, 1, value))
 })
 
@@ -77,18 +83,22 @@ setGeneric("domain<-", useAsDefault = function(x, value){
 #'
 #'@param x a URL, or vector of URLs
 #'
-#'@param value a replacement value for x's port.
+#'@param value a replacement value for x's port. If NULL, the port
+#'will be entirely removed.
 #'
 #'@seealso \code{\link{scheme}}, \code{\link{domain}}, \code{\link{path}},
 #'\code{\link{parameters}} and \code{\link{fragment}} for other accessors.
 #'
 #'@examples
-#'#Get a component
+#'# Get the port
 #'example_url <- "http://cran.r-project.org:80/submit.html"
 #'port(example_url)
 #'
-#'#Set a component
+#'# Set the port
 #'port(example_url) <- "12"
+#'
+#'# Remove the port
+#'port(example_url) <- NULL
 #'@export
 port <- function(x){
   return(get_component_(x,2))
@@ -97,6 +107,9 @@ port <- function(x){
 #'@rdname port
 #'@export
 setGeneric("port<-", useAsDefault = function(x, value){
+  if(is.null(value)){
+    return(rm_component_(x, 2))
+  }
   return(set_component_(x, 2, value))
 })
 
@@ -109,18 +122,22 @@ setGeneric("port<-", useAsDefault = function(x, value){
 #'
 #'@param x a URL, or vector of URLs
 #'
-#'@param value a replacement value for x's path
+#'@param value a replacement value for x's path. If NULL, the path
+#'will be removed entirely.
 #'
 #'@seealso \code{\link{scheme}}, \code{\link{domain}}, \code{\link{port}},
 #'\code{\link{parameters}} and \code{\link{fragment}} for other accessors.
 #'
 #'@examples
-#'#Get a component
+#'# Get the path
 #'example_url <- "http://cran.r-project.org:80/submit.html"
 #'path(example_url)
 #'
-#'#Set a component
+#'# Set the path
 #'path(example_url) <- "bin/windows/"
+#'
+#'# Remove the path
+#'path(example_url) <- NULL
 #'@export
 path <- function(x){
   return(get_component_(x,3))
@@ -129,6 +146,9 @@ path <- function(x){
 #'@rdname path
 #'@export
 setGeneric("path<-", useAsDefault = function(x, value){
+  if(is.null(value)){
+    return(rm_component_(x, 3))
+  }
   return(set_component_(x, 3, value))
 })
 
@@ -142,19 +162,22 @@ setGeneric("path<-", useAsDefault = function(x, value){
 #'
 #'@param x a URL, or vector of URLs
 #'
-#'@param value a replacement value for x's parameters.
+#'@param value a replacement value for x's parameters. If NULL, the
+#'parameters will be removed entirely.
 #'
 #'@seealso \code{\link{scheme}}, \code{\link{domain}}, \code{\link{port}},
 #'\code{\link{path}} and \code{\link{fragment}} for other accessors.
 #'
 #'@examples
-#'#Get a component
+#'# Get the parameters
 #'example_url <- "http://en.wikipedia.org/wiki/Aaron_Halfaker?debug=true"
 #'parameters(example_url)
-#'#[1] "debug=true"
 #'
-#'#Set a component
+#'# Set the parameters
 #'parameters(example_url) <- "debug=false"
+#'
+#'# Remove the parameters
+#'parameters(example_url) <- NULL
 #'@export
 parameters <- function(x){
   return(get_component_(x,4))
@@ -163,6 +186,9 @@ parameters <- function(x){
 #'@rdname parameters
 #'@export
 setGeneric("parameters<-", useAsDefault = function(x, value){
+  if(is.null(value)){
+    return(rm_component_(x, 4))
+  }
   return(set_component_(x, 4, value))
 })
 
@@ -175,7 +201,8 @@ setGeneric("parameters<-", useAsDefault = function(x, value){
 #'
 #'@param x a URL, or vector of URLs
 #'
-#'@param value a replacement value for x's fragment.
+#'@param value a replacement value for x's fragment. If NULL, the
+#'fragment will be removed entirely.
 #'
 #'@seealso \code{\link{scheme}}, \code{\link{domain}}, \code{\link{port}},
 #'\code{\link{path}} and \code{\link{parameters}} for other accessors.
@@ -187,6 +214,9 @@ setGeneric("parameters<-", useAsDefault = function(x, value){
 #'
 #'#Set a component
 #'fragment(example_url) <- "production"
+#'
+#'#Remove a component
+#'fragment(example_url) <- NULL
 #'@export
 #'@rdname fragment
 #'@export
@@ -198,5 +228,8 @@ fragment <- function(x){
 #'@rdname fragment
 #'@export
 setGeneric("fragment<-", useAsDefault = function(x, value){
+  if(is.null(value)){
+    return(rm_component_(x, 5))
+  }
   return(set_component_(x, 5, value))
 })
diff --git a/man/fragment.Rd b/man/fragment.Rd
diff --git a/man/parameters.Rd b/man/parameters.Rd
diff --git a/man/path.Rd b/man/path.Rd
diff --git a/man/port.Rd b/man/port.Rd
diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp
@@ -133,6 +133,18 @@ BEGIN_RCPP
     return rcpp_result_gen;
 END_RCPP
 }
+// rm_component_
+CharacterVector rm_component_(CharacterVector urls, int component);
+RcppExport SEXP _urltools_rm_component_(SEXP urlsSEXP, SEXP componentSEXP) {
+BEGIN_RCPP
+    Rcpp::RObject rcpp_result_gen;
+    Rcpp::RNGScope rcpp_rngScope_gen;
+    Rcpp::traits::input_parameter< CharacterVector >::type urls(urlsSEXP);
+    Rcpp::traits::input_parameter< int >::type component(componentSEXP);
+    rcpp_result_gen = Rcpp::wrap(rm_component_(urls, component));
+    return rcpp_result_gen;
+END_RCPP
+}
 // puny_encode
 CharacterVector puny_encode(CharacterVector x);
 RcppExport SEXP _urltools_puny_encode(SEXP xSEXP) {
@@ -215,6 +227,7 @@ static const R_CallMethodDef CallEntries[] = {
     {"_urltools_url_parse", (DL_FUNC) &_urltools_url_parse, 1},
     {"_urltools_get_component_", (DL_FUNC) &_urltools_get_component_, 2},
     {"_urltools_set_component_", (DL_FUNC) &_urltools_set_component_, 3},
+    {"_urltools_rm_component_", (DL_FUNC) &_urltools_rm_component_, 2},
     {"_urltools_puny_encode", (DL_FUNC) &_urltools_puny_encode, 1},
     {"_urltools_puny_decode", (DL_FUNC) &_urltools_puny_decode, 1},
     {"_urltools_reverse_strings", (DL_FUNC) &_urltools_reverse_strings, 1},

diff --git a/src/parsing.cpp b/src/parsing.cpp
@@ -174,9 +174,10 @@ String parsing::get_component(std::string url, int component){
 }
 
 //Component modification
-String parsing::set_component(std::string url, int component, String new_value){
+String parsing::set_component(std::string url, int component, String new_value,
+                              bool rm){
 
-  if(new_value == NA_STRING){
+  if(new_value == NA_STRING && !rm){
     return NA_STRING;
   }
   std::string output;
@@ -324,7 +325,25 @@ CharacterVector set_component_(CharacterVector urls, int component,
       Rcpp::checkUserInterrupt();
     }
 
-    output[i] = parsing::set_component(Rcpp::as<std::string>(urls[i]), component, new_value);
+    output[i] = parsing::set_component(Rcpp::as<std::string>(urls[i]), component, new_value, false);
+  }
+  return output;
+}
+
+//[[Rcpp::export]]
+CharacterVector rm_component_(CharacterVector urls, int component){
+
+  if(component < 2){
+    Rcpp::stop("Scheme and domain are required components");
+  }
+  unsigned int input_size = urls.size();
+  CharacterVector output(input_size);
+  for (unsigned int i = 0; i < input_size; ++i){
+    if((i % 10000) == 0){
+      Rcpp::checkUserInterrupt();
+    }
+
+    output[i] = parsing::set_component(Rcpp::as<std::string>(urls[i]), component, NA_STRING, true);
   }
   return output;
 }
diff --git a/src/parsing.h b/src/parsing.h
@@ -114,12 +114,15 @@ namespace parsing {
    * 
    * @param new_value the value to insert into url[component].
    * 
-   * @param delim a delimiter, used in cases where there's no existing value.
+   * @param rm whether the intent is to remove the component
+   * (in which case new_value must be an NA_STRING)
+   * 
    * @see get_component, which allows for retrieval.
    * 
    * @return a string consisting of the modified URL.
    */
-  String set_component(std::string url, int component, String new_value);
+  String set_component(std::string url, int component, String new_value,
+                       bool rm);
 
   /**
    * Decompose a vector of URLs and turn it into a data.frame.

diff --git a/tests/testthat/test_get_set.R b/tests/testthat/test_get_set.R
@@ -57,3 +57,29 @@ test_that("Assigning NA with get will NA a URL", {
   port(url) <- NA_character_
   testthat::expect_true(is.na(url))
 })
+
+test_that("Removing components with a NULL works", {
+  url <- "https://www.google.com:80/foo.php?api_params=turnip#ending"
+  fragment(url) <- NULL
+  testthat::expect_equal(url,
+                         "https://www.google.com:80/foo.php?api_params=turnip")
+  parameters(url) <- NULL
+  testthat::expect_equal(url,
+                         "https://www.google.com:80/foo.php")
+  path(url) <- NULL
+  testthat::expect_equal(url,
+                         "https://www.google.com:80")
+  port(url) <- NULL
+  testthat::expect_equal(url, "https://www.google.com")
+})
+
+test_that("Removing non-removable components throws an error", {
+
+  url <- "https://en.wikipedia.org/foo.php"
+  testthat::expect_error({
+    scheme(url) <- NULL
+  })
+  testthat::expect_error({
+    domain(url) <- NULL
+  })
+})