inst/shiny/sdcApp/global.R

In sdcTools/sdcMicro: Statistical Disclosure Control Methods for Anonymization of Data and Risk Estimation

library(shiny)
library(grid)
library(sdcMicro)
library(rhandsontable)
library(haven)
library(shinyBS)
library(data.table)

if (!getShinyOption("sdcAppInvoked", FALSE)) {### Beginning required code for deployment
  .startdir <- .guitheme <- .guijsfile <- NULL
  maxRequestSize <- 50
  options(shiny.maxRequestSize=ceiling(maxRequestSize)*1024^2)

  shinyOptions(.startdir = getwd())

  theme="IHSN"
  shinyOptions(.guitheme = "ihsn-root.css")
  shinyOptions(.guijsfile = "js/ihsn-style.js")
}## End of deployment code


# required that 'dQuote()' works nicely when
# outputting R-Code
options(useFancyQuotes=FALSE)

# maximum upload size = 1GB (defined in sdcApp())
#options(shiny.maxRequestSize=1000*1024^2)

# cmd is the original codestr (also listed in tab 'script')
# as generated by one of the code_xxx() reactive-expressions
runEvalStr <- function(cmd, comment=NULL) {
  nr_warnings_start <- nrow(get.sdcMicroObj(obj$sdcObj, type="additionalResults")$sdcMicro_warnings)
  if (is.null(nr_warnings_start)) {
    nr_warnings_start <- 0
  }

  evalAsIs <- !is.null(attributes(cmd)$evalAsIs)
  # evaluate using tryCatchFn()
  if (evalAsIs) {
    cmdeval <- gsub("sdcObj","obj$sdcObj", cmd)
  } else {
    if (length(grep("<-", unlist(strsplit(cmd, " "))))>1) {
      cmdeval <- gsub("\n","",cmd)
      cmdeval <- sub("obj[$]sdcObj <- ","",cmdeval) # first occurence
      cmdeval <- gsub("sdcObj","obj$sdcObj", cmd)
    } else {
      cmdeval <- gsub("sdcObj","obj$sdcObj", cmd)
      cmdeval <- strsplit(cmdeval, "<-")[[1]][2]
    }
  }
  evalstr <- paste0("res <- sdcMicro:::tryCatchFn({",cmdeval,"})")
  #cat(evalstr,"\n")
  eval(parse(text=evalstr))
  if (!"simpleError" %in% class(res)) {
    obj$last_error <- NULL

    if (!evalAsIs) {
      obj$sdcObj <- res; rm(res)
    }

    if (!is.null(comment)) {
      cmd <- paste0(comment,"\n",cmd)
    }
    cmd <- sub('lab=obj[$]stata_labs, ','',cmd) # for stata export
    obj$code_anonymize <- c(obj$code_anonymize, cmd)
    # check if we have some new warnings
    current_warnings <- get.sdcMicroObj(obj$sdcObj, type="additionalResults")$sdcMicro_warnings
    nr_new <- nrow(current_warnings)
    if (!is.null(current_warnings) && nrow(current_warnings) > nr_warnings_start) {
      obj$last_warning <- utils::tail(current_warnings,1)
    } else {
      obj$last_warning <- NULL
    }
  } else {
    obj$last_error <- res$message
    obj$last_warning <- NULL
  }
}

# simple evaluations
runEvalStrMicrodat_no_errorchecking <- function(cmd, comment=NULL) {
  # evaluate using tryCatchFn()
  cmdeval <- gsub("inputdata","obj$inputdata", cmd)
  eval(parse(text=cmdeval))

  if (!is.null(comment)) {
    cmd <- paste0(comment,"\n",cmd)
  }
  obj$code_read_and_modify <- c(obj$code_read_and_modify, cmd)
}

