R/surveytools.R

In adviceas/adviceverse: Tools for Data and Survey Analysis, Advice A/S

#
#   Install Package:           'Cmd + Shift + B'
#   Check Package:             'Cmd + Shift + E'
#   Test Package:              'Cmd + Shift + T'
#
#   Update documentation:       devtools::document()
#

#' Filter completes responses
#'
#' @param df Data frame of survey responses (acccepts Haven labels).
#' @param preset E.g. "surveyxact".
#' @return Data frame, preserves Haven labels
filter_completes <- function(df,
                             preset = NULL,
                             complete_var = NULL,
                             complete_code = NULL
                             ) {

  # TODO: Implement simple check of inputs

  if (!is.null(preset)) {

    if (preset == "surveyxact") {

      return(filter_completes(df,
                              complete_var = "statoverall_4",
                              complete_code = 1)
                              )

    } else if (preset == "you-name-it") {

      # Add more presets here.

      return(filter_completes(df,
                              complete_var = "you-name-it",
                              complete_code = 1)
      )

    } else {

      stop("No such preset.")

    }

  }

  dplyr::filter(df, get(complete_var) == complete_code)

}

#' Print common sampling statistics
#'
#' @param df Data frame of survey responses (acccepts Haven labels).
#' @param preset E.g. "surveyxact".
#' @return Survey sampling statistics
print_sampling_stats <- function(df,
                                 preset = NULL,
                                 responsetime_var = NULL,
                                 complete_var = NULL,
                                 complete_code = NULL,
                                 incomplete_var = NULL,
                                 incomplete_code = NULL,
                                 screenouts_var = NULL,
                                 screenouts_code = NULL,
                                 starttime_var = NULL,
                                 endtime_var = NULL) {

  # TODO: Implement simple check of inputs
  # TODO: Implement partial output

  if (!is.null(preset)) {

    if (preset == "surveyxact") {

      return(print_sampling_stats(df,
                                  responsetime_var = "difftime",
                                  complete_var = "statoverall_4",
                                  complete_code = 1,
                                  incomplete_var = "statoverall_3",
                                  incomplete_code = 1,
                                  screenouts_var = "statoverall_5",
                                  screenouts_code = 1,
                                  starttime_var = "starttime",
                                  endtime_var = "closetime"
                                  )
            )

    } else if (preset == "you-name-it") {

      # Add more presets here.

      return(print_sampling_stats(df,
                                  responsetime_var = "you-name-it",
                                  complete_var = "you-name-it",
                                  complete_code = 1,
                                  incomplete_var = "you-name-it",
                                  incomplete_code = 1,
                                  screenouts_var = "you-name-it",
                                  screenouts_code = 1,
                                  starttime_var = "you-name-it",
                                  endtime_var = "you-name-it"
                                  )
      )

    } else {

    stop("No such preset")

    }

  }

  # Get, compute and format stats

  completes <- sum(df[[complete_var]] == complete_code)
  incompletes <- sum(df[[incomplete_var]] == incomplete_code)
  screenouts <- sum(df[[screenouts_var]] == screenouts_code)
  IR <- round((completes / (completes + screenouts)) * 100, 0)
  responsetime <- round(median(df[[responsetime_var]][df[[complete_var]] == complete_code]) / 60, 1)
  starttime <- format(min(df[[starttime_var]], na.rm = TRUE), "%d/%m/%Y")
  endtime <- format(max(df[[endtime_var]], na.rm = TRUE), "%d/%m/%Y")

  # Print stats

  cat(
    paste("Gennemførte besvarelser:",
          completes,
          sep = " "),
    paste("Frasorterede:",
          screenouts,
          sep = " "),
    paste("Fænomenstørrelse:",
          IR,
          "%",
          sep = " "),
    paste("Frafaldne:",
          incompletes,
          sep = " "),
    paste("Svartid blandt gennemførte (median):",
          responsetime,
          "min.",
          sep = " "),
    paste("Indsamlingsperiode:",
          starttime,
          "-",
          endtime),
    sep = "\n")

}

#' Export labelled survey responses as .xlsx (imitating SurveyXact's "Complete" sheet)
#' THIS IS AN ALPHA VERSION: Use openxlsx::write.xlsx() for non-labelled sheets
#'
#' @param df Data frame of survey responses (acccepts Haven labels).
#' @param filename E.g. "rawdata.xlsx"
write_excel_survey <- function(df,
                            filename) {

  df <-
    df %>%
    dplyr::mutate_all(haven::as_factor)

  # TODO: Håndter variabelnavne uden variabel labels.

  colnames(df) <- .llookup_backend(df)$label # Use labels as varnames

  # TODO: Implementer "nice-to-have" - fx ark-navngivning, ark med variabeloversigt etc.

  openxlsx::write.xlsx(df, filename)

  message("ALPHA VERSION: Tjek data før det sendes til kunder.")
  message("NB! Data i .xlsx er reduceret irreversibelt. Husk også at gemme som .RDS eller .sav")

}