R/epitool_import.R

In R4VN: Health Data Analysis and Publication-Ready Reporting

# =============================================================================
# R4VN EpiTool Studio - Universal import, templates, mapping and validation
# File: R/epitool_import.R
# =============================================================================

.r4vn_epi_template_registry <- function() {
  list(
    outbreak = list(
      title="Outbreak line list",
      file="outbreak_line_list_template.xlsx",
      required=c("case_id"),
      recommended=c("onset_date","case_status"),
      aliases=list(
        case_id=c("case_id","caseid","id","ma_ca","maca","record_id","stt"),
        onset_date=c("onset_date","onset","date_onset","ngay_khoi_phat","ngaykhoiphat"),
        report_date=c("report_date","date_reported","notification_date","ngay_bao_cao"),
        case_status=c("case_status","status","classification","phan_loai_ca","phanloaica"),
        age=c("age","tuoi","tu\u1ed5i"), sex=c("sex","gender","gioi","gioitinh","gi\u1edbi"),
        latitude=c("latitude","lat","vi_do","vido","v\u0129_\u0111\u1ed9","v\u0129\u0111\u1ed9"),
        longitude=c("longitude","lon","lng","kinh_do","kinhdo")
      )
    ),
    foodborne = list(
      title="Foodborne outbreak / exposure analysis",
      file="foodborne_exposure_template.xlsx",
      required=c("case_id","ill"),
      recommended=c("onset_date"),
      aliases=list(
        case_id=c("case_id","id","ma_ca","stt"),
        ill=c("ill","illness","case","outcome","benh","b\u1ec7nh"),
        onset_date=c("onset_date","onset","ngay_khoi_phat"),
        latitude=c("latitude","lat","vi_do","vido"),
        longitude=c("longitude","lon","lng","kinh_do","kinhdo")
      )
    ),
    surveillance = list(
      title="Routine surveillance",
      file="surveillance_template.xlsx",
      required=c("date","cases"),
      recommended=c("area"),
      aliases=list(
        date=c("date","week","month","report_date","ngay","ng\u00e0y"),
        cases=c("cases","case_count","n_cases","count","so_ca","soca","s\u1ed1_ca"),
        population=c("population","pop","dan_so","danso","d\u00e2n_s\u1ed1"),
        area=c("area","district","commune","province","site","location","dia_ban","diaban")
      )
    ),
    spatial_cases = list(
      title="Spatial case data",
      file="spatial_cases_template.xlsx",
      required=c("latitude","longitude"),
      recommended=c("case_id","onset_date","case_status"),
      aliases=list(
        case_id=c("case_id","caseid","id","ma_ca","maca","stt"),
        latitude=c("latitude","lat","y","vi_do","vido","v\u0129_\u0111\u1ed9","v\u0129\u0111\u1ed9"),
        longitude=c("longitude","lon","lng","x","kinh_do","kinhdo"),
        onset_date=c("onset_date","onset","date_onset","ngay_khoi_phat"),
        case_status=c("case_status","status","classification","phan_loai_ca")
      )
    ),
    spatial_sources = list(
      title="Suspected spatial sources",
      file="spatial_sources_template.xlsx",
      required=c("source_id","latitude","longitude"),
      recommended=c("source_name","source_type"),
      aliases=list(
        source_id=c("source_id","id","site_id","ma_nguon","manguon"),
        source_name=c("source_name","name","site_name","ten_nguon","tennguon"),
        source_type=c("source_type","type","site_type","loai_nguon","loainguon"),
        latitude=c("latitude","lat","y","vi_do","vido"),
        longitude=c("longitude","lon","lng","x","kinh_do","kinhdo")
      )
    ),
    area_rates = list(
      title="Area population / rates",
      file="area_population_template.xlsx",
      required=c("area_id","population"),
      recommended=c("area_name","cases"),
      aliases=list(
        area_id=c("area_id","district_code","commune_code","code","ma_dia_ban","madiaban"),
        area_name=c("area_name","district","commune","province","name","ten_dia_ban"),
        cases=c("cases","case_count","count","so_ca","soca"),
        population=c("population","pop","dan_so","danso")
      )
    ),
    diagnostic = list(
      title="Diagnostic / screening data",
      file="diagnostic_template.xlsx",
      required=c("index_test","reference_standard"),
      recommended=c("id"),
      aliases=list(
        id=c("id","case_id","patient_id","record_id","stt"),
        index_test=c("index_test","test","screening_test","xet_nghiem"),
        reference_standard=c("reference_standard","gold_standard","reference","chuan_tham_chieu")
      )
    ),
    case_control = list(
      title="Case-control data",
      file="case_control_template.xlsx",
      required=c("case","exposure"),
      recommended=c("id"),
      aliases=list(
        id=c("id","case_id","record_id","stt"),
        case=c("case","outcome","disease","benh","b\u1ec7nh"),
        exposure=c("exposure","exposed","phoi_nhiem","phoinhiem")
      )
    )
  )
}

