R/misc.R

In msberends/certedata: Tools for Data Analysis at Certe

# ==================================================================== #
# TITLE                                                                #
# Tools for Data Analysis at Certe                                     #
#                                                                      #
# AUTHORS                                                              #
# Berends MS (m.berends@certe.nl)                                      #
# Meijer BC (b.meijer@certe.nl)                                        #
# Hassing EEA (e.hassing@certe.nl)                                     #
#                                                                      #
# COPYRIGHT                                                            #
# (c) 2019 Certe Medische diagnostiek & advies - https://www.certe.nl  #
#                                                                      #
# LICENCE                                                              #
# This R package is free software; you can redistribute it and/or      #
# modify it under the terms of the GNU General Public License          #
# version 2.0, as published by the Free Software Foundation.           #
# This R package is distributed in the hope that it will be useful,    #
# but WITHOUT ANY WARRANTY; without even the implied warranty of       #
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the         #
# GNU General Public License for more details.                         #
# ==================================================================== #

"%like%" <- AMR::`%like%`

#' @inherit base::identical
#' @rdname equalsexact
#' @export
`%===%` <- function(x, y) {
  if (is.na(x)) {
    x <- NA_character_
  }
  if (is.na(y)) {
    y <- NA_character_
  }
  base::identical(x, y)
}

# @export
# @noRd
# `<-` = function(...) {
#
#
#   eval.parent(
#     replace(
#       match.call(),
#       1,
#       list(base::`<-`)))
#
#   if (getOption("keep.history", TRUE)
#       & interactive()
#       & environmentName(parent.frame()) == "R_GlobalEnv") {
#     # only save timestamp when set in options, in interactive mode and in global env.
#     objectname <- as.character(match.call())[2]
#     write(
#       x = paste(
#         objectname,
#         as.double(Sys.time()),
#         as.double(object.size(get(objectname))),
#         paste(class(get(objectname)), collapse = "/"),
#         NROW(get(objectname)),
#         NCOL(get(objectname)),
#         Sys.getenv("R_USERNAME"),
#         sep = ","),
#       file = ".Rhistory_obj",
#       append = TRUE)
#   }
# }

# Historie van object
#
# Van alle objecten worden timestamps opgeslagen in het bestand \code{.Rhistory_obj}, wanneer \code{options(keep.history = TRUE)} gebruikt is. Met deze functie kan de historie van een object bekeken worden.
# @param object R object
# @export
history <- function(target_object) {
  target_object <- deparse(substitute(target_object))
  if (getOption("keep.history", TRUE) & file.exists(".Rhistory_obj")) {
    con = file(".Rhistory_obj")
    lines <- readLines(con = con, warn = FALSE, encoding = "UTF-8")
    close(con)
    target_lines <- lines[grepl(paste0("^(", target_object, "),"), lines)]
    if (length(target_lines) > 0) {
      cat("History of object", target_object, '\n\n')
      output <- data.frame(action = character(0),
                           timestamp = character(0),
                           size = character(0),
                           class = character(0),
                           dimensions = character(0))
      for (i in 1:length(target_lines)) {
        elem <- unlist(strsplit(target_lines[i], ","))
        if (i == 1) {
          action <- paste("Created by", elem[7], "on")
        } else {
          action <- paste("Modified by", elem[7], "on")
        }
        output <- rbind(output,
                        data.frame(action = action,
                                   timestamp = as.POSIXct(origin = "1970-01-01", x = as.double(elem[2])),
                                   size = size_humanreadable(elem[3]),
                                   class = elem[4],
                                   dimensions = paste(elem[5], "x", elem[6])))
      }
      colnames(output) <- c(' ', '  ', '  Object size', '  Object class', '  Object dimensions')
      print(output,
            header = FALSE,
            row.names = FALSE,
            col.names = TRUE,
            quote = FALSE)
    } else {
      cat("No history available for this object.")
    }
  }
}

#' Selecteren van een element
#'
#' Selecteert een element uit een data.frame, list of andere vector. Dit kan gebruikt worden om van een list iedere waarde van names(list) te retourneren.
#' @param .data Een data.frame, list, matrix, of vector van tekst of getallen.
#' @param e Standaard is \code{1}. Het te selecteren element. Ondersteunt tidyverse-achtige quasiquotation.
#' @export
#' @examples
#' \dontrun{
#'
#' df %>% plot2(...) %>% element(data) # gelijk aan: plot2(df, ...)$data
#' df %>% element(1:3) # gelijk aan: df %>% select(1:3)
#'
#' LETTERS[1:10] %>% element(1:5)
#'
#' df %>% plot2() %>% names()
#' [1] "data"        "layers"      "scales"      "mapping"     "theme"
#'     "coordinates" "facet"       "plot_env"    "labels"

#' df %>% plot2() %>% element(mapping)
#' * fill  -> zkhgroep_locatie
#' * group -> zkhgroep_locatie
#' * x     -> testnaam
#' * y     -> aantal
#' }
element <- function(.data, e = 1) {
  e_txt <- deparse(substitute(e))
  if (!is.numeric(as.double2(e_txt)) & length(e_txt) == 1) {
    e <- e_txt
  }
  if (is.data.frame(.data) | is.matrix(.data)) {
    .data[, e]
  } else if (is.list(.data)) {
    .data[[e]]
  } else {
    .data[e]
  }
}

#' Referenties van geladen pakketten
#'
#' Print een lijst met alle geladen pakketten als wetenschappelijke referenties.
#' @param url Standaard is \code{FALSE}. Print ook de URL van het pakket als deze opgegeven is.
#' @param rstudio Standaard is \code{TRUE}. Print ook de referentie van RStudio.
#' @keywords cit url citation ref referentie rstudio
#' @export
#' @return Tekst (lijst)
citations <- function(url = FALSE, rstudio = TRUE) {
  if (rstudio == TRUE) {
    ref.rstudio <- rstudioapi::versionInfo()$citation
    if (url == FALSE) {
      ref.rstudio$url = NULL;
    }
    print(ref.rstudio, style = 'text')
    cat('\n')
  }

  referentielijst <- c('base', names(sessionInfo()$otherPkgs))
  for (i in 1:length(referentielijst)) {
    ref <- citation(referentielijst[i])
    if (url == FALSE) {
      ref$url = NULL;
    }
    print(ref, style = 'text')
    cat('\n')
  }
}

#' Vervangen van "NULL" door NA in een dataframe
#'
#' Retourneert een dataframe waarin alle velden met \code{"NULL"} vervangen zijn door \code{NA}.
#' @param tbl Dataframe met gegevens.
#' @keywords null na
#' @export
#' @return data.frame
#' @examples
#' \dontrun{
#'
#' tbl <- tbl_removeNULLs(tbl)
#' }
tbl_removeNULLs <- function(tbl) {
  tbl[, 1:length(tbl)][tbl[, 1:length(tbl)] == 'NULL'] <- NA
  tbl
}

