Commit c09412a3 authored by Petar Horki's avatar Petar Horki

Preparing for repository migration ...

parents 226a3e6e 36fe381b
......@@ -162,8 +162,8 @@ DataModel.Demographics <- function() {
#' Get
#'
#' @description
#' Given the domain(s) and key(s), get the values from the global dictionary.\cr
#' Returns the whole dictionary when called without parameters.
#' Given the domain(s) and key(s), get the matching entries from the global\cr
#' dictionary. Returns the whole dictionary when called without parameters.
#'
#' @details
#' Assumption: the global dictionary exists.
......@@ -243,6 +243,27 @@ Delete <- function(domainIn, keyIn) {
anti_join(Get(domainIn, keyIn), by = c('domain', 'key'))
}
#==============================================================================
#' Keys
#'
#' @description
#' Given the value(s), get the the matching entries from the global dictionary.
#'
#' @details
#' Assumption: the global dictionary exists.
#'
#' @param valueIn The value(s)
#'
#' @export
Keys <- function(domainIn) {
stopifnot(exists("_myDict"))
myDict <- `_myDict` %>%
filter(value %in% valueIn)
return(myDict)
}
#==============================================================================
#' SchemaToJSON
#'
......@@ -744,3 +765,184 @@ MapClass <- function(sourceCode, connection, searchChildren) {
setterResults <- `_MapClass.Set`(parserResults)
}
#==============================================================================
#'
Factory.Map <- function(classification){
# TODO function that reads and returns sql from file(s) in inst/sql/postgres
# ... <- f(paste0("_MAP_", classification, "_DB_SCHEMA"))
myRenderedSql <- do.call(paste0("Render", classification), list(...))
# TODO where to call classification specific parser/setter parts?
# OPTION A
myMapFun = function(sourceCode, connection){
# OPTION B
getterResults <- `_MapClass.Get`(sourceCode, connection, myRenderedSql)
parserResults <- `_MapClass.Parse`(getterResults)
setterResults <- `_MapClass.Set`(parserResults)
return(setterResults)
}
return(myMapFun)
}
#==============================================================================
#'
RenderLOINC <- function(...) {
renderedSql <- SqlRender::render(sqlTemplate,
databaseSchema = databaseSchema,
table1 = 'concept',
columns = '*',
attr1 = 'concept_code',
attr2 = 'standard_concept',
operator1 = 'LIKE',
operator2 = 'LIKE',
value1 = sprintf("'%s'", value1),
value2 = sprintf("'%s'", 'S'),
limit = 10)
}
#==============================================================================
#'
RenderICD <- function(...) {
renderedSql <- SqlRender::render(`_MAP_CLASS_SQL_TEMPLATE`,
databaseSchema = `_MAP_CLASS_DB_SCHEMA`,
table1 = 'source_to_concept_map',
table2 = 'concept',
columns = c('SOURCE_CODE', 'TARGET_CONCEPT_ID', 'CONCEPT_NAME', 'DOMAIN_ID',
'CONCEPT_CLASS_ID', 'CONCEPT.VALID_START_DATE', 'CONCEPT.VALID_END_DATE',
'SOURCE_VOCABULARY_ID', 'STANDARD_CONCEPT'),
joinAttr1 = 'target_concept_id',
joinAttr2 = 'concept_id',
condition1 = 'source_code',
operator1 = 'LIKE',
value1 = sprintf("'%s'", value1),
limit = 10)
}
getLoinc <- function(loincCode, connection, searchChildren) {
sqlTemplate <- "Select @columns FROM @databaseSchema.@table1 WHERE @attr1 @operator1 @value1 AND @attr2 @operator2 @value2{0 != @limit}?{ LIMIT @limit};"
databaseSchema = 'vocabulary'
# add '*' to loincCode (i.e J44 -> J44*)
if(searchChildren) {
loincCode = paste(loincCode, "*", sep = "")
}
# replace '*' in given code parameter with % to use in sql
value1 = gsub("[*]", "%", loincCode)
renderedSql <- SqlRender::render(sqlTemplate,
databaseSchema = databaseSchema,
table1 = 'concept',
columns = '*',
attr1 = 'concept_code',
attr2 = 'standard_concept',
operator1 = 'LIKE',
operator2 = 'LIKE',
value1 = sprintf("'%s'", value1),
value2 = sprintf("'%s'", 'S'),
limit = 10)
sqlResults <- ExecuteSQL(connection, renderedSql)
#DatabaseConnector::disconnect(omopConn)
return(sqlResults)
}
parseLoinc <- function(sqlResults) {
# vectors for the source codes and concept name
conceptClassIds <- c()
conceptIds <- c()
conceptNames <- c() # conceptNames
# get the source codes (if there are multiple) , concept name and source vocabulary id
for (i in 1:length(sqlResults[[1]])) {
# check only standard concepts, others will have value 'NA'
if (!is.na(sqlResults[['STANDARD_CONCEPT']][i])) {
conceptNames <- c(conceptNames, sqlResults[['CONCEPT_NAME']][i])
conceptId <- c(conceptIds, sqlResults[['CONCEPT_ID']][i])
conceptClassId <- c(conceptClassIds, sqlResults[['CONCEPT_CLASS_ID']][i])
sourceVocabularyID <- sqlResults[['SOURCE_VOCABULARY_ID']][i]
domainId <- sqlResults[['DOMAIN_ID']][i]
}
}
# throw out duplicates
conceptNames <- unique(conceptNames)
conceptClassIds <- unique(conceptClassIds)
conceptIds <- unique(conceptIds)
# test if only duplicates in sourceVocabularyID
if(1 != length(unique(sourceVocabularyID))) {
warning("Multiple source vocabulary IDs where only one is expected.")
}
sourceVocabularyID <- unique(sourceVocabularyID)
# need only one domain since it is constant
myDomain = paste(sqlResults[,'DOMAIN_ID'], ":", sqlResults[,'CONCEPT_ID'], sep="")
attribute = conceptNames[[1]]
# Quick and dirty parameter workaround
myKeys = c('entityType', 'isRepeatable', 'valueType', 'Attribute', 'Attribute', 'Attribute')
myValues = list('Participant', 'FALSE', 'boolean', Attribute(attribute, 'label', 'en'),
Attribute(conceptNames[1], 'description', 'en'),
Attribute(paste(paste0(conceptClassIds, ':'), paste(conceptIds, collapse=', '), sep=' '), 'source codes', 'en'))
return(list("myDomain"=myDomain, "myKeys"=myKeys, "myValues"=myValues))
}
setLoinc <- function(parsedResults) {
myDomain <- parsedResults[[1]]
myKeys <- parsedResults[[2]]
myValues <- parsedResults[[3]]
for(i in 1:length(myKeys)) {
Set(domainIn=myDomain, keyIn=myKeys[[i]], valueIn=myValues[[i]])
}
return(list("myDomain"=myDomain, "myKeys"=myKeys, "myValues"=myValues))
}
#
# myFilePath = file.path("../..", "inst", "config.yml")
# myOmopParams <- config::get(file=myFilePath,"omop")
# create OMOP connection
omopConn <- OpenOmopConnection(dbmsIn = myOmopParams$dbms,
serverIn = myOmopParams$server,
userIn = myOmopParams$user,
portIn = myOmopParams$port,
passwordIn = myOmopParams$password,
schemaIn = myOmopParams$schema)
loincCode = '%8302-2%'
getResults <- getLoinc(loincCode, omopConn, FALSE)
parsedResults <- parseLoinc(sqlResults)
setResults <- setLoinc(parsedResults)
print(getResults)
......@@ -1089,14 +1089,27 @@ test_that("mapping a source ICD code works", {
expect_that(myDict$key, equals(myKeys[[3]]))
expect_that(myDict$value[[1]]$value, equals(myValues[[3]]))
myDict <- Get(domainIn = myDomain, keyIn = myKeys[[4]])
expect_that(myDict$domain[[1]], equals(myDomain))
expect_that(myDict$key[[1]], equals(myKeys[[4]]))
expect_that(myDict$key[[2]], equals(myKeys[[4]]))
expect_that(myDict$key[[3]], equals(myKeys[[4]]))
expect_that(myDict$value[[1]], equals(myValues[[4]]))
expect_that(myDict$value[[2]], equals(myValues[[5]]))
expect_that(myDict$value[[3]], equals(myValues[[6]]))
# <<<<<<< HEAD
# myDict <- Get(domainIn = myDomain, keyIn = myKeys[[4]])
# expect_that(myDict$domain[[1]], equals(myDomain))
# expect_that(myDict$key[[1]], equals(myKeys[[4]]))
# expect_that(myDict$key[[2]], equals(myKeys[[4]]))
# expect_that(myDict$key[[3]], equals(myKeys[[4]]))
# expect_that(myDict$value[[1]], equals(myValues[[4]]))
# expect_that(myDict$value[[2]], equals(myValues[[5]]))
# expect_that(myDict$value[[3]], equals(myValues[[6]]))
# =======
#====================================================================
test_that("dynamic function calling works", {
AddFooPrefix <- function(param) {
return(paste0("Foo", param))
}
retVal <- do.call("AddFooPrefix", list("bar"))
expect_that(retVal, equals("Foobar"))
})
>>>>>>> master
# free resources
CloseOmopConnection(omopConn)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment