R/concepts.R

In anoopshah/Rdiagnosislist: Manipulate SNOMED CT Diagnosis Lists

#' Check if inactive terms are included in SNOMED CT dictionary
#'
#' Checks the active_only flag in the metadata of a SNOMED
#' environment to determine whether inactive terms are
#' included
#'
#' @param SNOMED environment containing SNOMED dictionary, defaults
#'   to an object named 'SNOMED' in the global environment
#' @return TRUE or FALSE (logical vector of length one)
#' @export
#' @examples
#' # Create a TEST environment and load the sample dictionaries
#' TEST <- sampleSNOMED()
#' inactiveIncluded(TEST)
#' assign('metadata', list(active_only = TRUE), envir = TEST)
#' inactiveIncluded(TEST)
inactiveIncluded <- function(SNOMED = getSNOMED()){
	if (is.null(SNOMED$metadata$active_only)){
		TRUE
	} else if (SNOMED$metadata$active_only == TRUE){
		FALSE
	} else {
		TRUE
	}
}

#' Returns the SNOMED CT concept IDs for a set of terms
#'
#' Carries out an exact or regular expression match to
#' return the concept ID for a set of search terms, or
#' converts a character, integer or integer64 vector to a
#' SNOMEDconcept object.
#'
#' @param x character vector of terms to match, or
#'   character vector containing SNOMED CT concept IDs, or
#'   64-bit integer vector containing SNOMED CT concept IDs
#' @param active_only whether or not to include inactive concepts
#' @param exact_match if TRUE, only an exact (case sensitive)
#'   match is performed. If FALSE, a regular expression match
#'   is performed.
#' @param unique whether to include no more than one instance of each
#'   SNOMED CT concept
#' @param SNOMED environment containing SNOMED dictionary. Defaults
#'   to an object named 'SNOMED' in the global environment
#' @param ... additional arguments to send to grepl if using
#'   regular expression matching
#' @return a SNOMEDconcept object (vector of 64-bit integers) containing
#'   unique SNOMED CT concept IDs
#' @import data.table
#' @import bit64
#' @export
#' @examples
#' SNOMEDconcept('Heart failure', SNOMED = sampleSNOMED()) -> hf
#' is.SNOMEDconcept(hf)
#' SNOMEDconcept('900000000000003001')
#' as.SNOMEDconcept('900000000000003001')
SNOMEDconcept <- function(x, active_only = TRUE,
	exact_match = TRUE, unique = TRUE,
	SNOMED = getSNOMED()){
	# Declare names to be used for non-standard evaluation for R CMD check
	active <- conceptId <- NULL
	
	if (length(x) == 0){
		out <- integer64(0)
		class(out) <- c('SNOMEDconcept', 'integer64')
		return(out)
	}
	if ('integer64' %in% class(x)){
		# correct format for a SNOMED CT concept ID
		out <- x
		class(out) <- c('SNOMEDconcept', 'integer64')
		return(out)
	} else if ('integer' %in% class(x)){
		# convert to integer64
		out <- bit64::as.integer64(x)
		class(out) <- c('SNOMEDconcept', 'integer64')
		return(out)
	} else if ('character' %in% class(x)){
		if (all(grepl('^[0-9]+$', x))){
			# concept ID in character format 
			out <- bit64::as.integer64(x)
			class(out) <- c('SNOMEDconcept', 'integer64')
			return(out)
		}
	} else {
		stop('term to match must be character, integer or integer64; ',
			class(x), ' is not acceptable.')
	}

	# Try to match a term description
	if (exact_match){
		if (inactiveIncluded(SNOMED)){
			MATCHED <- SNOMED$DESCRIPTION[data.table(term = x),
				list(active, conceptId), on = 'term']
		} else {
			MATCHED <- SNOMED$DESCRIPTION[data.table(term = x),
				list(conceptId), on = 'term']
		}
	} else {
		matched <- rep(FALSE, nrow(SNOMED$DESCRIPTION))
		for (i in x){
			matched <- matched | grepl(i, SNOMED$DESCRIPTION$term)
		}
		if (inactiveIncluded(SNOMED)){
			MATCHED <- SNOMED$DESCRIPTION[matched, list(active, conceptId)]
		} else {
			MATCHED <- SNOMED$DESCRIPTION[matched, list(conceptId)]
		}
	}
	
	# Limit to active descriptions if needed
	if (active_only & inactiveIncluded(SNOMED)){
		MATCHED <- MATCHED[active == TRUE]
	}
	
	# Limit to active concepts
	if (active_only){
		if (inactiveIncluded(SNOMED)){
			out <- SNOMED$CONCEPT[MATCHED[, list(id = conceptId)],
				on = 'id'][active == TRUE]$id
		} else {
			out <- merge(SNOMED$CONCEPT, MATCHED[, list(id = conceptId)],
				by = 'id')$id
		}
		if (unique){
			out <- unique(out)
		}
	} else {
		if (unique){
			out <- unique(MATCHED$conceptId)
		} else {
			out <- MATCHED$conceptId
		}
	}
	class(out) <- c('SNOMEDconcept', 'integer64')
	return(out)
}