#' Waarde tijdelijk opslaan in Global Environment
#'
#' Dit kan gebruikt worden in een dplyr-syntax om een waarde later in de syntax te herinneren. Werkt voor maximaal 5 waarden, die tijdelijk naar de Global Environment opgeslagen worden.
#' @rdname remember_recall
#' @param .data Tabel die na de functie weer ongewijzigd doorgegeven wordt.
#' @param tmp_1,tmp_2,tmp_3,tmp_4,tmp_5 Standaard is \code{NA}. Waarde die onthouden moet worden. Kan ook een functie zijn die over \code{.data} berekend wordt.
#' @param tmp Standaard is \code{1}. Waarde die opgehaald moet worden.
#' @param delete Standaard is \code{TRUE}. Waarde na \code{recall()} weer verwijderen.
#' @details Waarden kunnen geslagen worden met \strong{\code{remember()}} en opgehaald (en verwijderd) worden met \strong{\code{recall()}}.
#' @export
#'
#' @examples
#' \dontrun{
#'  tbl %>%
#'    filter(...) %>%
#'    remember(nrow(.)) %>%
#'    group_by(...) %>%
#'    summarise(...) %>%
#'    plot2(title = "Test",
#'    subtitle = paste("n =",
#'                     recall()))
#'
#'  tbl %>%
#'    filter(...) %>%
#'    remember(tmp_1 = nrow(.)) %>%
#'    group_by(...) %>%
#'    summarise(...) %>%
#'    plot2(title = "Test",
#'    subtitle = paste("n =",
#'                     recall(tmp = 1)))
#' }
remember <- function(.data,
                     tmp_1 = NA,
                     tmp_2 = NA,
                     tmp_3 = NA,
                     tmp_4 = NA,
                     tmp_5 = NA) {

  if (!is.na(tmp_1)) {
    if (is.function(tmp_1)) {
      tmp_1.real <- tmp_1(.data)
    } else {
      tmp_1.real <- tmp_1
    }
    tmp_1_ <<- tmp_1.real
  }

  if (!is.na(tmp_2)) {
    if (is.function(tmp_2)) {
      tmp_2.real <- tmp_2(.data)
    } else {
      tmp_2.real <- tmp_2
    }
    tmp_2_ <<- tmp_2.real
  }

  if (!is.na(tmp_3)) {
    if (is.function(tmp_3)) {
      tmp_3.real <- tmp_3(.data)
    } else {
      tmp_3.real <- tmp_3
    }
    tmp_3_ <<- tmp_3.real
  }

  if (!is.na(tmp_4)) {
    if (is.function(tmp_4)) {
      tmp_4.real <- tmp_4(.data)
    } else {
      tmp_4.real <- tmp_4
    }
    tmp_4_ <<- tmp_4.real
  }

  if (!is.na(tmp_5)) {
    if (is.function(tmp_5)) {
      tmp_5.real <- tmp_5(.data)
    } else {
      tmp_5.real <- tmp_5
    }
    tmp_5_ <<- tmp_5.real
  }

  # data retourneren om hem in dplyr te kunnen gebruiken
  .data
}


#' @rdname remember_recall
#' @export
recall <- function(tmp = 1, delete = TRUE) {

  if (!tmp %in% c(1:5)) {
    stop('`tmp` must be between 1 and 5.')
  }

  tmp_val <- paste0("tmp_", tmp, "_") %>% as.name()
  tmp_val.local <- eval(tmp_val)

  if (delete == TRUE) {
    rm(list = paste0("tmp_", tmp, "_"), envir = .GlobalEnv)
  }
  tmp_val.local
}

#' Alfanumerieke ID
#'
#' Hiermee kan een alfanumerieke ID gemaakt worden (waarden \code{0}-\code{9} en \code{a}-\code{f}).
#' @param size Lengte van de ID.
#' @export
#' @details De kans dat 2 ID's overeenkomen bij verschillende waarden van \code{size}:\cr
#' 1: 1 op 16 \cr
#' 2: 1 op 256 \cr
#' 3: 1 op 4.096 \cr
#' 4: 1 op 65.536 \cr
#' 5: 1 op 1.048.576 \cr
#' 6: 1 op 16.777.216 \cr
#' ...
ID <- function(size = 6) {
  chars <- c(0:9, letters[1:6])
  output <- character(0)
  for (i in 1:size) {
    output <- c(output, sample(chars, size = 1))
  }
  concat(output)
}

export.query <- function(object, filename) {
  q <- suppressMessages(qry(object))
  if (!filename %like% '[.]sql$') {
    filename <- paste0(filename, '.sql')
  }
  filename <- gsub("[?|<>|*]", "", filename)
  write(q, file = filename, ncolumns = 1, append = FALSE)
}

#' Exporteren naar R-structuur
#'
#' Hiermee kan een tabel naar nieuw R-bestand geschreven worden. Dit bestand is gecomprimeerd. Gebruik \code{\link{import.R}} om het weer te gebruiken.
#' @param tbl Tabel met gegevens.
#' @param filename Standaard is \code{NA}, waarmee de naam van \code{tbl} gebruikt wordt. De (nieuwe) bestandsnaam van het R-bestand.
#' @keywords gegevens exporteren export
#' @export
#' @examples
#' \dontrun{
#' export.R(starwars)
#' starwars2 <- import.R("starwars.rds")
#' identical(starwars, starwars2) # TRUE
#' }
#' @source \code{\link{saveRDS}}
export.R <- function(tbl, filename = NA) {

  if (is.na(filename)) {
    filename <- deparse(substitute(tbl))
    if (filename == ".") {
      filename <- "tbl"
    }
  }
  if (!filename %like% '[.]rds$') {
    filename <- paste0(filename, '.rds')
  }

  filename <- gsub("[?|<>|*]", "", filename)

  saveRDS(tbl, file = filename, compress = TRUE, ascii = FALSE)
  if (file.exists(filename)) {
    message(paste0('Exported as `', filename, '` - ', file.size(filename) %>% size_humanreadable(), '.'))
  } else {
    stop('Error while saving `', filename, '`.')
  }

  if (!is.null(suppressMessages(qry(tbl)))) {
    filename_qry <- gsub('.rds', '.sql', filename, fixed = TRUE)
    export.query(tbl, filename_qry)
    message(paste0('Query exported as `', filename_qry, '`.'))
  }

}

#' Exporteren naar Excel
#'
#' Hiermee kan een tabel naar nieuw Excel-bestand geschreven worden.
#' @param tbl Tabel met gegevens.
#' @param filename Standaard is \code{NA}, waarmee de naam van \code{tbl} gebruikt wordt. De (nieuwe) bestandsnaam van het Excel-bestand.
#' @inheritParams openxlsx::addWorksheet
#' @inheritParams openxlsx::writeData
#' @inheritParams openxlsx::freezePane
#' @keywords gegevens exporteren export
#' @export
#'
export.excel <- function(tbl,
                         filename = NA, 
                         sheetName = "Blad1", 
                         colNames = TRUE, 
                         firstRow = colNames, ...) {

  tblname <- as.character(match.call())[2]
  if (tblname == ".") {
    tblname <- "tbl"
  }

  if (!filename %like% '[.]xlsx$') {
    if (is.na(filename)) {
      filename <- tblname
    }
    filename <- paste0(filename, '.xlsx')
  }
  
  filename <- gsub("[?|<>|*]", "", filename)
  
  newfile <- rio::export(x = tbl,
                         file = filename,
                         sheetName = sheetName,
                         colNames = colNames,
                         firstRow = firstRow,
                         colWidths = "auto",
                         creator = unname(Sys.info()['user']),
                         ...)
  
  if (file.exists(newfile)) {
    message(paste0('Exported as `', filename, '` - ', file.size(newfile) %>% size_humanreadable(), '.'))
  } else {
    stop('Error while saving `', filename, '`.')
  }

  if (!is.null(suppressMessages(qry(tbl)))) {
    filename_qry <- gsub('.xlsx', '.sql', filename, fixed = TRUE)
    export.query(tbl, filename_qry)
    message(paste0('Query exported as `', filename_qry, '`.'))
  }
}

