R/helper.r

In sooyongl/ESS:

#' @include import.r
NULL

#' data_prep
data_prep <- function(inpData, lvNm, locInf){
  # fourthData <- fourth_data
  GCAId <- inpData %>% pull(GCA) %>% unique()
  level_nm <- lvNm %>% select(all_of(GCAId)) %>% pull()

  location <- locInf$location[[GCAId]]
  bind_loc <- locInf$bind_loc[[GCAId]]

  return(list(
    data_1 = inpData,
    level_nm = level_nm,
    test_id = GCAId,
    location = location,
    bind_loc = bind_loc))
}
#' get_opname1
get_opname1 <- function(datainp, lvname, opnum){

  efficacy_data_1 <- datainp # efficacy_data_1 <- est_cutscore[[i]]
  eff_name <- names(efficacy_data_1)
  target_filter = "ALD"

  item_start <- 1
  cut_point <- which(opnum==1)
  num_item <-length(opnum)

  operational_1 <- c(item_start, cut_point, num_item)
  Operational_name <- rep(lvname[length(lvname)], length(opnum))

  for(i in 1:(length(cut_point)+1)){
    # i <- 2
    if(i == (length(cut_point)+1)) {
      Operational_name[operational_1[i]:(operational_1[(i+1)])] <- lvname[i]

    } else {
      Operational_name[operational_1[i]:(operational_1[(i+1)]-1)] <- lvname[i]
    }
  }

  return(Operational_name)
}
#'
remove_blank_vector <- function(inpData) {

  inpData %>% stri_replace_all_charclass(., "\\p{WHITE_SPACE}", "")
}
#'
#'
upper_remove_blank <- function(vec){
  toupper(remove_blank_vector(vec))
}

#'
freq_to_vec = function(data) {

  rep(data$score, data$freq)
}
#'
#'
fifth_reorg <-
  function(inpdata){
    if(sum(str_detect(toupper(names(inpdata)), toupper("freq"))) == 0){

      return(inpdata)

    } else {
      inpdata_reorg <- vector("list", ncol(inpdata))

      for(i in 1:ncol(inpdata)) {
        # i <- 4
        if(sum(is.na(inpdata[i])) == nrow(inpdata)){
          next
        }
        inpdata_reorg[[i]] <- inpdata[i]
      }
      inpdata_reorg <- inpdata_reorg %>% bind_cols()

      inpdata_reorg <-
        foreach(i = 1:(ncol(inpdata_reorg)/3), .combine = 'rbind') %do% {
          ii = 1 + (i - 1)*3
          iii = ii + 2
          inpdata_reorg[,ii:iii] %>% drop_na() %>%
            set_names(., nm = c("score", "freq","GCA"))
        }
      return(inpdata_reorg)
    }
  }
#'
extract_num <- function(vectorInp){
as.numeric(str_extract(vectorInp, "[[:digit:]]"))
}
#'
gen_ifelse <-
  function(x, lvNames) {
    colors <- c("#FBEEE6","#ffc0cb","#c9ede7","#e3dcf1","#c0ffee","#FBEEE6","#F5B7B1","#D2B4DE","#AED6F1","#A3E4D7","#F9E79F")
    colors <- colors[1:length(lvNames)]

    for(i in 1:length(lvNames)) {
      lvNames[i] <- glue::glue({ "'{lvNames[i]}'"  })
    }

    for(i in 1:length(colors)) {
      colors[i] <- glue::glue({ "'{colors[i]}'"  })
    }

    if_list <- list()
    for(i in 1:length(lvNames)){
      # i <- 1
      lvNames_1 <- lvNames[i]
      colors_1 <- colors[i]

      if(i < length(lvNames)){
        if_list[[i]] <-
          glue::glue({
            "ifelse({x} == {lvNames_1}, {colors_1},"
          })
      } else {
        p1 <- paste( rep(")", (length(lvNames)-1)), collapse = " ")
        if_list[[i]] <- glue::glue({ "{colors_1} {p1}" })
      }
    }
    return(paste(unlist(if_list), collapse = " "))
  }