.r4vn_epi_normalize_name <- function(x) {
  x <- enc2utf8(as.character(x))
  x <- iconv(x, from="", to="ASCII//TRANSLIT")
  x[is.na(x)] <- ""
  tolower(gsub("[^a-z0-9]+","",x))
}

.r4vn_epi_guess_mapping <- function(data, template_id) {
  reg <- .r4vn_epi_template_registry()
  if(!template_id %in% names(reg)) stop("Unknown EpiTool template.",call.=FALSE)
  aliases <- reg[[template_id]]$aliases
  nms <- names(data); norm <- .r4vn_epi_normalize_name(nms)
  out <- setNames(rep(NA_character_,length(aliases)),names(aliases))
  for(field in names(aliases)) {
    aa <- unique(.r4vn_epi_normalize_name(c(field,aliases[[field]])))
    exact <- which(norm %in% aa)
    if(length(exact)) {
      out[field] <- nms[exact[1]]
    } else {
      # Conservative fuzzy match: only unambiguous contains matches.
      # Conservative fuzzy matching.
      # `grepl()` accepts a single pattern, so each alias must be checked
      # separately.  Vectorising the pattern (grepl(aa, z)) produces
      # "argument 'pattern' has length > 1" warnings and may ignore aliases.
      cand <- which(vapply(norm, function(z) {
        if (!nzchar(z)) return(FALSE)
        aa2 <- aa[nzchar(aa)]
        if (!length(aa2)) return(FALSE)

        any(vapply(aa2, function(a) {
          # Very short aliases (e.g. "id", "x", "y") are useful for exact
          # matching above but are too ambiguous for substring matching.
          if (nchar(a) < 3L || nchar(z) < 3L) return(FALSE)
          grepl(a, z, fixed = TRUE) || grepl(z, a, fixed = TRUE)
        }, logical(1)))
      }, logical(1)))

      if(length(cand)==1) out[field] <- nms[cand]
    }
  }
  out
}

.r4vn_epi_template_info <- function(template_id) {
  reg <- .r4vn_epi_template_registry()
  if(!template_id %in% names(reg)) stop("Unknown template id: ",template_id,call.=FALSE)
  reg[[template_id]]
}

.r4vn_epi_template_path <- function(template_id) {
  info <- .r4vn_epi_template_info(template_id)
  p <- system.file("extdata","epitool_templates",info$file,package="R4VN")
  if(nzchar(p) && file.exists(p)) return(p)
  # Development fallback when running with devtools::load_all().
  candidates <- c(
    file.path("inst","extdata","epitool_templates",info$file),
    file.path(getwd(),"inst","extdata","epitool_templates",info$file)
  )
  p2 <- candidates[file.exists(candidates)]
  if(length(p2)) normalizePath(p2[1],winslash="/") else ""
}