#' Exporteren naar CSV-structuur
#'
#' Hiermee kan een tabel naar nieuw CSV-bestand geschreven worden. \code{export.csv} schrijft een bestand als standaard CSV (komma-gescheiden), \code{export.csv2} schrijft een bestand als een West-Europese CSV (puntkomma-gescheiden) die ook door Nederlandse versies van Excel gelezen kan worden.
#' @rdname export.csv
#' @param tbl Tabel met gegevens.
#' @param filename Standaard is \code{NA}, waarmee de naam van \code{tbl} gebruikt wordt. De (nieuwe) bestandsnaam van het CSV-bestand.
#' @details Intern wordt de functie \code{\link{write.table}} gebruikt, maar met deze exportfuncties wordt \code{NA} geëxporteerd als \code{""} (in plaats van \code{"NA"}) en worden rijnamen niet geëxporteerd. Ook forceert het UTF-8-encoding, zodat diacritische tekens juist ondersteund worden (zoals accenten en trema's).
#' @keywords gegevens exporteren export
#' @export
export.csv <- function(tbl, filename = NA) {

  tblname <- as.character(match.call())[2]
  if (tblname == ".") {
    tblname <- "tbl"
  }

  if (!filename %like% '[.]csv$') {
    if (is.na(filename)) {
      filename <- tblname
    }
    filename <- paste0(filename, '.csv')
  }

  filename <- gsub("[?|<>|*]", "", filename)

  write.table(tbl,
              file = filename,
              append = FALSE,
              quote = TRUE,
              sep = ",",
              eol = "\n",
              na = "",
              dec = ".",
              row.names = FALSE,
              col.names = TRUE,
              qmethod = "double",
              fileEncoding = "UTF-8")

  if (file.exists(filename)) {
    message(paste0('Exported as `', filename, '` - ', file.size(filename) %>% size_humanreadable(), '.'))
  } else {
    stop('Error while saving `', filename, '`.')
  }

  if (!is.null(suppressMessages(qry(tbl)))) {
    filename_qry <- gsub('csv', '.sql', filename, fixed = TRUE)
    export.query(tbl, filename_qry)
    message(paste0('Query exported as `', filename_qry, '`.'))
  }
}

#' @rdname export.csv
#' @export
export.csv2 <- function(tbl, filename = NA) {

  tblname <- as.character(match.call())[2]
  if (tblname == ".") {
    tblname <- "tbl"
  }

  if (!filename %like% '[.]csv$') {
    if (is.na(filename)) {
      filename <- tblname
    }
    filename <- paste0(filename, '.csv')
  }

  filename <- gsub("[?|<>|*]", "", filename)

  write.table(tbl,
              file = filename,
              append = FALSE,
              quote = TRUE,
              sep = ";",
              eol = "\n",
              na = "",
              dec = ",",
              row.names = FALSE,
              col.names = TRUE,
              qmethod = "double",
              fileEncoding = "UTF-8")

  if (file.exists(filename)) {
    message(paste0('Exported as `', filename, '` - ', file.size(filename) %>% size_humanreadable(), '.'))
  } else {
    stop('Error while saving `', filename, '`.')
  }

  if (!is.null(suppressMessages(qry(tbl)))) {
    filename_qry <- gsub('csv', '.sql', filename, fixed = TRUE)
    export.query(tbl, filename_qry)
    message(paste0('Query exported as `', filename_qry, '`.'))
  }
}

#' Exporteren naar klembord
#'
#' Hiermee wordt een \code{data.frame} uit R naar het klembord geëxporteerd als tekst. De maximale hoeveelheid data die geëxporteerd kan worden is evenveel als de beschikbare hoeveelheid RAM-geheugen.
#' @param tbl Tabel die naar het klembord moet worden gekopieerd.
#' @param sep Standaard is \code{"\\t"}. Het scheidingsteken waardoor de velden in elke rij gescheiden worden.
#' @param na Standaard is \code{""}. Teken voor lege waarden. Geldt niet wanneer \code{structure.R = TRUE}.
#' @param header Standaard is \code{TRUE}. Kolomnamen als koptekst exporteren.
#' @param quote Standaard is \code{FALSE}. Aanhalingsteken gebruiken.
#' @param format.NL Standaard is \code{TRUE}. Hiermee worden getallen met een komma als decimaal teken geëxporteerd.
#' @param structure.R Standaard is \code{FALSE}. Dit gebruikt \code{\link{dump}} om de tabel te exporteren in R-structuur, met behoud van alle tabeleigenschappen.
#' @keywords gegevens importeren import
#' @export
export.clipboard <- function(tbl, sep = '\t', na = "", header = TRUE, quote = FALSE, format.NL = Sys.isdecimalcomma(), structure.R = FALSE) {
  if (structure.R == TRUE) {
    if (!is.character(tbl)) {
      stop('`tbl` must be a character when exporting as R structure.')
    }
    size <- get(tbl) %>%
      object.size() %>%
      formatC(format = 'd') %>%
      as.integer()
    dump(tbl, file = paste0("clipboard-", size * 1.25))
  } else {
    size <- tbl %>%
      object.size() %>%
      formatC(format = 'd') %>%
      as.integer()
    if (format.NL == TRUE) {
      decteken <- ','
    } else {
      decteken <- '.'
    }
    if (!is.data.frame(tbl)) {
      header <- FALSE
    }
    # maximale grootte van klembord instellen als 125% van de grootte van tbl
    write.table(x = tbl,
                file = paste0("clipboard-", size * 1.25),
                sep = sep,
                na = as.character(na),
                row.names = FALSE,
                col.names = header,
                dec = decteken,
                quote = quote)
  }
  message(
    paste0(
      'Exported to clipboard: ',
      size %>% size_humanreadable(),
      " (",
      format2(NROW(tbl)),
      " obs. of ",
      format2(NCOL(tbl)),
      ' variables)'
    )
  )
}

#' Importeren van R-structuur
#'
#' Hiermee wordt een data uit een RDS-bestand in R geïmporteerd, nadat deze geëxporteerd was met de functie \code{\link{export.R}}.
#' @param filename De bestandsnaam van het RDS-bestand.
#' @keywords gegevens importeren import
#' @export
#' @examples
#' \dontrun{
#' export.R(starwars)
#' starwars2 <- import.R("starwars.rds")
#' identical(starwars, starwars2) # TRUE
#' }
#' @source \code{\link{readRDS}}
import.R <- function(filename) {
  df <- readRDS(filename)
  message(
    paste0(
      "Size of dataset: ",
      object.size(df) %>% size_humanreadable(),
      " (",
      format2(NROW(df)),
      " obs. of ",
      format2(NCOL(df)),
      ' variables)'
    )
  )
  df
}

#' Importeren van Excel-bestand
#'
#' Hiermee wordt een tabblad uit een Excel-bestand in R geïmporteerd als \code{data.frame}.
#' @param file Locatie van het Excel-bestand. Wanneer een bestandsnaam opgegeven is, wordt de omgevingsvariabele \code{R_REFMAP} gebruikt als map. Bij Windows-locaties moet \code{\\} vervangen worden door \code{\\\\}.
#' @param sheet Standaard is \code{NA}. Het blad dat geïmporteerd moet worden.
#' @inheritParams tbl_guess_columns
#' @keywords gegevens importeren import excel
#' @export
#' @return data.frame
import.excel <- function(file,
                         sheet = 1,
                         auto_transform = TRUE,
                         datenames = 'en',
                         dateformat = '%Y-%m-%d',
                         timeformat = '%H:%M',
                         decimal.mark = '.',
                         big.mark = '',
                         timezone = 'UTC',
                         na = c("", "NULL", "NA")) {

  file <- gsub('\\', '/', file, fixed = TRUE)

  if (!grepl(':/', file, fixed = TRUE)) {
    file <- .R_REFMAP(file)
  }

  if (!file.exists(file)) {
    stop('File does not exist: ', file)
  }

  bladen <- readxl::excel_sheets(file)
  # alles importeren en melding ongeldige kolomwaarden onderdrukken
  bladen.lijst <- suppressWarnings(lapply(readxl::excel_sheets(file), readxl::read_excel, path = file))

  if (is.na(sheet)) {
    if (length(bladen) == 1) {
      blad <- bladen
      n <- 1
    } else {
      cat('Which sheet should be imported?\n\n')
      for (i in 1:length(bladen)) {
        grootte <- object.size(bladen.lijst[[i]]) %>% size_humanreadable()
        message(paste0('[',
                   i,
                   '] ',
                   bladen[i],
                   ' (',
                   grootte,
                   '; ',
                   format2(NROW(bladen.lijst[[i]])),
                   ' obs. of ',
                   format2(NCOL(bladen.lijst[[i]])),
                   ' variables)'
        ))
      }
      n <- NA
      while (is.na(n)) {
        n <- readline(paste0('\nSheet (1-', length(bladen), '): '))
        n <- ifelse(grepl("\\D", n), NA, as.integer(n))
        if (is.na(n)) {
          # breaks when hit enter
          return('\nNo data imported.\n')
        }
      }
      blad <- bladen[n]
    }
  } else {
    n <- sheet
    blad <- bladen[n]
  }

  if (!n %in% c(1:length(bladen))) {
    stop('No valid sheet. Pick a number between 1 and ', length(bladen), '.')
  }

  if (auto_transform == TRUE) {
    tbl_guess_columns(bladen.lijst[[n]],
                      datenames = datenames,
                      dateformat = dateformat,
                      timeformat = timeformat,
                      decimal.mark = decimal.mark,
                      big.mark = big.mark,
                      timezone = timezone,
                      na = na)
  } else {
    bladen.lijst[[n]]
  }

}