# runEvaluationString and update Objects for microdata-modifications
runEvalStrMicrodat <- function(cmd, comment=NULL) {
  # evaluate using tryCatchFn()
  # if we read an existing object from R, we need to use sub (in case the obj is called inputdata)
  is_from_df <- grep('type="rdf"', cmd)
  if (length(is_from_df)>0) {
    cmdeval <- sub("inputdata","obj$inputdata", cmd)
  } else {
    cmdeval <- gsub("inputdata","obj$inputdata", cmd)
  }

  cmdeval <- strsplit(cmdeval, "<-")[[1]][2]
  evalstr <- paste0("res <- sdcMicro:::tryCatchFn({",cmdeval,"})")
  #cat("evalstr:", evalstr,"\n")
  eval(parse(text=evalstr))
  #print(str(res))
  if (!"simpleError" %in% class(res)) {
    obj$last_error <- NULL
    obj$inputdata <- res; rm(res)
    if (!is.null(comment)) {
      cmd <- paste0(comment,"\n",cmd)
    }
    obj$code_read_and_modify <- c(obj$code_read_and_modify, cmd)
    # check if we have some new warnings
  } else {
    obj$last_error <- res$message
    obj$last_warning <- NULL
  }
}

# required code to temporarily reset strata-variable
# new_strataV: new strata variable
# ex_strataV: existing strata variable
code_reset_strata <- function(new_strataV, ex_strataV) {
  cmd1 <- cmd2 <- NA
  strata_ex <- ex_strataV
  if (!is.null(strata_ex) & is.null(new_strataV)) {
    cmd1 <- paste0("strataVar(sdcObj) <- NULL")
  } else if (is.null(strata_ex) & !is.null(new_strataV)) {
    cmd1 <- paste0("strataVar(sdcObj) <- ",dQuote(new_strataV))
  }

  # reset back to original value
  if (!is.null(strata_ex) & !is.null(new_strataV)) {
    cmd2 <- paste0("strataVar(sdcObj) <-",dQuote(ex_strataV))
  } else if (is.null(strata_ex) & !is.null(new_strataV)) {
    cmd2 <- paste0("strataVar(sdcObj) <- NULL")
  }
  out <- list(cmd1=cmd1, cmd2=cmd2)
}

#helper function for code-generation
#correctly 'quote' a character vector
VecToRStr <- function(v, quoted=TRUE) {
  if (quoted) {
    paste0('c("',paste(v, collapse='","'),'")')
  } else {
    paste0("c(",paste(v, collapse=","),")")
  }
}

VecToRStr_txt <- function(v) {
  paste0('"',paste(v, collapse='", "'),'"')
}

# filed file names keeping original name of uploaded file
fixUploadedFilesNames <- function(x) {
  if (is.null(x)) {
    return()
  }
  oldNames = x$datapath
  newNames = file.path(dirname(x$datapath), x$name)
  file.rename(from=oldNames, to=newNames)
  x$datapath <- newNames
  x
}

genObserver_menus <- function(pat="btn_results_", n=1, updateVal) {
  res <- paste0('observeEvent(input$',pat,n,', {
    curid <- "',pat,n,'"
    nn <- names(input)
    nn <- nn[grep("',pat,'",nn)]
    nn <- setdiff(nn, curid)
    for (btnid in nn) {
      updateButton(session, btnid, style="default")
    }
    obj$',updateVal,' <- "',pat,n,'"
    updateButton(session, curid, style="primary")
  });
  ')
  res
}


myActionButton <- function(inputId, label, btn.style="", css.class="") {
  if ( btn.style %in% c("primary","info","success","warning","danger","inverse","link")) {
    btn.css.class <- paste("btn", btn.style, sep="-")
  } else {
    btn.css.class <- ""
  }
  tags$button(id=inputId, type="button", class=paste("btn action-button", btn.css.class, css.class, collapse=" "), label)
}

myErrBtn <- function(id, label, btn.style="danger") {
  btn <- myActionButton(id,label=label, btn.style=btn.style)
  return(fluidRow(column(12, div(btn, align="center"))))
}

# does not immediately react to user input
customTextInput <- function(inputId, label, value = "") {
  tagList(
    singleton(tags$head(tags$script(src = "sdcwww/js/customTextInputBinding.js"))),
    tags$label(label, `for` = inputId),
    tags$input(id = inputId, type = "text", value = value, class = "returnTextInput")
  )
}

msg_nodata <- function(tab_import=FALSE) {
  if ( tab_import ) {
    txt <- "Please select a dataset to upload"
  } else {
    txt <- "Please upload data in the Microdata tab!"
  }
  fluidRow(
    column(12, h2("No data available", align="center")),
    column(12, strong(txt)))
}