.r4vn_epi_read_tabular <- function(path, sheet=NULL) {
  ext <- tolower(tools::file_ext(path))
  if(ext=="csv") {
    x <- tryCatch(utils::read.csv(path,check.names=FALSE,stringsAsFactors=FALSE,fileEncoding="UTF-8-BOM"),
                  error=function(e) utils::read.csv(path,check.names=FALSE,stringsAsFactors=FALSE))
    return(x)
  }
  if(ext %in% c("xlsx","xls")) {
    if(!requireNamespace("readxl",quietly=TRUE)) stop("Excel import requires the optional package `readxl`.",call.=FALSE)
    return(as.data.frame(readxl::read_excel(path,sheet=if(is.null(sheet))1 else sheet),check.names=FALSE))
  }
  if(ext=="rds") return(readRDS(path))
  if(ext %in% c("dta","sav","zsav")) {
    if(!requireNamespace("haven",quietly=TRUE)) stop("Stata/SPSS import requires the optional package `haven`.",call.=FALSE)
    if(ext=="dta") return(as.data.frame(haven::read_dta(path),check.names=FALSE))
    return(as.data.frame(haven::read_sav(path),check.names=FALSE))
  }
  stop("Unsupported tabular file. Use Excel, CSV, RDS, Stata .dta, or SPSS .sav.",call.=FALSE)
}

.r4vn_epi_read_spatial <- function(path) {
  if(!requireNamespace("sf",quietly=TRUE)) stop("Spatial boundary import requires the optional package `sf`.",call.=FALSE)
  ext <- tolower(tools::file_ext(path))
  if(ext=="zip") {
    td <- tempfile("epitool_shape_"); dir.create(td)
    utils::unzip(path,exdir=td)
    shp <- list.files(td,pattern="\\.shp$",full.names=TRUE,ignore.case=TRUE)
    if(!length(shp)) stop("The ZIP file does not contain a .shp file.",call.=FALSE)
    return(sf::st_read(shp[1],quiet=TRUE,stringsAsFactors=FALSE))
  }
  if(ext %in% c("geojson","json","gpkg","kml","shp")) {
    return(sf::st_read(path,quiet=TRUE,stringsAsFactors=FALSE))
  }
  stop("Unsupported spatial file. Use GeoPackage, GeoJSON, KML, SHP, or a ZIP containing a shapefile.",call.=FALSE)
}

.r4vn_epi_apply_mapping <- function(data,mapping,keep_original=TRUE) {
  if(is.null(mapping)||!length(mapping)) return(data)
  out <- data
  for(target in names(mapping)) {
    src <- mapping[[target]]
    if(is.null(src)||is.na(src)||!nzchar(src)||!src%in%names(data)) next
    if(target==src) next
    if(keep_original || !target%in%names(out)) out[[target]] <- data[[src]]
    else out[[target]] <- data[[src]]
  }
  out
}