#' Importeren van bestand
#'
#' @description Hiermee wordt (MMB-)data (bijv. aanvraaggegevens of doorlooptijden) geïmporteerd van een bestand. De functies \code{import.csv}, \code{import.csv2} en \code{import.tsv} zijn hier wrappers van.
#'
#' Gebruik alleen een bestandsnaam om de omgevingsvariabele \code{R_REFMAP} te gebruiken als map. Het transformeert datumkolommen naar geldige datums en alle booleankolommen naar geldige logicals. Daarnaast worden alle velden die leeg zijn of \code{"NULL"} bevatten getransformeerd naar \code{NA}.
#' @rdname import
#' @param file Locatie van het bestand. Wanneer een bestandsnaam opgegeven is, wordt de omgevingsvariabele \code{R_REFMAP} gebruikt als map. Bij Windows-locaties moet \code{\\} vervangen worden door \code{\\\\}.
#' @param sep Standaard is \code{"auto"}, waardoor het sep bepaald wordt op basis van de bestandsextensie. Het scheidingsteken waardoor de velden in elke rij gescheiden worden.
#' @param info Standaard is \code{TRUE}. Printen van voortgang van importeren en de uiteindelijke datagrootte met aantal rijen en kolommen.
#' @param startrow Standaard is \code{1}. Eerste rij die geïmporteerd moet worden.
#' @param headerrow Standaard is \code{1}. De rij waarin de koppen zich bevinden. Gebruik \code{headerrow = NA} of \code{headerrow = 0} om geen koppen te importeren.
#' @param datenames Standaard is \code{"en"}. Taal van de datenames (zoals weekdagen en maanden).
#' @param dateformat Standaard is \code{"\%Y-\%m-\%d"}. Accepteert ook Excel-formaten, zoals \code{"dd-mm-yy"} en \code{"dd-mm-jjjj"}.
#' @param timeformat Standaard is \code{"\%H:\%M"}. Accepteert ook Excel-formaten, zoals \code{"HH:MM:SS"}.
#' @param decimal.mark Standaard is \code{"."}. Scheidingsteken voor decimale getallen.
#' @param big.mark Standaard is \code{""}. Groepsteken voor getallen, zoals 1.000.000.
#' @param na Standaard is \code{c("", "NULL", "NA")}. Waarden die vertaald moeten worden als \code{NA}.
#' @param ... Parameters die doorgegeven worden aan \code{import}.
#' @keywords gegevens importeren import
#' @export
#' @return data.frame
#' @seealso \code{\link{import}}, \code{\link{import.csv}}, \code{\link{import.csv2}}, \code{\link{import.tsv}}, \code{\link{date_generic}}
#' @examples
#' \dontrun{
#' mmb <- import.csv("2016.csv") # met komma als sep en punt als decimal.mark
#' mmb <- import.csv2("2016.csv") # met puntkomma als sep en komma als decimal.mark
#' mmb <- import.tsv("2016.tsv")
#' mmb <- import("2016.txt", sep = "|")
#'
#' (met forward slash, moet enkel)
#' mmb <- import.csv("Z:/Data_Management/Data-analyse/Totaalanalyse MMB/2016.csv")
#'
#' (met backslash, Windows-standaard, moet wel dubbel)
#' mmb <- import.csv("Z:\\Data_Management\\Data-analyse\\Totaalanalyse MMB\\2016.csv")
#' }
import <- function(file,
                   sep = 'auto',
                   info = TRUE,
                   startrow = 1,
                   headerrow = 1,
                   datenames = 'en',
                   dateformat = '%Y-%m-%d',
                   timeformat = '%H:%M',
                   decimal.mark = '.',
                   big.mark = '',
                   na = c("", "NULL", "NA")) {

  dateformat <- date_generic(dateformat)
  timeformat <- date_generic(timeformat)
  file <- gsub('\\', '/', file, fixed = TRUE)

  if (!grepl(':/', file, fixed = TRUE)) {
    file <- .R_REFMAP(file)
  }

  if (!file.exists(file)) {
    stop('File does not exist: ', file, '.')
  }

  if (sep == 'auto') {
    if (grepl('(.csv)$', file)) {
      sep <- ','
    } else if (grepl('(.tsv)$', file)) {
      sep <- '\t'
    } else {
      stop('Separator sign (sep) cannot be determined.')
    }
  }

  if (is.na(headerrow) | headerrow == 0) {
    koppen <- FALSE
    headerrow <- startrow
  } else {
    koppen <- TRUE
    if (headerrow < startrow) {
      stop('`headerrow` (', headerrow, ') cannot be lower than `startrow` (', startrow, ').')
    }
    startrow <- max(1, headerrow - startrow)
  }

  if (info == TRUE) {
    cat(paste0('Importing "', gsub('/', '\\', file, fixed = TRUE), '"...\n'))
  }

  suppressWarnings(data <- readr::read_delim(
    file,
    delim = sep,
    escape_double = FALSE,
    trim_ws = TRUE,
    skip = max(0, headerrow - 1),
    na = c("", "NULL", "NA"),
    locale = readr::locale(date_names = datenames,
                           date_format = dateformat,
                           time_format = timeformat,
                           decimal_mark = decimal.mark,
                           grouping_mark = big.mark,
                           encoding = "UTF-8",
                           asciify = FALSE),
    progress = info,
    col_names = koppen,
    col_types = readr::cols(
      patidnb = readr::col_character(),
      pat_molis = readr::col_character(),
      primair_steriel = readr::col_logical(),
      is_poli = readr::col_logical(),
      is_seh = readr::col_logical(),
      is_klinisch = readr::col_logical(),
      is_ic = readr::col_logical(),
      is_bwc = readr::col_logical(),
      eerste_isolaat = readr::col_logical(),
      eerste_isolaat_gewogen = readr::col_logical(),
      eerste_isolaat_met_screening = readr::col_logical(),
      eerste_isolaat_zonder_screening = readr::col_logical(),
      eerste_isolaat_gewogen_zonder_screening = readr::col_logical(),
      eerste_brmo_ooit = readr::col_logical(),
      eerste_urineisolaat = readr::col_logical(),
      eerste_urineisolaat_gewogen = readr::col_logical(),
      eerste_respisolaat = readr::col_logical(),
      eerste_respisolaat_gewogen = readr::col_logical(),
      eerste_pusisolaat = readr::col_logical(),
      eerste_pusisolaat_gewogen = readr::col_logical(),
      eerste_bloedisolaat = readr::col_logical(),
      eerste_bloedisolaat_gewogen = readr::col_logical(),
      eerste_liquorisolaat = readr::col_logical(),
      eerste_liquorisolaat_gewogen = readr::col_logical(),
      eerste_icu_isolaat = readr::col_logical(),
      eerste_icu_isolaat_gewogen = readr::col_logical(),
      bevat_brmo = readr::col_logical(),
      is_esbl = readr::col_logical(),
      is_mrsa = readr::col_logical(),
      is_qare = readr::col_logical(),
      is_cre = readr::col_logical(),
      is_cra = readr::col_logical(),
      is_crab = readr::col_logical(),
      is_mrpa = readr::col_logical(),
      is_qara = readr::col_logical(),
      is_crs = readr::col_logical(),
      is_vre = readr::col_logical(),
      is_pvre = readr::col_logical(),
      is_prsp = readr::col_logical(),
      is_vrsp = readr::col_logical(),
      pathogeen_urinekweek = readr::col_logical(),
      pathogeen_bloedkweek = readr::col_logical(),
      pathogeen_bloedkweek_bacterie = readr::col_logical(),
      uur_in_transport = readr::col_double(),
      uur_modbac_tot_1e_rapport = readr::col_double(),
      uur_modbac_tot_def_rapport = readr::col_double(),
      uur_modser_tot_1e_rapport = readr::col_double(),
      uur_modser_tot_def_rapport = readr::col_double(),
      uur_modserpre_tot_1e_rapport = readr::col_double(),
      uur_modserpre_tot_def_rapport = readr::col_double(),
      uur_modtb_tot_1e_rapport = readr::col_double(),
      uur_modtb_tot_def_rapport = readr::col_double(),
      uur_modvir_tot_1e_rapport = readr::col_double(),
      uur_modvir_tot_def_rapport = readr::col_double(),
      uur_naar_transport = readr::col_double(),
      uur_tot_1e_rapport = readr::col_double(),
      uur_tot_aanvullen = readr::col_double(),
      uur_tot_def_rapport = readr::col_double(),
      uur_tot_modbac = readr::col_double(),
      uur_tot_modser = readr::col_double(),
      uur_tot_modserpre = readr::col_double(),
      uur_tot_modtb = readr::col_double(),
      uur_tot_modvir = readr::col_double(),
      uur_tot_v1_max = readr::col_double(),
      uur_tot_v1_min = readr::col_double(),
      uur_tot_v2_max = readr::col_double(),
      uur_tot_v2_min = readr::col_double(),
      uur_tot_v3_max = readr::col_double(),
      uur_tot_v3_min = readr::col_double())
  ))

  if (startrow > 1) {
    # verliest anders kolomkoppen
    data <- data[startrow:nrow(data),]
  }

  message(
    paste0(
      "\nSize of dataset: ",
      object.size(data) %>% size_humanreadable(),
      " (",
      format2(NROW(data)),
      " obs. of ",
      format2(NCOL(data)),
      ' variables)'
    )
  )


  data
}