#' @rdname SNOMEDconcept
#' @family SNOMEDconcept functions
#' @export
as.SNOMEDconcept <- function(x, ...){
	if (is.SNOMEDconcept(x)){
		return(x)
	} else {
		return(SNOMEDconcept(x, ...))
	}
}

#' Check if an object is a SNOMEDconcept
#'
#' SNOMEDconcept is an S3 class for vectors of SNOMED concept IDs
#' as 64-bit integers. This function checks whether the object has
#' the class SNOMEDconcept and is a vector of 64-bit integers.
#'
#' @param x object to check
#' @return a logical vector of length one: TRUE or FALSE
#' @family SNOMEDconcept functions
#' @export
is.SNOMEDconcept <- function(x){
	if (identical(class(x), c('SNOMEDconcept', 'integer64'))){
		TRUE
	} else {
		FALSE
	}
}

#' Display a SNOMEDconcept object with descriptions
#'
#' SNOMEDconcept is an S3 class for vectors of SNOMED concept IDs
#' as 64-bit integers. This function checks whether the object has
#' the class SNOMEDconcept and is a vector of 64-bit integers.
#'
#' @param x SNOMEDconcept object, or something that can be
#'   coerced to one
#' @param ... not required
#' @return invisibly returns a character vector of the SNOMED CT
#'   concepts with descriptions separated by pipe (|)
#' @family SNOMEDconcept functions
#' @method print SNOMEDconcept
#' @export
print.SNOMEDconcept <- function(x, ...){
	SNOMED <- NULL
	try(SNOMED <- getSNOMED(), silent = TRUE)
	
	if (length(x) > 0){
		if (is.null(SNOMED)){
			out <- as.SNOMEDconcept(x)
			class(out) <- 'integer64'
			methods::show(out)
			return(invisible(out))
		} else {
			x <- as.SNOMEDconcept(x, SNOMED = SNOMED)
			output <- paste0(x, ' | ', description(x, SNOMED = SNOMED)$term)
			
			truncateChar <- function (x, maxchar){
				convert <- nchar(x) > maxchar
				x[convert] <- paste0(substr(x[convert], 1, maxchar - 3), "...")
				x
			}
			
			methods::show(truncateChar(output, getOption("width") - 7))
			return(invisible(output))
		}
	} else {
		message('No SNOMED CT concepts\n')
		return(character(0))
	}
}

#' Obtain descriptions for a set of SNOMED CT terms
#'
#' Returns the descriptions matching a set of concept IDs from
#' a SNOMED dictionary
#'
#' @param conceptIds character or integer64 vector
#' @param include_synonyms whether to return only the Fully Specified
#'    Name (default) or all synonyms
#' @param active_only whether to include only active descriptions
#' @param SNOMED environment containing SNOMED dictionary. Defaults
#'   to an object named 'SNOMED' in the global environment
#' @return a data.table with the following columns: id, conceptId, type
#'   (only if include_synonyms = TRUE), term,
#'   active (only if active_only = FALSE)
#' @export
#' @examples
#' hf <- SNOMEDconcept('Heart failure', SNOMED = sampleSNOMED())
#' description(hf, include_synonyms = FALSE, SNOMED = sampleSNOMED())
description <- function(conceptIds,
	include_synonyms = FALSE, active_only = TRUE,
	SNOMED = getSNOMED()){
	# Check that conceptIds is a vector of strings or integer64 values
	# FSN     '900000000000003001'
	# Synonym '900000000000013009'
	
	# Declare names used for non-standard evaluation for R CMD check
	id <- term <- active <- typeId <- conceptId <- NULL
	
	# Return an empty data.table if there is no input data
	if (length(conceptIds) == 0){
		return(data.table(id = integer64(0), conceptId = integer64(0),
			term = character(0)))
	}
	
	CONCEPTS <- data.table(conceptId = as.SNOMEDconcept(conceptIds),
		order = seq_along(conceptIds))
	TOMATCH <- data.table(conceptId = unique(CONCEPTS$conceptId))
	if (include_synonyms == FALSE){
		OUT <- SNOMED$DESCRIPTION[TOMATCH, on = 'conceptId'][
			typeId == bit64::as.integer64('900000000000003001')][,
			list(id, conceptId, term, active)]
	} else {
		OUT <- SNOMED$DESCRIPTION[TOMATCH, on = 'conceptId'][,
			list(id, conceptId, type = ifelse(
			typeId == bit64::as.integer64('900000000000003001'),
			'Fully specified name', 'Synonym'), term, active)]
	}
	# Remove inactive terms if necessary
	if (active_only){
		if (inactiveIncluded(SNOMED)){
			OUT <- OUT[active == TRUE]
		}
		OUT[, active := NULL]
	}
	# Restore original order
	OUT <- OUT[CONCEPTS, on = 'conceptId', allow.cartesian = TRUE]
	data.table::setkeyv(OUT, 'order')
	OUT[, order := NULL]
	OUT[]
}

