Compare `979d9f8 ... +4 ... 008efed`

                    ...){
  format <- match.arg(format)
  n <- length(names)
  provider <- db


  # be compatible with common space delimiters
  names <- gsub("[_|-|\\.]", " ", names)

  df <- filter_name(name = names,
                provider = db,
                provider = provider,
                version = version,
                collect = TRUE,
                ignore_case = ignore_case,
                db = taxadb_db) %>%
    arrange(sort)

  df <- duplicate_as_unresolved(df)
  out <- vapply(names, function(x){
    df <- df[df$scientificName == x, ]

    if(nrow(df) < 1) return(NA_character_)

    # Unambiguous: one acceptedNameUsageID per name
    if(nrow(df)==1) return(df$acceptedNameUsageID[1])

    ## Drop infraspecies when not perfect match
    df <- df[is.na(df$infraspecificEpithet),]

  if(dim(df)[1] != n){
    stop(paste("Error in resolving possible duplicate names.",
               "Try the filter_name() function instead."),
         .call = FALSE)
  }
    ## If we resolve to a unique accepted ID, return that
    ids <- unique(df$acceptedNameUsageID)
    if(length(ids)==1){
      return(ids)
    } else {
      warning(paste0("  Found ", bb(length(ids)), " possible identifiers for ",
                     ibr(x),
                     ".\n  Returning ", bb('NA'), ". Try ",
                     bb(paste0("tl('", x, "', '", provider,"')")),
                     " to resolve manually.\n"),
              call. = FALSE)
      return(NA_character_)
    }
  },
  character(1L), USE.NAMES = FALSE)

  ##
  if("acceptedNameUsageID" %in% names(df)){
    out <- dplyr::pull(df, "acceptedNameUsageID")
  } else {
    out <- dplyr::pull(df, "taxonID")
  }

  ## Format ID as requested
  switch(format,

@@ -122,3 +137,12 @@

122	137		replace_empty(out)
123	138		}
124	139
	140	+
	141	+	ibr <- function(...){
	142	+	if(!requireNamespace("crayon", quietly = TRUE)) return(paste(...))
	143	+	crayon::italic(crayon::bold(crayon::red(...)))
	144	+	}
	145	+	bb <- function(...){
	146	+	if(!requireNamespace("crayon", quietly = TRUE)) return(paste(...))
	147	+	crayon::bold(crayon::blue(...))
	148	+	}

@@ -91,8 +91,8 @@

  sort <- "sort"   # avoid complaint about NSE.
                   #We could do sym("sort") but this is cleaner.
  suppress_msg({   # bc MonetDBLite whines about upper-case characters
    safe_right_join(x, y, by = by, copy = TRUE) %>%
      dplyr::arrange(sort)
    safe_right_join(x, y, by = by, copy = TRUE) #%>%
      #dplyr::arrange(sort)
  })
}


@@ -36,7 +36,7 @@

