Merge branch 'dev'

Author: Andreas Blätte

DESCRIPTION

@@ -1,8 +1,8 @@
 Package: RcppCWB
 Type: Package
 Title: 'Rcpp' Bindings for the 'Corpus Workbench' ('CWB')
-Version: 0.5.2
-Date: 2022-03-28
+Version: 0.5.3
+Date: 2022-05-17
 Author: Andreas Blaette [aut, cre],
   Bernard Desgraupes [aut],
   Sylvain Loiseau [aut],

NEWS.md

@@ -1,3 +1,22 @@
+# RcppCWB 0.5.2.9001ff
+
+* Fixed a bug in the `region_matrix_corpus()` C++ code that would not show any
+context at all if s_attribute expansion transgressed start or end of corpus.
+* Fixed a bug in the `region_matrix_corpus()` C++ code that would result from 
+not considering that query matches may go cover more than one strucs of a 
+structural attribute.
+* `corpus_info_file()` does not crash if INFO is not defined in the registry
+file (#62).
+* Implicit processing of arguments `sAttribute` and `pAttribute` as `s_attribute`
+or `p_attribute` respectively is now accompanied by a warning that arguments 
+are deprectated.
+* The `check_corpus()` function distinguishes between whether a corpus is loaded
+in the CL and/or CQP context.
+* `cwb_huffcode()` and `cwb_compress_rdx()` have argument `delete` to trigger
+deleting redundant files after compression (#60).
+* `cqp_load_corpus` will internally upper corpus ID as required in the CQP
+context (#64).
+
 # RcppCWB 0.5.2
 
 * The example for `corpus_data_dir()` dir not work as intended without

R/checks.R

@@ -32,37 +32,42 @@ check_registry <- function(registry){
 #' @rdname checks
 #' @export check_corpus
 #' @importFrom fs path
-check_corpus <- function(corpus, registry){
+#' @param cl A `logical` value, whether CL availability of corpus is required
+#'   for positive result.
+#' @param cqp A `logical` value, whether CQP availability of corpus is required
+#'   for positive result.
+check_corpus <- function(corpus, registry, cl = TRUE, cqp = TRUE){
 
-  registry <- fs::path(registry)
-  
-  if (length(corpus) != 1L)
-    stop("corpus needs to be a vector of length 1")
-  
-  if (!is.character(corpus))
-    stop("corpus needs to be a character vector")
+  if (length(corpus) != 1L) stop("corpus needs to be a vector of length 1")
+  if (!is.character(corpus)) stop("corpus needs to be a character vector")
 
+  registry <- fs::path(registry)
   if (isFALSE(dir.exists(registry)))
     stop(sprintf("Registry directory '%s' does not exist.", registry))
 
-  if (isFALSE(cqp_is_initialized())) cqp_initialize(registry = registry)
+  if (cl){
+    if (!tolower(corpus) %in% cl_list_corpora()){
+      cl_load_corpus(corpus = corpus, registry = registry)
+    }
+    cl_availability <- corpus_is_loaded(corpus = corpus, registry = registry)
+  }
 
-  if (!tolower(corpus) %in% cl_list_corpora()){
-    
-    success_cl <- cl_load_corpus(corpus = corpus, registry = registry)
-    if (isFALSE(success_cl))
-      warning(sprintf("corpus '%s' is not loaded and cannot be loaded", corpus))
-    
-    success_cqp <- cqp_load_corpus(corpus = toupper(corpus), registry = registry)
-    if (isFALSE(success_cqp))
-      warning(sprintf("corpus '%s' is not loaded and cannot be loaded", corpus))
-    
+  if (cqp){
+    if (isFALSE(cqp_is_initialized())) cqp_initialize(registry = registry)
+    if (!toupper(corpus) %in% cqp_list_corpora()){
+      cqp_load_corpus(corpus = toupper(corpus), registry = registry)
+    }
+    cqp_availability <- as.logical(
+      .check_corpus(corpus = toupper(corpus))
+    )
   }
-
-  if (.check_corpus(toupper(corpus)) == 0L)
-    stop(sprintf("corpus %s is not available (check whether there is a typo)", sQuote(corpus)))
 
-  return( TRUE )
+  if (!any(cl, cqp)) return(TRUE)
+  if (all(cl, cqp)) return(all(cqp_availability, cl_availability))
+  if (cl && !cqp) return(cl_availability)
+  if (!cl && cqp) return(cqp_availability)
+
+  return(FALSE)
 }
 
 #' @export check_s_attribute

R/cl.R

@@ -139,7 +139,7 @@ cl_lexicon_size <- function(corpus, p_attribute, registry = Sys.getenv("CORPUS_R
 #' fulltext <- paste(txt, collapse = " ")
 cl_cpos2struc <- function(corpus, s_attribute, cpos, registry = Sys.getenv("CORPUS_REGISTRY")){
   check_registry(registry)
-  check_corpus(corpus, registry)
+  check_corpus(corpus, registry, cqp = FALSE)
   check_s_attribute(corpus = corpus, registry = registry, s_attribute = s_attribute)
 
   if (length(cpos) == 0L) return(integer())
@@ -151,7 +151,7 @@ cl_cpos2struc <- function(corpus, s_attribute, cpos, registry = Sys.getenv("CORP
 #' @rdname s_attributes
 cl_struc2cpos <- function(corpus, s_attribute, registry = Sys.getenv("CORPUS_REGISTRY"), struc){
   check_registry(registry)
-  check_corpus(corpus, registry)
+  check_corpus(corpus, registry, cqp = FALSE)
   check_s_attribute(corpus = corpus, registry = registry, s_attribute = s_attribute)
   check_strucs(corpus = corpus, s_attribute = s_attribute, strucs = struc, registry = registry)
   .cl_struc2cpos(corpus = corpus, s_attribute = s_attribute, registry = registry, struc = struc)
@@ -160,7 +160,7 @@ cl_struc2cpos <- function(corpus, s_attribute, registry = Sys.getenv("CORPUS_REG
 #' @rdname s_attributes
 cl_struc2str <- function(corpus, s_attribute, struc, registry = Sys.getenv("CORPUS_REGISTRY")){
   check_registry(registry)
-  check_corpus(corpus, registry)
+  check_corpus(corpus, registry, cqp = FALSE)
   check_s_attribute(corpus = corpus, registry = registry, s_attribute = s_attribute)
   check_strucs(corpus = corpus, s_attribute = s_attribute, strucs = struc, registry = registry)
   .cl_struc2str(corpus = corpus, s_attribute = s_attribute, struc = struc, registry = registry)
@@ -169,7 +169,7 @@ cl_struc2str <- function(corpus, s_attribute, struc, registry = Sys.getenv("CORP
 #' @rdname s_attributes
 cl_cpos2lbound <- function(corpus, s_attribute, cpos, registry = Sys.getenv("CORPUS_REGISTRY")){
   check_registry(registry)
-  check_corpus(corpus, registry)
+  check_corpus(corpus, registry, cqp = FALSE)
   check_s_attribute(corpus = corpus, registry = registry, s_attribute = s_attribute)
 
   if (length(cpos) == 0L) return(integer())
@@ -181,7 +181,7 @@ cl_cpos2lbound <- function(corpus, s_attribute, cpos, registry = Sys.getenv("COR
 #' @rdname s_attributes
 cl_cpos2rbound <- function(corpus, s_attribute, cpos, registry = Sys.getenv("CORPUS_REGISTRY")){
   check_registry(registry)
-  check_corpus(corpus, registry)
+  check_corpus(corpus, registry, cqp = FALSE)
   check_s_attribute(corpus = corpus, registry = registry, s_attribute = s_attribute)
 
   check_cpos(corpus = corpus, p_attribute = "word", cpos = cpos, registry = registry)
@@ -267,45 +267,45 @@ cl_cpos2rbound <- function(corpus, s_attribute, cpos, registry = Sys.getenv("COR
 #' 
 cl_cpos2str <- function(corpus, p_attribute, registry = Sys.getenv("CORPUS_REGISTRY"), cpos){
   check_registry(registry)
-  check_corpus(corpus, registry)
+  check_corpus(corpus, registry, cqp = FALSE)
   if (length(cpos) == 0L) return(integer())
   .cl_cpos2str(corpus = corpus, p_attribute = p_attribute, registry = registry, cpos = cpos)
 }
 
 #' @rdname p_attributes
 cl_cpos2id <- function(corpus, p_attribute, registry = Sys.getenv("CORPUS_REGISTRY"), cpos){
   check_registry(registry)
-  check_corpus(corpus, registry)
+  check_corpus(corpus, registry, cqp = FALSE)
   if (length(cpos) == 0L) return(integer())
   .cl_cpos2id(corpus = corpus, p_attribute = p_attribute, registry = registry, cpos = cpos)
 }
 
 #' @rdname p_attributes
 cl_id2str <- function(corpus, p_attribute, registry = Sys.getenv("CORPUS_REGISTRY"), id){
   check_registry(registry)
-  check_corpus(corpus, registry)
+  check_corpus(corpus, registry, cqp = FALSE)
   check_id(corpus = corpus, p_attribute = p_attribute, id = id, registry = registry)
   .cl_id2str(corpus = corpus, p_attribute = p_attribute, registry = registry, id = id)
 }
 
 #' @rdname p_attributes
 cl_regex2id <- function(corpus, p_attribute, regex, registry = Sys.getenv("CORPUS_REGISTRY")){
   check_registry(registry)
-  check_corpus(corpus, registry)
+  check_corpus(corpus, registry, cqp = FALSE)
   .cl_regex2id(corpus = corpus, p_attribute = p_attribute, regex = regex, registry = registry)
 }
 
 #' @rdname p_attributes
 cl_str2id <- function(corpus, p_attribute, str, registry = Sys.getenv("CORPUS_REGISTRY")){
   check_registry(registry)
-  check_corpus(corpus, registry)
+  check_corpus(corpus, registry, cqp = FALSE)
   .cl_str2id(corpus = corpus, p_attribute = p_attribute, str = str, registry = registry)
 }
 
 #' @rdname p_attributes
 cl_id2freq <- function(corpus, p_attribute, id, registry = Sys.getenv("CORPUS_REGISTRY")){
   check_registry(registry)
-  check_corpus(corpus, registry)
+  check_corpus(corpus, registry, cqp = FALSE)
   check_p_attribute(p_attribute = p_attribute, corpus = corpus, registry = registry)
   check_id(corpus = corpus, p_attribute = p_attribute, id = id, registry = registry)
   .cl_id2freq(corpus = corpus, p_attribute = p_attribute, id = id, registry = registry)
@@ -315,7 +315,7 @@ cl_id2freq <- function(corpus, p_attribute, id, registry = Sys.getenv("CORPUS_RE
 #' @rdname p_attributes
 cl_id2cpos <- function(corpus, p_attribute, id, registry = Sys.getenv("CORPUS_REGISTRY")){
   check_registry(registry)
-  check_corpus(corpus, registry)
+  check_corpus(corpus, registry, cqp = FALSE)
   check_p_attribute(p_attribute = p_attribute, corpus = corpus, registry = registry)
   check_id(corpus = corpus, p_attribute = p_attribute, id = id, registry = registry)
   .cl_id2cpos(corpus = corpus, p_attribute = p_attribute, id = id, registry = registry)
@@ -394,7 +394,7 @@ cl_charset_name <- function(corpus, registry = Sys.getenv("CORPUS_REGISTRY")){
 #' cl_struc_values("REUTERS", "places") # TRUE - attribute has values
 #' cl_struc_values("REUTERS", "date") # NA - attribute does not exist
 cl_struc_values <- function(corpus, s_attribute, registry = Sys.getenv("CORPUS_REGISTRY")){
-  check_corpus(corpus = corpus, registry = registry)
+  check_corpus(corpus = corpus, registry = registry, cqp = FALSE)
   registry <- normalizePath(path.expand(registry))
   i <- .cl_struc_values(corpus = corpus, s_attribute = s_attribute, registry = registry)
   if (i == 1L) TRUE else if (i == 0L) FALSE else if (i < 0L) as.integer(NA)
@@ -414,19 +414,20 @@ cl_struc_values <- function(corpus, s_attribute, registry = Sys.getenv("CORPUS_R
 #' @examples
 #' corpus_data_dir("REUTERS", registry = get_tmp_registry())
 corpus_data_dir <- function(corpus, registry = Sys.getenv("CORPUS_REGISTRY")){
-  check_corpus(corpus = corpus, registry = registry)
+  check_corpus(corpus = corpus, registry = registry, cqp = FALSE)
   registry <- path(path_expand(registry))
   dir <- .corpus_data_dir(corpus = corpus, registry = registry)
   path(dir)
 }
 
 #' @details `corpus_info_file()` will return the path to the info file for a
-#'   corpus (class `fs_path` object).
+#'   corpus (class `fs_path` object). If info file does not exist or INFO line
+#'   is missing in the registry file, `NA` is returned.
 #' @rdname registry_info
 #' @examples
 #' corpus_info_file("REUTERS", registry = get_tmp_registry())
 corpus_info_file <- function(corpus, registry = Sys.getenv("CORPUS_REGISTRY")){
-  check_corpus(corpus = corpus, registry = registry)
+  check_corpus(corpus = corpus, registry = registry, cqp = FALSE)
   registry <- path(path_expand(registry))
   fname <- .corpus_info_file(corpus = corpus, registry = registry)
   path(fname)
@@ -438,7 +439,7 @@ corpus_info_file <- function(corpus, registry = Sys.getenv("CORPUS_REGISTRY")){
 #' @examples
 #' corpus_full_name("REUTERS", registry = get_tmp_registry())
 corpus_full_name <- function(corpus, registry = Sys.getenv("CORPUS_REGISTRY")){
-  check_corpus(corpus = corpus, registry = registry)
+  check_corpus(corpus = corpus, registry = registry, cqp = FALSE)
   registry <- path(path_expand(registry))
   .corpus_full_name(corpus = corpus, registry = registry)
 }
@@ -449,7 +450,7 @@ corpus_full_name <- function(corpus, registry = Sys.getenv("CORPUS_REGISTRY")){
 #' @examples
 #' corpus_p_attributes("REUTERS", registry = get_tmp_registry())
 corpus_p_attributes <- function(corpus, registry = Sys.getenv("CORPUS_REGISTRY")){
-  check_corpus(corpus = corpus, registry = registry)
+  check_corpus(corpus = corpus, registry = registry, cqp = FALSE)
   registry <- path(path_expand(registry))
   .corpus_p_attributes(corpus = corpus, registry = registry)
 }
@@ -460,7 +461,7 @@ corpus_p_attributes <- function(corpus, registry = Sys.getenv("CORPUS_REGISTRY")
 #' @examples
 #' corpus_s_attributes("REUTERS", registry = get_tmp_registry())
 corpus_s_attributes <- function(corpus, registry = Sys.getenv("CORPUS_REGISTRY")){
-  check_corpus(corpus = corpus, registry = registry)
+  check_corpus(corpus = corpus, registry = registry, cqp = FALSE)
   registry <- path(path_expand(registry))
   .corpus_s_attributes(corpus = corpus, registry = registry)
 }
@@ -471,7 +472,7 @@ corpus_s_attributes <- function(corpus, registry = Sys.getenv("CORPUS_REGISTRY")
 #' @examples
 #' corpus_properties("REUTERS", registry = get_tmp_registry())
 corpus_properties <- function(corpus, registry = Sys.getenv("CORPUS_REGISTRY")){
-  check_corpus(corpus = corpus, registry = registry)
+  check_corpus(corpus = corpus, registry = registry, cqp = FALSE)
   registry <- path(path_expand(registry))
   .corpus_properties(corpus = corpus, registry = registry)
 }
@@ -492,7 +493,7 @@ corpus_property <- function(corpus, registry = Sys.getenv("CORPUS_REGISTRY"), pr
     length(property) == 1L,
     is.character(property)
   )
-  check_corpus(corpus = corpus, registry = registry)
+  check_corpus(corpus = corpus, registry = registry, cqp = FALSE)
   registry <- path(path_expand(registry))
   .corpus_property(corpus = corpus, registry = registry, property = property)
 }

R/cqp.R

@@ -212,5 +212,5 @@ matrix_to_subcorpus <- function(region_matrix, corpus, subcorpus){
 #' @export cqp_load_corpus
 #' @rdname cqp_initialize
 cqp_load_corpus <- function(corpus, registry){
-  as.logical(.cqp_load_corpus(corpus = corpus, registry = registry))
+  as.logical(.cqp_load_corpus(corpus = toupper(corpus), registry = registry))
 }

R/cwb.R

@@ -93,7 +93,9 @@ cwb_makeall <- function(corpus, p_attribute, registry = Sys.getenv("CORPUS_REGIS
 
 #' @rdname cwb_utils
 #' @export cwb_huffcode
-cwb_huffcode <- function(corpus, p_attribute, registry = Sys.getenv("CORPUS_REGISTRY"), quietly = FALSE){
+#' @param delete A `logical` value, whether to remove redundant files after
+#'   compression.
+cwb_huffcode <- function(corpus, p_attribute, registry = Sys.getenv("CORPUS_REGISTRY"), quietly = FALSE, delete = TRUE){
   huffcode <- function()
     .cwb_huffcode(x = corpus, p_attribute = p_attribute, registry_dir = registry)
 
@@ -102,6 +104,15 @@ cwb_huffcode <- function(corpus, p_attribute, registry = Sys.getenv("CORPUS_REGI
   } else {
     success <- huffcode()
   }
+  
+  if (delete){
+    data_dir <- corpus_data_dir(corpus = corpus, registry = registry)
+    fname <- path(data_dir, sprintf("%s.corpus", p_attribute))
+    if (!file.exists(fname)) warning("cwb_huffcode: file to delete missing")
+    removed <- file.remove(fname)
+    if (removed) if (!quietly) message("redundant file deleted: ", fname)
+  }
+  
   success
 
 }
@@ -114,7 +125,7 @@ cwb_huffcode <- function(corpus, p_attribute, registry = Sys.getenv("CORPUS_REGI
 #'   p_attribute = "word",
 #'   registry = get_tmp_registry()
 #' )
-cwb_compress_rdx <- function(corpus, p_attribute, registry = Sys.getenv("CORPUS_REGISTRY"), quietly = FALSE){
+cwb_compress_rdx <- function(corpus, p_attribute, registry = Sys.getenv("CORPUS_REGISTRY"), quietly = FALSE, delete = TRUE){
   compress_rdx <-function()
     .cwb_compress_rdx(x = corpus, p_attribute = p_attribute, registry_dir = registry)
 
@@ -123,6 +134,21 @@ cwb_compress_rdx <- function(corpus, p_attribute, registry = Sys.getenv("CORPUS_
   } else {
     success <- compress_rdx()
   }
+  
+  if (delete){
+    data_dir <- corpus_data_dir(corpus = corpus, registry = registry)
+    
+    rev_file <- path(data_dir, sprintf("%s.corpus.rev", p_attribute))
+    if (!file.exists(rev_file)) warning("cwb_huffcode: file to delete missing")
+    removed <- file.remove(rev_file)
+    if (removed) if (!quietly) message("redundant file deleted: ", rev_file)
+    
+    rdx_file <- path(data_dir, sprintf("%s.corpus.rdx", p_attribute))
+    if (!file.exists(rdx_file)) warning("cwb_huffcode: file to delete missing")
+    removed <- file.remove(rdx_file)
+    if (removed) if (!quietly) message("redundant file deleted: ", rdx_file)
+  }
+
   success
 }
 

cran-comments.md

@@ -1,9 +1,9 @@
 ## General remarks
 
-This is a "standard" release with some new functionality. No changes to the 
+This is a maintenance release with bug fixes. No changes to the 
 setup of the package.
 
-Previous aspects I repeat here:
+Previous aspects I repeat:
 
 - CRAN package check results report 'GNU make is a SystemRequirements'. Using GNU
 make remains important for the portability of the C code. There would be a great
@@ -18,7 +18,8 @@ change.
 ## Test environments
 
 * CI checks with GitHub Actions (Windows/macOS/Ubuntu)
-* local macOS R 4.1.3 (arm64)
+* R winbuilder (R 4.2 release and devel)
+* local macOS, still R 4.1.3 (arm64)
 
 
 ## R CMD check results

inst/extdata/cwb/registry/unga

@@ -8,8 +8,6 @@ NAME "UNGA"
 ID   unga
 # path to binary data files
 HOME /private/var/folders/r6/1k6mxnbj5077980k11xvr0q40000gn/T/RtmpMJzg3A/revdep1207b38ee9c65/RcppCWB/extdata/cwb/indexed_corpora/unga
-# optional info file (displayed by ",info;" command in CQP)
-INFO /private/var/folders/r6/1k6mxnbj5077980k11xvr0q40000gn/T/RtmpMJzg3A/revdep1207b38ee9c65/RcppCWB/extdata/cwb/indexed_corpora/unga/.info
 
 # corpus properties provide additional information about the corpus:
 ##:: charset = "utf8"