#' @rdname import
#' @export
import.csv <- function(file, ...) {
  if (!grepl('(.csv)$', file)) {
    file <- paste0(file, '.csv')
  }
  import(file,
         sep = ',',
         decimal.mark = '.',
         big.mark = '',
         ...)
}

#' @rdname import
#' @export
import.csv2 <- function(file, ...) {
  if (!grepl('(.csv)$', file)) {
    file <- paste0(file, '.csv')
  }
  import(file,
         sep = ';',
         decimal.mark = ',',
         big.mark = '.',
         datenames = 'nl',
         ...)
}

#' @rdname import
#' @export
import.tsv <- function(file, ...) {
  if (!grepl('(.tsv)$', file)) {
    file <- paste0(file, '.tsv')
  }
  import(file, sep = '\t', ...)
}

#' Importeren van klembord
#'
#' Hiermee wordt een tabel uit het klembord in R geïmporteerd als \code{data.frame}.
#' @param sep Standaard is \code{"\\t"}. Het scheidingsteken waardoor de velden in elke rij gescheiden worden.
#' @param header Standaard is \code{TRUE}. Koptekst als kolomnamen importeren.
#' @param na Standaard is \code{c("", "NA", "NULL")}. Waarden die als \code{NA} gelezen moeten worden.
#' @param format.NL Standaard is \code{TRUE}. Hiermee worden getallen met een komma als decimaal teken geïmporteerd.
#' @param startrow Standaard is \code{1}. Eerste rij die geïmporteerd moet worden.
#' @param ... Parameters die doorgegeven worden aan \code{\link{tbl_guess_columns}}.
#' @keywords gegevens importeren import
#' @export
#' @return data.frame
import.clipboard <- function(sep = '\t',
                             header = TRUE,
                             na = c("", "NA", "NULL"),
                             format.NL = Sys.isdecimalcomma(),
                             startrow = 1,
                             ...) {
  if (format.NL == TRUE) {
    decteken <- ','
  } else {
    decteken <- '.'
  }
  tabel <- tibble::as.tibble(
    read.table(file = 'clipboard',
               sep = sep,
               header = header,
               row.names = NULL,
               quote = '"',
               fill = TRUE,
               comment.char = '',
               strip.white = TRUE,
               dec = decteken,
               na.strings = na,
               # fileEncoding = 'UTF-8',
               encoding = 'UTF-8',
               stringsAsFactors = FALSE))
  if (startrow > 1) {
    # verliest anders kolomkoppen
    tabel <- tabel[startrow:nrow(tabel),]
  }
  colnames(tabel) <- gsub('[.]+', '_', colnames(tabel))
  for (i in 1:ncol(tabel)) {
    if (tabel %>% pull(i) %>% is.double2() %>% all()) {
      tabel[, i] <- tabel %>% pull(i) %>% as.double2()
    }
  }
  tbl_guess_columns(tabel, ...)
}

#' @inherit utils::choose.dir
#' @description Aangepaste functie om ook gebruik om macOS mogelijk te maken.
#' @source \url{http://grokbase.com/t/r/r-sig-mac/12bxhv5xcz/equivalent-of-choose-dir}
choose.dir <- function(default = "", caption = "Select folder") {
  if (Sys.info()['sysname'] == 'Windows') {
    return(utils::choose.dir(default = default, caption = caption))
  } else {
    system("osascript -e 'tell app \"R\" to POSIX path of (choose folder with prompt \"Choose Folder:\")' > /tmp/R_folder",
           intern = FALSE, ignore.stderr = TRUE)
    p <- system("cat /tmp/R_folder && rm -f /tmp/R_folder", intern = TRUE)
    return(ifelse(length(p), p, NA))
  }
}

#' Grootte van Global Environment
#'
#' Retourneert een tabel met de grootte in MB van alle elementen in het Global Environment.
#' @param min.MB Standaard is \code{1}. Alleen weergeven vanaf dit aantal MB's.
#' @export
size.env <- function(min.MB = 1) {
  tbl <- tibble(Name = character(0),
                Type = character(0),
                Size = character(0))
  tbl$Name <- tbl$Name %>% as.character()
  tbl$Type <- tbl$Type %>% as.character()
  tbl$Size <- tbl$Size %>% as.character()
  total <- 0

  for (obj in ls(.GlobalEnv)) {
    el.name <- obj %>% as.character()
    el.size <- object.size(get(obj)) %>% size_humanreadable()
    el.class <- get(obj) %>% class() %>% rev() %>% concat('->')
    total <- total + el.size
    if (el.size >= min.MB) {
      tbl <- tbl %>% tibble::add_row(Name = el.name, Type = el.class, Size = format(el.size, scientific = FALSE))
    }
  }

  tbl <- tbl %>% arrange(desc(Size))
  tbl$Size <- tbl$Size %>% format2()

  tbl <- tbl %>% tibble::add_row(Name = '', Type = '', Size = '--------+')
  tbl <- tbl %>% tibble::add_row(Name = '', Type = '', Size = format2(total))

  cat('Elementen met >=', format2(min.MB), 'MB:')
  print(knitr::kable(tbl, format = 'pandoc', align = c('l', 'l', 'r'), col.names = c('Element', 'Type', 'Grootte in MB')))
  cat('\n')
}

