end of day

Author: petermeissner

NAMESPACE

@@ -3,7 +3,10 @@
 export("%>%")
 export(diffrproject)
 export(dp_text_base_data)
+export(moc_helper_easy_matches)
+export(moc_helper_get_options_ordered_by_dist)
 export(moc_helper_trivial_matches)
+import(data.table)
 import(hellno)
 import(rtext)
 import(stringb)

R/RcppExports.R

@@ -1,6 +1,19 @@
 # This file was generated by Rcpp::compileAttributes
 # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393
 
+#' (choose from a number of pre-sorted options)
+#' takes a vector pair of toki1 / toki2 and a vector pair of res_token_i_1 /
+#' res_token_i_2 and chooses so that each 1st and exh 2nd value only is used
+#' where res_token_i_x identiefies already used items.
+#' @param toki1 first number of number pair to choose from
+#' @param toki2 second number of number pair to choose from
+#' @param res_token_i_1 already used first numbers
+#' @param res_token_i_2 already used second numbers
+#' // @keywords internal
+choose_options <- function(toki1, toki2, res_token_i_1, res_token_i_2) {
+    .Call('diffrprojects_choose_options', PACKAGE = 'diffrprojects', toki1, toki2, res_token_i_1, res_token_i_2)
+}
+
 #' (function to calculate distance matrix of integers)
 #' takes vector of size n and vector of size m and gives back matrix of n rows and m columns
 #' @param x a vector of type numeric

R/moc_helper.R

@@ -1,34 +1,144 @@
 #' trivial matches
 #'
-#' merhtod of comparison helper function
+#' merthod of comparison helper function
 #' @param tt1 tokenized text number 1
 #' @param tt2 tokenized text number 2
 #' @export
 moc_helper_trivial_matches <- function(tt1, tt2){
   # preparation
-  tt1 <- subset( tt1, TRUE, c(token, token_i))
+  tt1 <- subset( tt1, is_unique(token), c(token, token_i))
   tt1 <- data.table::as.data.table(tt1)
   data.table::setkey(tt1, token)
 
-  tt2 <- subset( tt2, TRUE, c(token, token_i))
+  tt2 <- subset( tt2, is_unique(token), c(token, token_i))
   tt2 <- data.table::as.data.table(tt2)
   data.table::setkey(tt2, token)
 
   # merge / join
-  matches <-
-    suppressWarnings(dplyr::inner_join(tt1, tt2, by="token"))
-  data.table::setkey(matches, token_i.x, token_i.y)
+  matches <- suppressWarnings(dplyr::inner_join(tt1, tt2, by="token"))
+             data.table::setkey(matches, token_i.x, token_i.y)
+
   # clean up names
   names(matches) <-
     names(matches) %>%
     stringb::text_replace("\\.", "_") %>%
     stringb::text_replace("x", "1") %>%
     stringb::text_replace("y", "2")
-  # keep unique matches only
-  iffer <- unique(matches$token_i_1)
-  matches <- matches[iffer, ]
-  iffer <- unique(matches$token_i_2)
-  matches <- matches[iffer, ]
+
   # return
   return(matches)
 }
+
+#' easy matches 1
+#'
+#' method of comparison helper function
+#' @param tt1 tokenized text number 1
+#' @param tt2 tokenized text number 2
+#' @export
+moc_helper_easy_matches <- function(tt1, tt2, res, type=c(1,2), fullreturn=TRUE){
+  # check input
+  if( is.null(tt1) | is.null(tt2) ){
+    # return
+    if( fullreturn ){
+      return(res)
+    }else{
+      return(data.frame())
+    }
+  }
+  # preparation
+  tt1_tmp <-
+    tt1 %>%
+    dplyr::select(token, token_i) %>%
+    dplyr::filter(
+      !(token_i %in% res$token_i_1)
+    ) %>%
+    as.data.table()
+  setkey(tt1_tmp, token_i)
+
+  tt2_tmp <-
+    tt2 %>%
+    dplyr::select(token, token_i) %>%
+    dplyr::filter(
+      !(token_i %in% res$token_i_2)
+    ) %>%
+    as.data.table()
+  setkey(tt2_tmp, token_i)
+
+  # decide which tokens (from text1 or from text2) should be unique
+  if( type == 1){
+    tt1_tmp <- tt1_tmp %>%  dplyr::filter( is_unique(token) )
+  }else if( type == 2){
+    tt2_tmp <- tt2_tmp %>%  dplyr::filter( is_unique(token) )
+  }
+
+  # get and order possible matches
+  matches <-
+    suppressWarnings(
+      moc_helper_get_options_ordered_by_dist(tt1_tmp, tt2_tmp, res)
+    )
+
+  # process optional matches
+  chosen <-
+    choose_options(matches$token_i_1, matches$token_i_2, res$token_i_1, res$token_i_2) %>%
+    as.data.table() %>%
+    setkey(token_i_1)
+
+  # add token to get it rbind-ed to res
+  tt1_tmp <- setNames(tt1_tmp, c("token", "token_i_1"))
+  chosen <- dplyr::left_join(chosen, tt1_tmp, by="token_i_1")
+
+  # return
+  if( fullreturn ){
+    return(rbind(res,chosen))
+  }else{
+    return(chosen)
+  }
+}
+
+
+#' get options for machtches
+#'
+#' method of comparison helper function
+#' @param tt1 tokenized text number 1
+#' @param tt2 tokenized text number 2
+#' @param res data.frame of already matched
+#' @import data.table
+#' @export
+moc_helper_get_options_ordered_by_dist <- function(tt1, tt2, res){
+  # distance between availible token positions and positions of tokens already matched
+  dist           <- which_dist_min_absolute(tt1$token_i, res$token_i_1)
+  tt1$min_dist_1 <- dist$minimum
+  # preapare information from res
+  res_tmp <-
+    res[dist$location, ] %>%
+    dplyr::select(token_i_1, token_i_2) %>%
+    setNames( paste0("res_",names(.)) )
+  # combine res with info from tt1
+  tt1_tmp <-
+    tt1 %>%
+    dplyr::select(token, token_i, min_dist_1) %>%
+    cbind(res_tmp)
+  # join tt1 and tt2
+  tt2_tmp <- dplyr::select(tt2, token, token_i)
+  tt1_tmp <-
+    tt1_tmp %>%
+    dplyr::inner_join(tt2_tmp, by="token")
+  names(tt1_tmp)[names(tt1_tmp)=="token_i.x"] <- "token_i_1"
+  names(tt1_tmp)[names(tt1_tmp)=="token_i.y"] <- "token_i_2"
+  tt1_tmp <- data.table::as.data.table(tt1_tmp)
+  # delete columns
+  tt1_tmp[, token := NULL]
+  tt1_tmp[, res_token_i_1 := NULL]
+  # add token_i_2 position distance
+  tt1_tmp$min_dist_2 <- 0L
+  tt1_tmp$min_dist_2 <- abs(tt1_tmp$res_token_i_2 - tt1_tmp$token_i_2)
+  # delete columns
+  tt1_tmp[, res_token_i_2 := NULL]
+  # sort
+  data.table::setorder(tt1_tmp, min_dist_1, min_dist_2, token_i_1, token_i_2)
+  # delete columns
+  tt1_tmp[, min_dist_1 := NULL]
+  tt1_tmp[, min_dist_2 := NULL]
+  # return
+  return(tt1_tmp)
+}