#'
#' }
td_connect <- function(dbdir = taxadb_dir(),
                       driver = Sys.getenv("TAXADB_DRIVER"),
                       driver = Sys.getenv("TAXADB_DRIVER", "duckdb"),
                       read_only = FALSE){

  arkdb::local_db(dbdir = dbdir, driver = driver, readonly = read_only)

@@ -17,36 +17,8 @@

#' @return a dplyr tbl connection to the temporary table in the database
#' @importFrom dplyr tbl
#' @export
#' @examples
#' \donttest{
#'   \dontshow{
#'    ## All examples use a temporary directory
#'    Sys.setenv(TAXADB_HOME=tempfile())
#'    Sys.setenv(TAXADB_DRIVER="RSQLite")
#'    options("taxadb_default_provider"="itis_test")
#'
#'   }
#'
#'   #Clean a list of messy common names
#'   library(dplyr)
#'   names <- clean_names(c("Steller's jay", "coopers Hawk"),
#'                binomial_only = FALSE, remove_sp = FALSE, remove_punc = TRUE)
#'
#'   #Get cleaned common names from a provider and search for cleaned names in that table
#'   taxa_tbl(schema = "common") %>%
#'   mutate_db(clean_names, "vernacularName", "vernacularNameClean",
#'             binomial_only = FALSE, remove_sp = FALSE, remove_punc = TRUE) %>%
#'   filter(vernacularNameClean %in% names)
#'
#'   \dontshow{
#'    ## All examples use a temporary directory
#'    Sys.unsetenv("TAXADB_HOME")
#'    Sys.unsetenv("TAXADB_DRIVER")

#'   }
#'
#' }

mutate_db <- function(.data,
                      r_fn,
                      col,

Learn more Showing 1 files with coverage changes found.

Changes in R/handling-duplicates.R

-10

→

+10

Loading file...

88.4% ø -5.8%

arkdb with read-write access

cboettig

008efed

CI Passed

Files		•	•	•	Coverage
R	+12	-10	ø	+22	^-5.8% 88.4%
Project Totals (16 files)	362	320	0	42	88.4%

61	61		...){
62	62		format <- match.arg(format)
63	63		n <- length(names)
	64	+	provider <- db
	65	+
64	66
65	67		# be compatible with common space delimiters
66	68		names <- gsub("[_\|-\|\\.]", " ", names)
67	69
68	70		df <- filter_name(name = names,
69		-	provider = db,
	71	+	provider = provider,
70	72		version = version,
71	73		collect = TRUE,
72	74		ignore_case = ignore_case,
73	75		db = taxadb_db) %>%
74	76		arrange(sort)
75	77
76		-	df <- duplicate_as_unresolved(df)
	78	+	out <- vapply(names, function(x){
	79	+	df <- df[df$scientificName == x, ]
	80	+
	81	+	if(nrow(df) < 1) return(NA_character_)
	82	+
	83	+	# Unambiguous: one acceptedNameUsageID per name
	84	+	if(nrow(df)==1) return(df$acceptedNameUsageID[1])
	85	+
	86	+	## Drop infraspecies when not perfect match
	87	+	df <- df[is.na(df$infraspecificEpithet),]
77	88
78		-	if(dim(df)[1] != n){
79		-	stop(paste("Error in resolving possible duplicate names.",
80		-	"Try the filter_name() function instead."),
81		-	.call = FALSE)
82		-	}
	89	+	## If we resolve to a unique accepted ID, return that
	90	+	ids <- unique(df$acceptedNameUsageID)
	91	+	if(length(ids)==1){
	92	+	return(ids)
	93	+	} else {
	94	+	warning(paste0(" Found ", bb(length(ids)), " possible identifiers for ",
	95	+	ibr(x),
	96	+	".\n Returning ", bb('NA'), ". Try ",
	97	+	bb(paste0("tl('", x, "', '", provider,"')")),
	98	+	" to resolve manually.\n"),
	99	+	call. = FALSE)
	100	+	return(NA_character_)
	101	+	}
	102	+	},
	103	+	character(1L), USE.NAMES = FALSE)
83	104
84		-	##
85		-	if("acceptedNameUsageID" %in% names(df)){
86		-	out <- dplyr::pull(df, "acceptedNameUsageID")
87		-	} else {
88		-	out <- dplyr::pull(df, "taxonID")
89		-	}
90	105
91	106		## Format ID as requested
92	107		switch(format,

Navigation	Overlay
`t` Navigate files	`h` Toggle hits
`y` Change url to tip of branch	`m` Toggle misses
`b / v` Jump to prev/next hit line	`p` Toggle partial
`z / x` Jump to prev/next missed or partial line	`1..9` Toggle flags
`shift + o` Open current page in GitHub	`a` Toggle all on
`/ or ?` Show keyboard shortcuts dialog	`c` Toggle context lines or commits

91	91		sort <- "sort" # avoid complaint about NSE.
92	92		#We could do sym("sort") but this is cleaner.
93	93		suppress_msg({ # bc MonetDBLite whines about upper-case characters
94		-	safe_right_join(x, y, by = by, copy = TRUE) %>%
95		-	dplyr::arrange(sort)
	94	+	safe_right_join(x, y, by = by, copy = TRUE) #%>%
	95	+	#dplyr::arrange(sort)
96	96		})
97	97		}
98	98

36	36		#'
37	37		#' }
38	38		td_connect <- function(dbdir = taxadb_dir(),
39		-	driver = Sys.getenv("TAXADB_DRIVER"),
	39	+	driver = Sys.getenv("TAXADB_DRIVER", "duckdb"),
40	40		read_only = FALSE){
41	41
42	42		arkdb::local_db(dbdir = dbdir, driver = driver, readonly = read_only)

17	17		#' @return a dplyr tbl connection to the temporary table in the database
18	18		#' @importFrom dplyr tbl
19	19		#' @export
20		-	#' @examples
21		-	#' \donttest{
22		-	#' \dontshow{
23		-	#' ## All examples use a temporary directory
24		-	#' Sys.setenv(TAXADB_HOME=tempfile())
25		-	#' Sys.setenv(TAXADB_DRIVER="RSQLite")
26		-	#' options("taxadb_default_provider"="itis_test")
27	20		#'
28		-	#' }
29	21		#'
30		-	#' #Clean a list of messy common names
31		-	#' library(dplyr)
32		-	#' names <- clean_names(c("Steller's jay", "coopers Hawk"),
33		-	#' binomial_only = FALSE, remove_sp = FALSE, remove_punc = TRUE)
34		-	#'
35		-	#' #Get cleaned common names from a provider and search for cleaned names in that table
36		-	#' taxa_tbl(schema = "common") %>%
37		-	#' mutate_db(clean_names, "vernacularName", "vernacularNameClean",
38		-	#' binomial_only = FALSE, remove_sp = FALSE, remove_punc = TRUE) %>%
39		-	#' filter(vernacularNameClean %in% names)
40		-	#'
41		-	#' \dontshow{
42		-	#' ## All examples use a temporary directory
43		-	#' Sys.unsetenv("TAXADB_HOME")
44		-	#' Sys.unsetenv("TAXADB_DRIVER")
45		-
46		-	#' }
47		-	#'
48		-	#' }
49		-
50	22		mutate_db <- function(.data,
51	23		r_fn,
52	24		col,

Compare 979d9f8 ... +4 ... 008efed

No flags found

Show failed CI and contexual commits c 6 Commits

Compare `979d9f8 ... +4 ... 008efed`

Show failed CI and contexual commits `c`

6 Commits