# custom Summary-Function for numerical Variables
summaryfn <- function(x) {
  if (is.numeric(x)) {
    vv <- c(min(x, na.rm=TRUE),
      stats::quantile(x, c(0.05,0.25, 0.5), na.rm=TRUE),
      mean(x, na.rm=TRUE),
      stats::quantile(x, c(0.75,0.95), na.rm=TRUE), max(x, na.rm=TRUE))
    names(vv) <- c("Min", "Q5","Q25","Median","Mean","Q75","Q95","Max")
  } else {
    vv <- as.data.frame.table(addmargins(table(x, useNA = "always")))
    vv$Freq <- as.integer(vv$Freq)
    vv$Perc <- formatC(100*(vv$Freq/length(x)), format="f", digits=2)
  }
  vv
}

# global, reactive data-structure
data(testdata, envir = .GlobalEnv)
data(testdata2, envir = .GlobalEnv)
testdata$urbrur <- factor(testdata$urbrur)
testdata$urbrur[sample(1:nrow(testdata), 10)] <- NA
testdata$roof <- factor(testdata$roof)
testdata$walls <- factor(testdata$walls)
testdata$sex <- factor(testdata$sex)
# which data.frames ware available in the global environment?
ex <- ls(envir = .GlobalEnv)
if (length(ex) > 0) {
  available_dfs <- ex[sapply(ex, function(x) {
    is.data.frame(get(paste(x), envir = .GlobalEnv))
  })]
  if (length(available_dfs) == 0) {
    available_dfs <- NULL
  }
}

get_keyVars <- reactive({
  if ( is.null(obj$sdcObj)) {
    return(NULL)
  }
  return(obj$sdcObj@keyVars)
})

# get key variables by names
get_keyVars_names <- reactive({
  if ( is.null(obj$sdcObj)) {
    return(NULL)
  }
  return(colnames(get_origData())[get_keyVars()])
})

get_weightVar <- reactive({
  if ( is.null(obj$sdcObj)) {
    return(NULL)
  }
  return(obj$sdcObj@weightVar)
})
get_numVars <- reactive({
  if ( is.null(obj$sdcObj)) {
    return(NULL)
  }
  return(obj$sdcObj@numVars)
})
get_origData <- reactive({
  if ( is.null(obj$sdcObj)) {
    return(NULL)
  }
  return(obj$sdcObj@origData)
})
get_risk <- reactive({
  if ( is.null(obj$sdcObj)) {
    return(NULL)
  }
  return(as.data.frame(obj$sdcObj@risk$individual))
})

noInputData <- function(prefix="btn_a_micro_", uri) {
  btn <- myActionButton(paste0(prefix, uri), label=("Load microdata"), "primary")
  fluidRow(
    column(12, h3("No input data available!"), class="wb-header"),
    column(12, p("Go to the Microdata tab to upload a dataset or upload a previously saved problem from the Undo tab"), class="wb-header-hint"),
    column(12, p("Go back to the Microdata tab by clicking the button below and load a dataset."), align="center"),
    column(12, div(btn, align="center")))
}

noSdcProblem <- function(prefix="btn_a_setup_", uri) {
  txt <- "Go back to the Anonymize tab by clicking the button below and select variables"
  btn <- myActionButton(paste0(prefix,uri),label=("Create an SDC problem"), "primary")
  fluidRow(
    column(12, h3("No SDC problem was specified"), class="wb-header"),
    column(12, p("Please go to the Microdata tab to upload a dataset or upload a previously saved problem from the Reproducibility tab."), class="wb-header-hint"),
    column(12, p(txt)),
    column(12, div(btn, align="center")))
}

# generate dynamic observers
genDynLinkObserver <- function(prefix="btn_a_setup_", verbose=FALSE, inputId="mainnav", selected=NULL) {
  fn <- paste0(prefix,sapply(strsplit(list.files("controllers"),"[.]"), function(x) x[1]))
  cmd <- paste0("observeEvent(input$",paste(fn, sep=""),", {")
  if ( verbose ) {
    cmd <- paste0(cmd, 'cat("',sQuote(paste(fn, sep="")),' was clicked ",input$',paste(fn, sep=""),', "times\\n");')
  }
  cmd <- paste0(cmd, "updateNavbarPage(session, inputId=",dQuote(inputId),", selected=",dQuote(selected),")});")
}