.r4vn_epi_validate_import <- function(data,template_id,mapping=NULL) {
  info <- .r4vn_epi_template_info(template_id)
  if(!is.data.frame(data)) stop("Imported object is not a data frame.",call.=FALSE)
  map <- if(is.null(mapping)) .r4vn_epi_guess_mapping(data,template_id) else mapping
  d <- .r4vn_epi_apply_mapping(data,map)
  issues <- data.frame(Field=character(),Issue=character(),Severity=character(),N=integer(),stringsAsFactors=FALSE)
  add <- function(field,issue,severity="Warning",n=NA_integer_) {
    issues <<- rbind(issues,data.frame(Field=field,Issue=issue,Severity=severity,N=as.integer(n),stringsAsFactors=FALSE))
  }
  for(f in info$required) if(!f%in%names(d)) add(f,"Required field is not mapped.","Critical",NA)
  for(f in info$recommended) if(!f%in%names(d)) add(f,"Recommended field is not mapped.","Info",NA)

  if("case_id"%in%names(d)) {
    x <- d$case_id
    miss <- sum(is.na(x)|!nzchar(trimws(as.character(x))))
    dup <- sum(!is.na(x)&duplicated(x))
    if(miss) add("case_id","Missing IDs.","Critical",miss)
    if(dup) add("case_id","Duplicate IDs.","Critical",dup)
  }
  for(f in intersect(c("onset_date","report_date","date"),names(d))) {
    z <- .r4vn_epi_safe_date(d[[f]])
    bad <- sum(is.na(z) & !is.na(d[[f]]) & nzchar(trimws(as.character(d[[f]]))))
    if(bad) add(f,"Values could not be interpreted as dates.","Warning",bad)
  }
  if(all(c("latitude","longitude")%in%names(d))) {
    lat <- suppressWarnings(as.numeric(d$latitude)); lon <- suppressWarnings(as.numeric(d$longitude))
    badnum <- sum((is.na(lat)&!is.na(d$latitude)) | (is.na(lon)&!is.na(d$longitude)))
    if(badnum) add("coordinates","Non-numeric coordinate values.","Critical",badnum)
    badrange <- sum((!is.na(lat)&(lat < -90|lat > 90)) | (!is.na(lon)&(lon < -180|lon > 180)))
    if(badrange) add("coordinates","Coordinates outside valid latitude/longitude ranges.","Critical",badrange)
    missing <- sum(is.na(lat)|is.na(lon))
    if(missing) add("coordinates","Records with missing coordinates.","Warning",missing)
    swapped <- sum(!is.na(lat)&!is.na(lon)&abs(lat)>90&abs(lon)<=90)
    if(swapped) add("coordinates","Some latitude/longitude values may be reversed.","Warning",swapped)
  }
  if("population"%in%names(d)) {
    pop <- suppressWarnings(as.numeric(d$population))
    bad <- sum(!is.na(pop)&pop<=0)
    if(bad) add("population","Population must be greater than zero.","Critical",bad)
  }
  if(!nrow(issues)) issues <- data.frame(Field="",Issue="Ready for analysis.",Severity="OK",N=0L,stringsAsFactors=FALSE)
  critical <- sum(issues$Severity=="Critical")
  warning <- sum(issues$Severity=="Warning")
  score <- max(0,100 - 15*critical - 4*warning)
  list(data=d,mapping=map,issues=issues,readiness=score,critical=critical,warning=warning)
}

.r4vn_epi_template_download_handler <- function(template_id) {
  shiny::downloadHandler(
    filename=function() .r4vn_epi_template_info(template_id)$file,
    content=function(file) {
      src <- .r4vn_epi_template_path(template_id)
      if(!nzchar(src)||!file.exists(src)) stop("Bundled template was not found.",call.=FALSE)
      file.copy(src,file,overwrite=TRUE)
    }
  )
}

.r4vn_epi_import_card_ui <- function(id,title,template_id,
                                     accept=c(".xlsx",".xls",".csv",".rds",".dta",".sav")) {
  ns <- shiny::NS(id)
  info <- .r4vn_epi_template_info(template_id)
  shiny::div(class="epi-upload-card",
    shiny::h4(title),
    shiny::p("Upload your existing file, or start from the EpiTool template."),
    shiny::fileInput(ns("file"),NULL,accept=accept,buttonLabel="Upload file",placeholder="No file selected"),
    shiny::div(class="epi-inline-actions",
      shiny::downloadButton(ns("template"),"Download template",class="btn-outline-primary"),
      shiny::actionButton(ns("example"),"Load example",class="btn-outline-secondary")
    ),
    shiny::tags$small(paste0("Required: ",paste(info$required,collapse=", "),
                             if(length(info$recommended)) paste0(" \u00b7 Recommended: ",paste(info$recommended,collapse=", ")) else ""))
  )
}