#' Levenshteinafstand berekenen
#'
#' Hiermee wordt het aantal verschillen tussen twee tekstreeksen berekend. Een insertie, deletie en substitutie tellen allen als 1. Dit volgt het algoritme van Levenshtein et al., 1965.
#' @param a Tekst a.
#' @param b Tekst b.
#' @param ignore Standaard is \code{c(" ", ".", ",", "<br>")}. Te negeren tekens in tekst \code{a} en tekst \code{b}.
#' @param info Standaard is \code{FALSE}. Print een specificatie van het aantal inserties, deleties en substituties.
#' @keywords adist levenshtein verschil tekst tekens
#' @seealso \code{\link{adist}}
#' @export diff.text
#' @return getal
#' @examples
#' \dontrun{
#'
#' diff.text("test", "testa") # = 1
#' diff.text("test", "vest")  # = 1
#' diff.text("test", "vespa") # = 3
#' }
diff.text <- function(a,
                      b,
                      ignore = c(" ", ":", "!", "?", ";", ".", ",", "<br>"),
                      info = FALSE) {

  a <- a %>%
    as.character() %>%
    gsub(paste0('([', concat(ignore, "]|["), '])'), '', .)
  b <- b %>%
    as.character() %>%
    gsub(paste0('([', concat(ignore, "]|["), '])'), '', .)

  if (info == TRUE) {
    cat('Deze tekens worden genegeerd:', toString(paste0('[', ignore, ']')), '\n')
    verschillen <- attributes(adist(a, b, fixed = TRUE, counts = TRUE))$counts
    cat('Aantal inserties:    ', verschillen[1], '\n')
    cat('Aantal deleties:     ', verschillen[2], '\n')
    cat('Aantal substituties: ', verschillen[3], '\n')
  }

  adist(a, b, fixed = TRUE) %>% as.integer()

}

#' Naam van input
#'
#' Vertaling van input naar tekst. Voorbeeld: \code{inputname(tbl1$x) = "tbl1$x"}.
#' @param x Inputfunctie of -tekst
#' @keywords input
#' @export
#'
inputname <- function(x) {
  # print omdat in geneste functies dit anders niet goed werkt
  deparse(substitute(x))
}

#' Extra lettertypen installeren
#'
#' Dit is nodig om Calibri te kunnen gebruiken, en Arial (voor PLOS One)
#' @keywords font lettertype
#' @export
#' @examples
#' \dontrun{
#' install.fonts()
#' }
#'
install.fonts <- function() {
  extrafont::font_import()
  message('You must now reload this package.')
}

#' Dit R-pakket updaten
#'
#' Hiermee wordt de laatste versie van \code{certedata} geinstalleerd, zoals die gevonden wordt van de omgevingsvariabele \code{R_REFMAP("certedata-lastest.zip")}.
#' @param force Standaard is \code{FALSE}. Forceert het installeren, waarmee bijv. dezelfde versie overschreven kan worden.
#' @param GitHub Standaard is \code{TRUE}. Dit downloadt de laatste versie van GitHub alvorens te updaten.
#' @param version Standaard is \code{"master"}. Wordt gebruikt als \code{GitHub == TRUE}.
#' @param ... oude niet-gebruikte parameters
#' @keywords update
#' @export
#' @examples
#' \dontrun{
#'
#' update_certedata()
#' }
#'
update_certedata <- function(force = FALSE, GitHub = TRUE, version = "master", ...) {
  if (!rstudioapi::showQuestion("`certedata` updaten", "Dit herstart de huidige R-sessie.", cancel = "Annuleren")) {
    return(invisible())
  }
  rstudioapi::restartSession(paste0("certedata:::resume_update(force = ", force, ", GitHub = ", GitHub, ", version = '", version, "')"))
}

resume_update <- function(force, GitHub, version) {
  locatie <- .R_REFMAP("certedata-latest.zip")
  if (GitHub == TRUE) {
    set_certe_proxy()
    download.file(paste0("https://github.com/msberends/certedata/archive/", version, ".zip"), locatie)
  }
  devtools::install_local(locatie, force = force)
  require(certedata)
}

#' Handleiding (PDF) openen
#'
#' Hiermee wordt de handleiding van dit pakket geopend in het standaard PDF-programma.
#' @details In het ontwikkelingsproject van dit pakket wordt deze functie gebruikt om de PDF te maken.
#' @export
manual <- function() {
  if (file.exists('certedata.Rproj')) {
    # PDF maken
    shell('R CMD Rd2pdf . --output=man/figures/manual.pdf --force --no-preview')
  } else {
    # PDF openen
    locaties <- .libPaths()
    for (i in 1:length(locaties)) {
      PDF.loc <- paste0(gsub('/', '\\', .libPaths()[i], fixed = TRUE),
                        '\\certedata\\help\\figures\\manual.pdf')
      if (file.exists(PDF.loc)) {
        shell.exec(PDF.loc)
      }
    }
  }
}


#' Controleer of de \emph{locale} West-Europees is
#'
#' Deze functie wordt gebruikt binnen andere functies van \code{certedata} om te controleren of de systeemtaal West-Europees is, om vervolgens getallen en datums zodanig op te maken (bijv. komma als scheidingsteken bij getallen). Zie Source voor de lijst met landen die hieronder vallen.
#' @return logical
#' @export Sys.isdecimalcomma
#' @source \url{https://en.wikipedia.org/wiki/Decimal_mark#Countries_using_Arabic_numerals_with_decimal_comma}
Sys.isdecimalcomma <- function() {

  countries <-
    c("Albania", "Algeria", "Andorra", "Angola", "Argentina", "Armenia", "Austria",
      "Azerbaijan", "Belarus", "Belgium", "Bolivia", "BosniaandHerzegovina", "Brazil",
      "Bulgaria", "Cameroon", "Chile", "Colombia", "CostaRica", "Croatia", "Cuba",
      "Cyprus", "CzechRepublic", "Denmark", "EastTimor", "Ecuador", "Estonia", "Faroes",
      "Finland", "France", "Germany", "Georgia", "Greece", "Greenland", "Hungary",
      "Iceland", "Indonesia", "Italy", "Kazakhstan", "Kosovo", "Kyrgyzstan", "Latvia",
      "Lebanon", "Lithuania", "Macedonia", "Moldova", "Mongolia", "Morocco", "Mozambique",
      "Namibia", "Netherlands", "Norway", "Paraguay", "Peru", "Poland", "Portugal",
      "Romania", "Russia", "Serbia", "Slovakia", "Slovenia", "SouthAfrica", "Spain",
      "Sweden", "Switzerland", "Tunisia", "Turkey", "Ukraine", "Uruguay", "Uzbekistan",
      "Venezuela", "Vietnam")

  any(sapply(countries, grepl, Sys.getlocale(), ignore.case = TRUE))

}