href_to_setup <- genDynLinkObserver(prefix="btn_a_setup_", verbose=FALSE, inputId="mainnav", selected="Anonymize")
href_to_microdata <- genDynLinkObserver(prefix="btn_a_micro_", verbose=FALSE, inputId="mainnav", selected="Microdata")

#observeEvent(input$btn_a_setup, {
#  cat(paste("'btn_a_setup' was clicked",input$btn_a_setup,"times..!\n"))
#  updateNavbarPage(session, inputId="mainnav", selected="Setup SDC-Problem")
#})

#check_packageStatus <- function(pkg="sdcMicro") {
#  xx <- readLines(paste0("https://cran.r-project.org/web/packages/",pkg,"/index.html"), n=40)
#  cranV <- gsub("<(td|\\/td)>","",xx[grep("Version", xx)+1])
#  isOk <- FALSE
#  if (packageVersion("sdcMicro")==cranV) {
#    isOk <- TRUE
#  }
#  return(list(isOk=isOk, cranV=cranV))
#}

permPfad <- reactiveValues()
obj <- reactiveValues() # we work with this data!

#obj$pkg_status <- check_packageStatus(pkg="sdcMicro")

#obj$sdcObj <- sample(1:10, 100, replace=TRUE)
#obj$v1 <- sample(LETTERS[1:10], 100, replace=TRUE)
#obj$v2 <- as.factor(sample(letters[1:8], 100, replace=TRUE))
#testdata$myfac <- factor(sample(1:100, nrow(testdata), replace=TRUE))

testdata$urbrur <-  as.numeric(testdata$urbrur)

#obj$inputdata <- obj$inputdataB <- testdata
obj$inputdata <- NULL
obj$sdcObj <- NULL
#obj$sdcObj <- createSdcObj(testdata,
#  keyVars=c('roof','walls','water'),
#  numVars=c('expend','income','savings'), strataVar="sex", w='sampling_weight')
obj$code_read_and_modify <- c()
obj$code_setup <- c()
obj$code_anonymize <- c()
obj$code <- c(
  paste("# created using sdcMicro", packageVersion("sdcMicro")),
  "library(sdcMicro)", "",
  "obj <- NULL")
obj$transmat <- NULL
obj$last_warning <- NULL
obj$last_error <- NULL
obj$comptime <- 0
obj$microfilename <- NULL # name of uploaded file
obj$lastaction <- NULL
obj$anon_performed <- NULL # what has been applied?
obj$rbs <- obj$sls <- NULL
obj$setupval_inc <- 0
obj$inp_sel_viewvar1 <- NULL
obj$inp_sel_anonvar1 <- NULL
obj$lastreport <- NULL # required to show the last saved report
obj$lastdataexport <- NULL # required to show the last saved exported data
obj$lastproblemexport <- NULL # required to show the last exported sdcproblem
obj$lastproblemexport1 <- NULL # required to show the last exported sdcproblem (undo-page)
obj$lastscriptexport <- NULL # required to show the last saved script
obj$ldiv_result <- NULL # required for l-diversity risk-measure
obj$suda2_result <- NULL # required for suda2 risk-measure
obj$hhdata <- NULL # household-file data required for merging
obj$hhdata_applied <- FALSE # TRUE, if mergeHouseholdData() has been applied
obj$hhdata_selected <- FALSE # TRUE, if selectHouseholdData() has been applied

# stores the current selection of the relevant navigation menus
obj$cur_selection_results <- "btn_results_1" # navigation for Results/Risks
obj$cur_selection_exports <- "btn_export_results_1" # navigation for export
obj$cur_selection_script <- "btn_export_script_1" # navigation for reproducibility/script
obj$cur_selection_microdata <- "btn_menu_microdata_1" # navigation for microdata
obj$cur_selection_import <- "btn_import_data_1" # navigation for import
obj$cur_selection_anon <- "btn_sel_anon_1" # navigation for anonymization

# for stata-labelling
obj$stata_labs <- NULL
obj$stata_varnames <- NULL

# the path, where all output will be saved to
pp <- getShinyOption(".startdir", getwd())
if (file.access(pp, mode=2)==0) {
  obj$path_export <- pp
} else {
  obj$path_export <- tempdir()
}

# is available in exported problem instances
# helpful for debugging
obj$sessioninfo <- sessionInfo()