#' Set operations for SNOMEDconcept vectors
#'
#' The default set functions in the base package do not handle integer64
#' vectors correctly, so this package also provides new generic functions
#' for union, intersect and setdiff, which enable the appropriate
#' object-specific function to be called according to the class of the
#' vector. This means that SNOMEDconcept vectors will remain as 
#' SNOMEDconcept vectors when these functions are used.
#'
#' @param x SNOMEDconcept vector
#' @param y SNOMEDconcept vector, or an object that can be coerced
#'   to SNOMEDconcept by as.SNOMEDconcept
#' @return an integer64 vector of SNOMEDconcept class
#' @export
#' @examples
#' sys_acute <- SNOMEDconcept(c('Systolic heart failure',
#'   'Acute heart failure'), SNOMED = sampleSNOMED())
#' acute_left_right <- SNOMEDconcept(c('Acute heart failure',
#'   'Left heart failure', 'Right heart failure'),
#'   SNOMED = sampleSNOMED())
#' union(sys_acute, acute_left_right) 
#' intersect(sys_acute, acute_left_right)
#' setdiff(sys_acute, acute_left_right)
union.SNOMEDconcept <- function(x, y){
	out <- unique(c(x, as.SNOMEDconcept(y)))
	class(out) <- c('SNOMEDconcept', 'integer64')
	out
}

#' @rdname union.SNOMEDconcept
#' @family SNOMEDconcept functions
#' @export
union <- function (x, y){
	UseMethod('union', x)
}

#' @rdname union.SNOMEDconcept
#' @family SNOMEDconcept functions
#' @method union default
#' @export
union.default <- function(x, y){
	base::union(x, y)
}

#' @rdname union.SNOMEDconcept
#' @family SNOMEDconcept functions
#' @method intersect SNOMEDconcept
#' @export
intersect.SNOMEDconcept <- function(x, y){
	if (length(y) == 0 | length(x) == 0){
		out <- bit64::integer64(0)
	} else {
		out <- unique(x[x %in% as.SNOMEDconcept(y)])
	}
	class(out) <- c('SNOMEDconcept', 'integer64')
	out
}

#' @rdname union.SNOMEDconcept
#' @family SNOMEDconcept functions
#' @export
intersect <- function (x, y){
	UseMethod('intersect', x)
}

#' @rdname union.SNOMEDconcept
#' @family SNOMEDconcept functions
#' @method intersect default
#' @export
intersect.default <- function(x, y){
	base::intersect(x, y)
}

#' @rdname union.SNOMEDconcept
#' @family SNOMEDconcept functions
#' @method setdiff SNOMEDconcept
#' @export
setdiff.SNOMEDconcept <- function(x, y){
	if (length(y) == 0 | length(x) == 0){
		out <- x
	} else {
		out <- unique(x[!(x %in% as.SNOMEDconcept(y))])
	}
	class(out) <- c('SNOMEDconcept', 'integer64')
	out
}

#' @rdname union.SNOMEDconcept
#' @family SNOMEDconcept functions
#' @export
setdiff <- function(x, y){
	UseMethod('setdiff', x)
}

#' @rdname union.SNOMEDconcept
#' @family SNOMEDconcept functions
#' @method setdiff default
#' @export
setdiff.default <- function(x, y){
	base::setdiff(x, y)
}

#' Concatenate vectors of SNOMED CT concepts
#'
#' SNOMEDconcept is an S3 class for vectors of SNOMED concept IDs
#' as 64-bit integers. This function concatenates two or more
#' SNOMEDconcept vectors.
#'
#' @param ... SNOMEDconcept vectors
#' @return concatenation of vectors
#' @family SNOMEDconcept functions
#' @method c SNOMEDconcept
#' @export
#' @examples
#' hf <- SNOMEDconcept('Heart failure', SNOMED = sampleSNOMED())
#' hf2 <- c(hf, hf)
c.SNOMEDconcept <- function(...){
	out <- bit64::c.integer64(...)
	if (bit64::is.integer64(out)){
		class(out) <- c('SNOMEDconcept', 'integer64')
	}
	out
}

#' Unique vector of SNOMED CT concepts
#'
#' SNOMEDconcept is an S3 class for vectors of SNOMED concept IDs
#' as 64-bit integers. This function returns a vector containing only
#' unique SNOMEDconcept values.
#'
#' @param x SNOMEDconcept vector
#' @param ... other variables to pass on to the underlying 'unique' function
#' @return SNOMEDconcept vector with duplicates removed
#' @family SNOMEDconcept functions
#' @method unique SNOMEDconcept
#' @export
#' @examples
#' hf <- SNOMEDconcept('Heart failure', SNOMED = sampleSNOMED())
#' hf2 <- c(hf, hf)
#' unique(hf2)
unique.SNOMEDconcept <- function(x, ...){
	class(x) <- 'integer64'
	out <- bit64::unique.integer64(x, ...)
	class(out) <- c('SNOMEDconcept', 'integer64')
	out
}