#' Structuur en inhoud van R-object bekijken
#'
#' Dit lijkt op \code{\link{str}}, maar analyseert een dataframe helemaal en retourneert ook het aantal unieke waarden en de beschikbaarheid per kolom.
#' @param object Een \code{R} object.
#' @param format.NL Standaard is \code{Sys.isdecimalcomma()}, zie \code{\link{Sys.isdecimalcomma}}. Hiermee worden getallen met een komma als decimaal teken weergegeven.
#' @seealso \code{\link{str}} \cr \code{\link{ls.str}} \cr \code{\link{summary}}
#' @keywords str str2 display summary
#' @export
str2 <- function(object, format.NL = Sys.isdecimalcomma()) {

  if (all(class(object) == 'character')) {
    object <- get(object, envir = .GlobalEnv)
  }

  class_obj <- classCaption(object)
  cols <- ncol(object)

  if (!is.null(cols)) {

    if (NROW(object) > 25000) {
      cat('\nAnalysing object...\n')
      progress <- progress_estimated(cols)
    }

    tbl <- tibble(column = character(0),
                  class = character(0),
                  na_count = character(0),
                  na_perc = character(0),
                  unique_count = character(0),
                  unique_list = character(0))

    for (i in 1:cols) {
      if (NROW(object) > 25000) {
        progress$tick()$print()
      }

      object.thiscol <- object %>% pull(i)
      column <- paste0('$', colnames(object)[i] %>% as.name())
      class <- classCaption(object.thiscol, FALSE)
      na_count <- length((object.thiscol)[is.na(object.thiscol)]) %>% format2(format.NL = format.NL)
      if (na_count > 0) {
        na_perc <- (length((object.thiscol)[is.na(object.thiscol)])
                    / nrow(object))
        if (na_perc == as.double(na_perc)) {
          na_perc <- na_perc %>%
            format2(percent = TRUE, round = 0, force.decimals = FALSE, format.NL = format.NL)
        } else {
          na_perc <- paste0('~',
                            na_perc %>%
                              format2(percent = TRUE, round = 0, force.decimals = FALSE, format.NL = format.NL))
        }
      } else {
        na_perc <- ''
      }

      unique_count <- (object.thiscol)[!is.na(object.thiscol)] %>% n_distinct() %>% format2(format.NL = format.NL)
      unique_list <- object.thiscol %>%
        unique() %>%
        sort()

      if (class %in% c('factor', 'character')) {
        unique_list <- paste0('"', unique_list, '"') # %>%
        # omzetten naar UTF-8
        #iconv('latin1', 'UTF-8')
      }
      unique_list <- unique_list[!is.na(unique_list)] %>% paste0(collapse = ' ')

      if (class == 'factor') {
        if (nchar(unique_list) > options()$width / 3) {
          unique_list <- unique_list %>% substr(1, options()$width / 3) %>% paste0('...')
        }
        unique_list <- unique_list %>% paste0(' (lvls: ', object.thiscol %>% levels() %>% concat(' '),')')

        class <- class %>% paste('w/', object.thiscol %>% levels() %>% length(), 'levels')
      }

      # nooit meer dan 100 tekens in lijst
      unique_list <- unique_list %>% substr(1, 300)

      unique_list <- unique_list %>%
        # zie https://en.wikipedia.org/wiki/Escape_character#ASCII_escape_character
        tryCatch(gsub('\033', ' ', ., fixed = TRUE),
                 error = function(e) {
                   warning(e$message) 
                   return(.)})

      tbl <- tbl %>%
        add_row(column = column,
                class = class,
                na_count = na_count,
                na_perc = na_perc,
                unique_count = unique_count,
                unique_list = unique_list)
    }

    if (NROW(object) > 25000) {
      cat('\n\n')
    }

  }

  # lijst met unieke waarden nog verder inkorten; totaal moet niet voorbij 100 komen
  limit <- tbl %>% pull(1) %>% nchar() %>% max() +
    tbl %>% pull(2) %>% nchar() %>% max() +
    tbl %>% pull(3) %>% nchar() %>% max() +
    tbl %>% pull(4) %>% nchar() %>% max() +
    tbl %>% pull(5) %>% nchar() %>% max() + 25

  limit <- options()$width - limit
  tbl <- tbl %>% mutate(unique_list = if_else(nchar(unique_list) > limit,
                                              paste0(unique_list %>% substr(1, limit), '...'),
                                              unique_list))

  cat('\nClass:', class_obj)

  if (!is.null(cols)) {
    cat('\nSize:  ',
        nrow(object) %>% format2(format.NL = format.NL),
        ' obs. of ',
        ncol(object) %>% format2(format.NL = format.NL),
        ' variables', sep = '')

    tbl_markdown(tbl,
                 format.tbl = 'rst',
                 align = c('l', 'l', 'r', 'r', 'r', 'l'),
                 column.names = c('Variable', 'Class', '<NA>', '<NA>%', 'Unique', 'Unique values (sorted ascending)'),
                 columns.bold = FALSE,
                 newlines.leading = 0,
                 newlines.trailing = 0,
                 padding = 0)
  } else {
    cat('\nLength:', length(object))
  }

  cat('\n')

}

#' Huidig document opslaan als nieuwe versie
#'
#' Hiermee wordt het geopende document opgeslagen als nieuwe versie. Er wordt automatisch een hoger versienummer en daarnaast de initialen van de huidige gebruiker toegevoegd.
#' @param myname Standaard is \code{Sys.getenv("R_USERNAME")}. De naam van de huidige gebruiker.
#' @param olddir Standaard is \code{"Oude versies"}. De map in de huidige map waarnaar oude versies verplaatst worden.
#' @export
SaveAsVersion <- function(myname = Sys.getenv("R_USERNAME"), olddir = 'Oude versies') {

  activedoc <- rstudioapi::getSourceEditorContext()
  activepath <- activedoc$path
  activedir <- dirname(activepath)
  movetodir <- paste0(activedir, '/', olddir)

  if (activepath == '') {
    # later save-scherm met v1?
    rstudioapi::showDialog("Not yet saved",
                           "This function only works on existing (i.e. previously saved) files.", url = "")
  } else {

    initials <- paste0(" ",
                       myname %>%
                         strsplit(" ") %>%
                         unlist() %>%
                         substr(1, 1) %>%
                         concat())

    filename <- basename(activepath)
    filename.bak <- filename
    extension <- tools::file_ext(filename)

    versionmatch <- regexpr(' v[0-9]+ ', filename)
    versionlength <- attributes(versionmatch)$match.length - 3

    if (versionmatch == -1) {
      newversion <- 2
      versionmatch <- nchar(filename) - 2 - nchar(extension)
    } else {
      newversion <- filename %>%
        substr(versionmatch + 2, versionmatch + 1 + versionlength)
      newversion <- as.double(newversion) + 1
      versionmatch <- versionmatch - 2
    }

    filename <- filename %>%
      substr(1, versionmatch + 1) %>%
      paste0(' v', newversion, initials, '.', extension)

    newpath <- gsub(filename.bak, filename, activepath, fixed = TRUE)
    oldpath <- paste0(movetodir, '/', filename.bak)

    answer <- rstudioapi::showQuestion("Save as version",
                                       paste0("Would you like to save '",
                                              filename.bak,
                                              "' as version ",
                                              newversion,
                                              " with you initals",
                                              initials,
                                              "?\n\n",
                                              "The current file will be moved to the subfolder '",
                                              olddir,
                                              "'.")
                                       , "Yes", "No")
    if (answer == TRUE) {
      # opslaan van huidige bestand als kopie naar map 'Oude versies'
      if (!dir.exists(movetodir)) {
        cmd <- paste0('mkdir "', movetodir)
        cmd <- gsub('/', '\\\\', cmd)
        shell(cmd, intern = TRUE, wait = TRUE)
      }
      cmd <- paste0('copy "', activepath, '" "', oldpath, '"')
      cmd <- gsub('/', '\\\\', cmd)
      shell(cmd, intern = TRUE, wait = TRUE)
      # opslaan van huidige bestand als nieuwe versie
      rstudioapi::documentSave(activedoc$id)
      cmd <- paste0('move "', activepath, '" "', newpath, '"')
      cmd <- gsub('/', '\\\\', cmd)
      shell(cmd, intern = TRUE, wait = TRUE)

      # nieuwe versie openen
      rstudioapi::navigateToFile(newpath)

      invisible(rstudioapi::showDialog("Version saved", "Version succesfully saved.", ""))

    }
  }
}

#' Certe-thema in RStudio installeren
#' @export
install.Certe.theme <- function(url = "https://github.com/msberends/certedata/blob/master/inst/rstudio/Certe.rstheme") {
  # https://support.rstudio.com/hc/en-us/articles/115011846747-Using-RStudio-Themes 
  # Gemaakt met:
  # https://tmtheme-editor.herokuapp.com/
  rstudioapi::addTheme(url, apply = TRUE)
}