README.Rmd

@@ -17,13 +17,32 @@ cat("#", tmp$Title)
 
 **Status**
 
-*unstable* - in wild developement with fuRiouS rEstRucturINg and biG biG pOKing
 
 [![Travis-CI Build Status](https://travis-ci.org/petermeissner/diffrprojects.svg?branch=master)](https://travis-ci.org/petermeissner/diffrprojects)
 [![codecov](https://codecov.io/gh/petermeissner/diffrprojects/branch/master/graph/badge.svg)](https://codecov.io/gh/petermeissner/diffrprojects/tree/master/R)
 [![CRAN version](http://www.r-pkg.org/badges/version/diffrprojects)](https://cran.r-project.org/package=diffrprojects)
 
 
+
+```{r, include=FALSE}
+filelist.R   <- list.files("R", recursive = TRUE, pattern="\\.R$", ignore.case = TRUE, full.names = TRUE)
+filelist.tests   <- list.files("tests", recursive = TRUE, pattern="\\.R$", ignore.case = TRUE, full.names = TRUE)
+filelist.cpp <- list.files("src", recursive = TRUE, pattern="\\.cpp$", ignore.case = TRUE, full.names = TRUE)
+lines.R      <- unlist(lapply(filelist.R, readLines))
+lines.tests  <- unlist(lapply(filelist.cpp, readLines))
+lines.cpp    <- unlist(lapply(filelist.cpp, readLines))
+length.R     <- length(grep("(^\\s*$)|(^\\s*#)|(^\\s*//)", lines.R,  value = TRUE, invert = TRUE))
+length.tests <- length(grep("(^\\s*$)|(^\\s*#)|(^\\s*//)", lines.tests,  value = TRUE, invert = TRUE))
+length.cpp   <- length(grep("(^\\s*$)|(^\\s*#)|(^\\s*//)", lines.cpp,  value = TRUE, invert = TRUE))
+```
+
+
+*unstable* - in wild developement with fuRiouS rEstRucturINg and biG biG pOKing
+
+*lines of R code:* `r length.R`, *lines of C++ code:* `r length.cpp`, *lines of test code:* `r length.tests`
+
+
+
 **Version**
 
 ```{r, results='asis', echo=FALSE}

README.md

@@ -4,9 +4,11 @@ Using diffr for more than two files
 
 **Status**
 
+[![Travis-CI Build Status](https://travis-ci.org/petermeissner/diffrprojects.svg?branch=master)](https://travis-ci.org/petermeissner/diffrprojects) [![codecov](https://codecov.io/gh/petermeissner/diffrprojects/branch/master/graph/badge.svg)](https://codecov.io/gh/petermeissner/diffrprojects/tree/master/R) [![CRAN version](http://www.r-pkg.org/badges/version/diffrprojects)](https://cran.r-project.org/package=diffrprojects)
+
 *unstable* - in wild developement with fuRiouS rEstRucturINg and biG biG pOKing
 
-[![Travis-CI Build Status](https://travis-ci.org/petermeissner/diffrprojects.svg?branch=master)](https://travis-ci.org/petermeissner/diffrprojects) [![codecov](https://codecov.io/gh/petermeissner/diffrprojects/branch/master/graph/badge.svg)](https://codecov.io/gh/petermeissner/diffrprojects/tree/master/R) [![CRAN version](http://www.r-pkg.org/badges/version/diffrprojects)](https://cran.r-project.org/package=diffrprojects)
+*lines of R code:* 388, *lines of C++ code:* 112, *lines of test code:* 112
 
 **Version**