#' Verticaal zoeken naar waarde in tabel
#'
#' Dit is een vrije exacte nabouw van de functie \code{VLOOKUP} (of \code{VERT.ZOEKEN} in Nederlands) van Microsoft Excel.
#' @param lookup_value The value you want to look up, also called the lookup value.
#' @param table_array The range where the lookup value is located. \emph{Remember that the lookup value should always be in the first column in the range for VLOOKUP to work correctly.}
#' @param col_index_num The column number in the range that contains the return value.
#' @param range_lookup Optionally, you can specify TRUE if you want an approximate match or FALSE if you want an exact match of the return value.
#' @param search_column Zie het schuingedrukte deel van de tweede parameter. Dit is R, dus dat bepalen we zelf even.
#' @source \url{https://support.office.com/en-us/article/VLOOKUP-function-0bbc8083-26fe-4963-8ab8-93a18ad188a1}
#' @export
vlookup <- function(lookup_value, table_array, col_index_num, range_lookup = FALSE, search_column = 1) {

  if (length(lookup_value) != 1L) {
    stop('`lookup_value` can only be a single value.')
  }

  table_array <- table_array %>% as.data.frame()

  if (range_lookup == FALSE) {
    table_array <- table_array[which(table_array[, search_column] == lookup_value), col_index_num]
  } else {
    table_array <- table_array[which(table_array[, search_column] %like% lookup_value), col_index_num]
  }

  if (length(table_array) == 0) {
    return(NA)
  } else {
    return(table_array[1])
  }

}

#' Referentiedocumenten voor analyses en rapporten
#'
#' Een set van verschillende sjablonen die gebruikt kunnen worden voor analyses en rapporten.
#' @param type Standaard is \code{"refdoc"}. Het type sjabloon dat gebruikt moet worden. Andere opties dan \code{"refdoc"} zijn er momenteel niet.
#' @export
#' @examples
#' # Begin van een Rmd-document (R Markdown):
#' #
#' # ---
#' # title: "Titel"
#' # subtitle:  "Ondertitel"
#' # output:
#' #   word_document:
#' #     reference_docx: "" # <- hier het resultaat van templatedoc()
#' # ---
templatedoc <- function(type = 'refdoc') {
  path <- switch(type,
                 'refdoc' = system.file("rmarkdown/refdoc.docx", package = "certedata") #,
                 # 'certeblauw' = system.file("rmarkdown/rapport_blauw.docx", package = "certedata"),
                 # 'certegeel' = system.file("rmarkdown/rapport_geel.docx", package = "certedata"),
                 # 'certegroen' = system.file("rmarkdown/rapport_groen.docx", package = "certedata"),
                 # 'certelila' = system.file("rmarkdown/rapport_lila.docx", package = "certedata")
  )
  if (is.null(path)) {
    stop('Invalid template type - templatedoc("', type, '").', call. = FALSE)
  } else {
    path
  }
}
#' @inherit dplyr::filter
#' @param min minimal group size, use \code{min = NULL} to filter on maximal group size only
#' @param max maximal group size, use \code{max = NULL} to filter on minimal group size only
#' @export
#' @source Stack Overflow answer by docendo discimus, \url{https://stackoverflow.com/a/43110620/4575331}
filter_group_size <- function(.data, min = NULL, max = min) {
  g <- dplyr::group_size(.data)
  if (is.null(min) & is.null(max)) {
    stop('`min` and `max` cannot both be NULL.')
  }
  if (is.null(max)) {
    max <- base::max(g, na.rm = TRUE)
  }
  ind <- base::rep(g >= min & g <= max, g)
  .data[ind, ]
}

certedata.Version <- function() {
  packageDescription("certedata")$Version %>% package_version()
}

#' Refmap voor certedata
#' @export
.R_REFMAP <- function(sub = "") {
  if (Sys.info()['sysname'] %in% c("Linux", "Darwin")) {
    r <- Sys.getenv("R_REFMAP")
  } else {
    r <- gsub('\\', '/', Sys.getenv("R_REFMAP"), fixed = TRUE)
  }

  if (r == "") {
    stop("Environmental user variable `R_REFMAP` not set.", call. = FALSE)
  }
  if (!r %like% '[/]$') {
    r <- paste0(r, '/')
  }
  sub <- trimws(sub, "both")
  r <- paste0(r, sub)
  if (r %like% '[/]$') {
    r <- substr(r, 1, nchar(r) - 1)
  }
  if (tools::file_ext(r) == "" & !dir.exists(r)) {
    dir.create(r, recursive = TRUE)
  }
  r
}

release_gh <- function(pdf = TRUE) {

  v <- paste0("v", packageDescription("certedata")$Version)
  if (pdf == TRUE) {
    cat("Creating PDF manual\n")
    manual()
  }
  rstudioapi::sendToConsole(
    code = paste0(
      "git add .\n",
      "git commit -a -m ", v, "\n",
      "git push\n",
      "git tag ", v, "\n",
      "git push origin ", v, "\n"),
    execute = FALSE)
}


#' Proxy-gegevens toepassen voor Certe
#'
#' Hiermee wordt automatisch de proxy ingesteld voor Certe, alleen wanneer de computernaam begint met CI en daarna alleen cijfers bevat. Het Certe-wachtwoord kan opgeslagen worden in \code{Sys.setenv(R_WW = "wachtwoord")}. Wanneer deze leeg is, wordt in iedere R-sessie 1 keer om het wachtwoord gevraagd.
#' @export
set_certe_proxy <- function() {
  if (grepl(x = Sys.info()['nodename'], pattern = '^CI[0-9]+$', ignore.case = TRUE) &
       grepl(x = Sys.info()['login'], pattern = '^[0-9]+$')) {
    httr::set_config(
      httr::use_proxy(
        url = "proxy.in.certe.nl",
        port = 8080,
        username = Sys.info()['login'],
        password = getpw(),
        auth = "any"
      )
    )
  }
}

#' Certe-gebruiker ophalen
#'
#' Hiermee worden gegevens over Certe-personeel gedownload uit \code{.R_REFMAP("gebruikers.csv")}.
#' @param x Standaard is huidige ingelogde gebruiker. Het Certe-inlognummer (en -personeelsnummer).
#' @param property Eigenschap om te retourneren.
#' @rdname get_certe_user
#' @export
get_certe_user <- function(x = Sys.info()['login'], property = c("id", "name", "mail", "job", "dept")) {
  if (length(property) > 1) {
    property <- 'name'
  } else if (!property %in% c("id", "name", "mail", "job", "dept")) {
    stop('invalid property for certe user: ', property, call. = FALSE)
  }
  users <- get_certe_users()
  if (!is.null(users)) {
    for (i in 1:length(x)) {
      if (is.double2(x[i])) {
        x[i] <- users %>% filter(id == x[i]) %>% pull(property)
      }
    }
  }
  x
}

#' @rdname get_certe_user
#' @export
get_certe_users <- function() {
  users_file <- .R_REFMAP("gebruikers.csv")
  if (file.exists(users_file)) {
    read.csv2(users_file,
              header = FALSE,
              col.names = c("id", "name", "mail", "job", "dept"),
              stringsAsFactors = FALSE,
              encoding = "UTF-8")
  } else {
    warning('file not found:', .R_REFMAP("gebruikers.csv"))
    NULL
  }
}

getpw <- function() {
  pw <- Sys.getenv("R_WW")
  if (pw == "") {
    if (!interactive()) {
      stop("Certe-wachtwoord voor ", Sys.info()['login'], " niet opgeslagen als omgevingsvariabele `R_WW`. Kan geen verbinding maken met database.")
    }
    pw <- rstudioapi::askForPassword(paste("Certe-wachtwoord niet opgeslagen als omgevingsvariabele `R_WW`, geef hier het wachtwoord van Certe-inlognummer", Sys.info()['login'], "op:"))
    Sys.setenv(R_WW = pw)
  }
  pw
}

#' @title Rmd-document knitten naar Word
#' @param file Bronbestand om te knitten (eindigend op .Rmd).
#' @param target Doelbestand.
#' @param quiet Standaard is \code{TRUE}. Zonder tekstoutput knitten.
#' @export
knit <- function(file, target = paste0(file, ".docx"), quiet = TRUE) {
  rmarkdown::render(
    input = file,
    output_file = target,
    output_format = "word_document",
    encoding = "UTF-8",
    quiet = quiet)
}