functions.R

In iNZightVIT/Lite: iNZight Lite

##########################################################
# To be removed when the iNZight tools package is working##
##########################################################

read_config <- function() {
  lite_config <- Sys.getenv("LITE_CONFIG")
  if (is.null(lite_config) || nchar(lite_config) <= 1) {
    return()
  }

  # read from json
  fromJSON(lite_config)
}

# Modified based off:
# https://github.com/dreamRs/shinylogs/blob/0195ac0a1f85d213c82143cfee712c9baddd1963/R/tracking.R#L134
init_lite_logs <- function(
    log_path = tempdir(),
    what = c("session", "input", "output", "error"),
    exclude_input_regex = NULL,
    exclude_input_id = NULL,
    exclude_users = NULL,
    session = getDefaultReactiveDomain()) {
  return()
  what <- match.arg(what, several.ok = TRUE)
  LITE_SESSION_ID_ <<- substr(session$token, 1, 10)

  if (!file.exists(log_path)) {
    dir.create(log_path)
  }
  addResourcePath("logs", log_path)

  print(list.files(log_path))

  app_name <- "lite"
  user <- shinylogs:::get_user_(session)
  storage_mode <- store_json(path = log_path)
  timestamp <- shinylogs:::get_timestamp(timestamp)
  log_name <- paste0("lite_logs_", LITE_SESSION_ID_, ".json")
  log_path <- file.path(log_path, log_name)
  download_path <- file.path("logs", log_name)

  timestamp <- Sys.time()
  init_log <- data.frame(
    session_id = LITE_SESSION_ID_,
    app = app_name,
    user = user,
    server_connected = timestamp,
    stringsAsFactors = FALSE
  )
  storage_mode$appname <- app_name
  storage_mode$timestamp <- format(
    bit64::as.integer64(nanotime::nanotime(timestamp)),
    scientific = FALSE
  )

  insertUI(
    selector = "body", where = "afterBegin",
    ui = singleton(tags$script(
      id = "shinylogs-tracking",
      type = "application/json",
      `data-for` = "shinylogs",
      toJSON(shinylogs:::dropNulls(list(
        what = what,
        logsonunload = FALSE,
        exclude_input_regex = exclude_input_regex,
        exclude_input_id = exclude_input_id,
        session_id = init_log$session_id,
        log_path = log_path,
        download_path = download_path
      )), auto_unbox = TRUE, json_verbatim = TRUE)
    )),
    immediate = TRUE,
    session = session
  )
  insertUI(
    selector = "body", where = "afterBegin",
    ui = htmltools::attachDependencies(
      x = tags$div(),
      value = list(
        shinylogs:::shinylogs_dependencies()
      )
    ),
    immediate = FALSE,
    session = session
  )

  if (isTRUE(storage_mode$console)) {
    observe({
      to_console(session$input$.shinylogs_browserData, init_log)
    })
    observe({
      to_console(session$input$.shinylogs_lastInput)
    })
  }

  onSessionEnded(
    fun = function() {
      init_log$server_disconnected <- shinylogs:::get_timestamp(Sys.time())
      logs <- c(
        isolate(session$input$.shinylogs_input),
        isolate(session$input$.shinylogs_error),
        isolate(session$input$.shinylogs_output)
      )
      browser_data <- isolate(session$input$.shinylogs_browserData)
      if (!is.null(browser_data)) {
        browser_data <- as.data.frame(browser_data)
        logs$session <- cbind(init_log, browser_data)
      } else {
        logs$session <- init_log
      }
      if (isTRUE(!user %in% exclude_users)) {
        # shinylogs:::write_logs(storage_mode, logs)
        jsonlite::write_json(
          x = logs,
          path = log_path,
          auto_unbox = TRUE
        )
      }
    },
    session = session
  )
}

#' Reahapes the data that all columns are merged into two
#' column with the variable names in the first column and
#' the values in the second column.
#'
#' @param dafr The data.frame to convert
#'
#' @return The converted data.frame.
#'
#' @author Christoph Knapp
get.reshape.data <- function(dafr) {
  temp <- do.call(rbind, lapply(1:ncol(dafr), function(index, d) {
    name <- colnames(d)[index]
    data.frame(groups = name, d[, index], stringsAsFactors = TRUE)
  }, dafr))
  colnames(temp)[2] <- "variables"
  temp
}

#' add new columns to the original dataframe which replace "NA"
#' with "missing" so that the missing values could be displayed
#' in the plot..
#'
#' @param dafr The input data.frame.
#' @param The column names or indexes to be converted.
#'
#' @return A data.frame with the new columns added.
#'
#' @author Wilson Hu
display.missing.categorical <- function(dafr, columns) {
  for (i in columns) {
    temp <- dafr[, i]
    if (is.factor(temp) || is.character(temp)) {
      temp <- as.character(temp)
      temp[is.na(temp)] <- "missing"
      temp <- as.factor(temp)
      original.level <- levels(temp)[levels(temp) != "missing"]
      temp <- factor(temp, levels = c(original.level, "missing"))
    } else {
      index <- is.na(temp)
      temp <- rep("observed", length(temp))
      temp[index] <- "missing"
      temp <- factor(temp, levels = c("observed", "missing"))
    }
    temp <- as.data.frame(temp, stringsAsFactors = TRUE)
    colnames(temp) <- paste(i, "missing", sep = "_")
    dafr <- data.frame(dafr, temp, stringsAsFactors = TRUE)
  }
  dafr
}

#' Simplifies the input data.frame by keeping only
#' columns where NA values are present. Function
#' used in get.combinations
#'
#' @param dafr A data.frame to be
#' simplified such that all columns
#' which do not contain NA values are
#' removed.
#'
#' @author Christoph Knapp
simplify.dafr <- function(dafr) {
  ies <- c()
  for (col in 1:ncol(dafr)) {
    if (!any(is.na(dafr[, col]))) {
      ies <- c(ies, col)
    }
  }
  dafr <- dafr[, -ies]
  if (ncol(dafr) == 0) {
    dafr <- NULL
  }
  dafr
}

#' Converts a data.frame to a format where all
#' non NA are replaced by "observed" and all NA
#' values are repalced by "missing".
#'
#' @param dafr the data.frame to convert.
#'
#' @return The converted data.frame.
#'
#' @author Christoph Knapp
convert.dafr <- function(dafr) {
  if (!is.null(dafr)) {
    temp <- do.call(cbind, lapply(1:ncol(dafr), function(i, d) {
      col <- rep("observed", nrow(d))
      col[is.na(d[, i])] <- "missing"
      col
    }, dafr))
    colnames(temp) <- colnames(dafr)
    temp
  } else {
    dafr
  }
}

#' Takes a data.frame as generated from the
#' \texttt(get.missing.categorical) function and converts it
#' into a data.frame of all unique rows and there counts in
#' the original data. It is a modified version of the
#' calmissing.data.frame method from the iNZightMR package.
#'
#' @param dafr A data.frmae to convert
#' @param simplify Returns the smallest number of possible
#' rows, ignoring columns which do not contain NA values if
#' TRUE, otherwise it processes the whole input.
#' @param convert TRUE if the input data.frame should be
#' converted into "missing" or observed format.
#'
#' @return A data.frame with all unique rows from dafr and
#' their counts in the last column.
#'
#' @author Christoph Knapp
get.combinations <- function(dafr, simplify = F) {
  dafr <- data.frame(dafr, stringsAsFactors = TRUE)
  index.column <- rep(T, ncol(dafr))
  rm.na <- function(variable) {
    sum(is.na(variable)) > 0
  }
  if (simplify) {
    index.column <- sapply(dafr, rm.na)
  }
  x <- data.frame(dafr[, index.column], stringsAsFactors = TRUE)
  if (ncol(x) == 0) {
    return(NULL)
  }

  x1 <- as.numeric(apply(x, 2, function(x) length(which(is.na(x)))))
  row4col.order <- order(x1)
  x1 <- c(x1, nrow(x))
  z1 <- ifelse(is.na(x), "missing", "observed")
  tab <- table(apply(z1, 1, paste, collapse = ","))
  tab <- tab[order(names(tab), decreasing = TRUE)]
  tab <- data.frame(
    combination = names(tab),
    count = as.numeric(tab), stringsAsFactors = TRUE
  )
  tabp <- t(apply(tab, 1, function(x) {
    unlist(strsplit(x, ",", fixed = TRUE))
  }))
  tabp <- data.frame(tabp, stringsAsFactors = F)
  tabp <- tabp[, c(row4col.order, max(row4col.order) + 1)]

  #  x1[row4col.order] == numMiss
  tabp <- rbind(tabp, x1[c(row4col.order, max(row4col.order) + 1)])
  names(tabp) <- c(names(x)[row4col.order], "Total")
  row.names(tabp) <- c(seq_len(nrow(tab)), "Total")

  tabfinal <- tabp[-nrow(tabp), ]
  tabfinal <- tabfinal[order(tabfinal$Total, decreasing = TRUE), ]
  tabfinal <- rbind(tabfinal, tabp[nrow(tabp), ])

  finaltable <- tabfinal

  Name <- names(finaltable)
  i <- nrow(finaltable)
  j <- ncol(finaltable)
  index <- order(x1[-j], decreasing = FALSE)
  numMiss <- x1[c(index, j)]
  percMiss <- round(numMiss / numMiss[j], 3)

  finaltable <- rbind(finaltable, paste0(round(percMiss * 100, 2), "%"))
  colnames(finaltable)[j] <- "Freq"
  finaltable
}

##########################################################
# To be removed when the iNZight tools package is working##
##########################################################
#' Takes an input string of a formula involving colummn
#' names in the input data set and tries to evaluate it.
#' If this is not possible, NULL is returned and the error
#' is printed to standard out.
#'
#' @param dafr The data.frame containing the data needed
#' to evaluate the expression.
#' @param new.formula The character string holding the
#' expression to be evaluated.
#'
#' @return Null if the expression could not be evaluated,
#' otherwise the input data.frame with one additional
#' column. This column contains the results of the
#' expression.
#'
#' @author Christoph Knapp
get.create.variables <- function(dafr, new.formula, new.name = NULL) {
  tryCatch(
    {
      colu <- eval(parse(text = new.formula), dafr)
      if (length(colu) > nrow(dafr)) {
        colu <- colu[1:nrow(dafr)]
      }
      temp <- cbind(dafr, colu)
      if (is.null(new.name) || "" %in% new.name) {
        new.name <- "new.name"
      }
      count <- 0
      while (new.name %in% colnames(dafr)) {
        count <- count + 1
        new.name <- paste(new.name, count, sep = ".")
      }
      colnames(temp)[ncol(temp)] <- new.name
      temp
    },
    error = function(cond) {
      return(NULL)
    },
    warning = function(cond) {},
    finally = {}
  )
}

##########################################################
# To be removed when the iNZight tools package is working##
##########################################################
#' Collapses selected levels in factor vector
#'
#' @param column the vector where levels should be
#' collapsed into one.
#' @param to.collapse Vector of levels to collapse.
#'
#' @note Levels in to.collapse which are not in column
#' will be ignored.
#'
#' @author Christoph Knapp
get.collapsed.column <- function(column, to.collapse) {
  column <- as.character(column)
  new.level <- paste(to.collapse, collapse = ".")
  indices <- which(column %in% to.collapse)
  if (length(indices) > 0) {
    column[indices] <- new.level
  }
  as.factor(column)
}

#' The iNZight version of the order function which lets you pass
#' in a list of vectors to order instead of the ... argument. It
#' is shortened and might be therefore not as stable as the
#' original order function.
#'
#' @param z a sequence of numeric, complex, character or logical
#' vectors, all of the same length, or a classed R object.
#' @param na.last for controlling the treatment of NAs. If TRUE,
#' missing values in the data are put last; if FALSE, they are
#' put first; if NA, they are removed (see ‘Note’.)
#' @param decreasing logical. Should the sort order be increasing
#' or decreasing?
#'
#' @note This function is only called in sort.data but needs to be
#' available to sort.data
#'
#' @author Christoph Knapp
order.overwrite <- function(z, na.last = TRUE, decreasing = FALSE) {
  if (any(diff(l.z <- vapply(z, length, 1L)) != 0L)) {
    stop("argument lengths differ")
  }
  ans <- vapply(z, is.na, rep.int(NA, l.z[1L]))
  ok <- if (is.matrix(ans)) {
    !apply(ans, 1, any)
  } else {
    !any(ans)
  }
  if (all(!ok)) {
    return(integer())
  }
  z[[1L]][!ok] <- NA
  ans <- do.call("order", c(z, decreasing = decreasing))
  keep <- seq_along(ok)[ok]
  ans[ans %in% keep]
}

#' Returns the names of all numeric columns in data
#'
#' @param dafr The input dataframe to be searched.
#'
#' @author Christoph Knapp
get.numeric.column.names <- function(dafr) {
  colnames(dafr)[which(unlist(lapply(1:ncol(dafr), function(index, d) {
    is.numeric(as.data.frame(d, stringsAsFactors = TRUE)[, index])
  }, dafr)))]
}

#' Returns the column names of the currently selected data which
#' can be converted into factors.
#'
#' @param dafr The input dataframe to be searched.
#'
#' @author Christoph Knapp
get.categorical.column.names <- function(dafr) {
  colnames(dafr)[which(unlist(lapply(1:ncol(dafr), function(index, d) {
    class(as.data.frame(d, stringsAsFactors = TRUE)[, index]) %in% "factor" ||
      class(as.data.frame(d, stringsAsFactors = TRUE)[, index]) %in% "character"
  }, dafr)))]
}


#' Returns TRUE if x can be converted to a numeric
#' value, FALSE if not.
#'
#' @param x any oblect to be tested
#'
#' @author Christoph Knapp
is.convertable.numeric <- function(x) {
  !suppressWarnings(is.na(as.numeric(x)))
}

#' Tests whether a character variable is convertable to an
#' integer value.
#'
#' @param x a character or numeric value to test for.
#'
#' @author Christoph Knapp
is.convertable.integer <- function(x) {
  temp <- is.convertable.numeric(x)
  temp[temp] <- as.numeric(x[temp]) %% 1 == 0
  temp
}

#' Prints a summary of the currently selected data set.
#'
#' @author Christoph Knapp
data.summary <- function(dafr) {
  if (!is.null(dafr)) {
    cat("Number of rows in data: ", nrow(dafr), "\n")
    cat("Number of columns in data: ", ncol(dafr), "\n")
    cat("\n")
    for (col in 1:length(colnames(dafr))) {
      cat(colnames(dafr)[col], "\n")
      print(summary(dafr[, col]))
    }
  }
}

#' Creates a widget for moving through plots quickly.
#'
#' @param ID.forward inputID for the forward button in the player widget
#' @param ID.player inputID for the slider in the player widget
#' @param ID.backward inputID for the backward button in the player widget
#'
#' @author Christoph Knapp
get.player <- function(ID.forward, ID.player, ID.backward, maxi) {
  fixedRow(column(
    width = 8, offset = 2,
    div(
      class = "player",
      fixedRow(
        column(
          width = 1, offset = 1,
          div(
            class = "seper",
            actionButton(
              inputId = ID.backward,
              label = "", icon = icon("backward")
            )
          )
        ),
        column(
          width = 6, offset = 1,
          sliderInput(
            inputId = ID.player, label = "", min = 1, max = maxi, step = 1,
            animate = animationOptions(interval = 500, loop = T, play = T),
            width = "100%", value = 1, ticks = F
          )
        ),
        column(
          width = 1, offset = 1,
          div(
            class = "seper",
            actionButton(
              inputId = ID.forward,
              label = "", icon = icon("forward")
            )
          )
        )
      )
    )
  ))
}

#' changes numeric columns to factor columns
#'
#' @param temp a matrix or data.frame with columns to change
#' @param columns a vector of column names for temp
#'
#' @return a data.frame where all numeric columns are
#' converted into character column
#'
#' @author Christoph Knapp
change.factor.transform <- function(temp, columns) {
  temp <- as.data.frame(temp, stringsAsFactors = TRUE)
  nums <- unlist(lapply(1:ncol(temp), function(index, temp.data, columns) {
    if (is.numeric(temp.data[, index])) {
      columns[index]
    } else {
      NULL
    }
  }, temp, columns))
  temp <- as.data.frame(
    stringsAsFactors = TRUE,
    do.call(cbind, lapply(1:ncol(temp), function(index, temp.data) {
      if (is.numeric(temp.data[, index])) {
        as.character(temp.data[, index])
      } else {
        NULL
      }
    }, temp)), stringsAsFactors = T
  )
  if (!is.null(temp) && ncol(temp) > 0 && nrow(temp) > 0) {
    colnames(temp) <- paste("factors", nums, sep = "_")
    temp
  } else {
    NULL
  }
}

#' change the sign of numeric columns
#'
#' @param dafr a data frame with columns to transform
#' @param columns the column names of the columns in dafr
#'
#' @author Christoph Knapp
change.sign.transform <- function(dafr, columns) {
  dafr <- as.data.frame(dafr, stringsAsFactors = TRUE)
  temp <- as.data.frame(
    stringsAsFactors = TRUE,
    do.call(cbind, lapply(1:ncol(dafr), function(index, dafr) {
      if (is.numeric(dafr[, index])) {
        as.matrix(dafr[, index] * (-1))
      } else {
        NULL
      }
    }, dafr))
  )
  if (!is.null(temp)) {
    colnames(temp) <- paste("change_sign",
      columns[unlist(lapply(1:ncol(dafr), function(i, d) {
        is.numeric(d[, i])
      }, dafr))],
      sep = "."
    )
  }
  temp
}

test.for.dates <- function(dafr) {
  ret <- F
  if (!is.null(dafr)) {
    ret <- unlist(lapply(
      1:ncol(dafr), function(index, d) {
        tryCatch(
          {
            is.numeric(as.numeric(as.Date(d[, index], origin = "1900-01-01")))
          },
          error = function(cond) {
            ret <- F
          },
          warning = function(cond) {
            print(cond)
          },
          finally = {}
        )
      }, dafr
    ))
  }
  ret
}

copy.transform <- function(dafr, columns) {
  data <- as.data.frame(dafr, stringsAsFactors = TRUE)
  colnames(dafr) <- paste("copy", columns, sep = ".")
  data
}

reverse.coding.transform <- function(dafr, columns) {
  data <- as.data.frame(dafr, stringsAsFactors = TRUE)
  temp <- as.data.frame(
    stringsAsFactors = TRUE,
    do.call(cbind, lapply(1:ncol(dafr), function(index, d) {
      if (is.numeric(d[, index])) {
        min(d[, index], na.rm = T) + max(d[, index], na.rm = T) - d[, index]
      } else {
        NULL
      }
    }, dafr))
  )
  if (!is.null(temp)) {
    colnames(temp) <- paste("reverse_coding",
      columns[unlist(lapply(
        1:ncol(dafr),
        function(i, d) {
          is.numeric(d[, i])
        }, dafr
      ))],
      sep = "."
    )
  }
  temp
}

median.split.transform <- function(dafr, columns) {
  dafr <- as.data.frame(dafr, stringsAsFactors = TRUE)
  nums <- unlist(lapply(1:ncol(dafr), function(index, dafr) {
    is.numeric(dafr[, index])
  }, dafr))
  dafr <- as.data.frame(
    stringsAsFactors = TRUE,
    do.call(cbind, lapply(1:ncol(dafr), function(index, d) {
      if (is.numeric(d[, index])) {
        med <- median(d[, index], na.rm = T)
        ret <- rep("high", length(d[, index]))
        ret[which(d[, index] <= med)] <- "low"
        ret
      } else {
        NULL
      }
    }, dafr)), stringsAsFactors = T
  )
  colnames(dafr) <- paste("median_split", columns[nums], sep = "_")
  dafr
}

standardize.transform <- function(dafr, columns) {
  dafr <- as.data.frame(dafr, stringsAsFactors = TRUE)
  dafr <- as.data.frame(
    stringsAsFactors = TRUE,
    do.call(cbind, lapply(1:ncol(dafr), function(index, d) {
      if (is.numeric(d[, index])) {
        (d[, index] - mean(d[, index], na.rm = T)) / sd(d[, index], na.rm = T)
      } else {
        (as.numeric(factor(d[, index]))
        - mean(as.numeric(factor(d[, index])), na.rm = T)) /
          sd(as.numeric(factor(d[, index])), na.rm = T)
      }
    }, dafr))
  )
  colnames(dafr) <- paste("standardize", columns, sep = ".")
  dafr
}

center.transform <- function(dafr, columns) {
  data <- as.data.frame(dafr, stringsAsFactors = TRUE)
  temp <- as.data.frame(
    stringsAsFactors = TRUE,
    do.call(cbind, lapply(1:ncol(dafr), function(index, d) {
      if (is.numeric(d[, index])) {
        d[, index] - mean(d[, index])
      } else {
        as.numeric(factor(d[, index])) - mean(as.numeric(factor(d[, index])))
      }
    }, dafr))
  )
  colnames(temp) <- paste("center", columns, sep = ".")
  temp
}

divide.transform <- function(dafr, columns) {
  dafr <- as.data.frame(dafr, stringsAsFactors = TRUE)
  colnames(dafr) <- columns
  if (is.null(dafr)) {
    return(NULL)
  } else {
    if (ncol(as.data.frame(
      stringsAsFactors = TRUE,
      dafr[, unlist(lapply(1:ncol(dafr), function(index, d) {
        is.numeric(d[, index])
      }, dafr))]
    )) == 1) {
      temp <- as.data.frame(
        stringsAsFactors = TRUE,
        dafr[, unlist(lapply(1:ncol(dafr), function(index, d) {
          is.numeric(d[, index])
        }, dafr))]
      )
      colnames(temp) <- colnames(data)[unlist(lapply(
        1:ncol(dafr),
        function(index, d) {
          is.numeric(d[, index])
        }, data
      ))]
    } else if (ncol(as.data.frame(
      stringsAsFactors = TRUE,
      dafr[, unlist(lapply(1:ncol(dafr), function(index, d) {
        is.numeric(d[, index])
      }, data))]
    )) > 1) {
      temp <- as.data.frame(
        stringsAsFactors = TRUE,
        divide(dafr[, unlist(lapply(1:ncol(dafr), function(index, d) {
          is.numeric(d[, index])
        }, dafr))])
      )
      colnames(temp) <- paste0(
        "divide.",
        paste(colnames(dafr)[unlist(lapply(1:ncol(dafr), function(index, d) {
          is.numeric(d[, index])
        }, dafr))], collapse = ".")
      )
    } else {
      return(NULL)
    }
  }
  temp
}

divide <- function(dafr) {
  dafr <- dafr[, unlist(lapply(1:ncol(dafr), function(index, d) {
    is.numeric(d[, index])
  }, dafr))]
  dafr <- as.data.frame(dafr, stringsAsFactors = TRUE)
  if (ncol(dafr) == 1) {
    dafr[, 1]
  } else {
    start <- dafr[, 1]
    for (col in 2:ncol(dafr)) {
      start <- start / dafr[, col]
    }
    start
  }
}

multiply.transform <- function(dafr, columns) {
  dafr <- as.data.frame(dafr, stringsAsFactors = TRUE)
  colnames(dafr) <- columns
  if (is.null(dafr)) {
    return(NULL)
  } else {
    if (ncol(as.data.frame(
      stringsAsFactors = TRUE,
      dafr[, unlist(lapply(1:ncol(dafr), function(index, d) {
        is.numeric(d[, index])
      }, dafr))]
    )) == 1) {
      temp <- as.data.frame(
        stringsAsFactors = TRUE,
        dafr[, unlist(lapply(1:ncol(dafr), function(index, d) {
          is.numeric(d[, index])
        }, dafr))]
      )
      colnames(temp) <- colnames(dafr)[unlist(lapply(
        1:ncol(dafr),
        function(index, d) {
          is.numeric(d[, index])
        }, dafr
      ))]
    } else if (ncol(as.data.frame(
      stringsAsFactors = TRUE,
      dafr[, unlist(lapply(1:ncol(dafr), function(index, d) {
        is.numeric(d[, index])
      }, dafr))]
    )) > 1) {
      temp <- as.data.frame(
        stringsAsFactors = TRUE,
        multiply(dafr[, unlist(lapply(1:ncol(dafr), function(index, d) {
          is.numeric(d[, index])
        }, dafr))])
      )
      colnames(temp) <- paste0(
        "multiply.",
        paste(colnames(dafr)[unlist(lapply(1:ncol(dafr), function(index, d) {
          is.numeric(d[, index])
        }, dafr))], collapse = ".")
      )
    } else {
      return(NULL)
    }
  }
  temp
}

multiply <- function(dafr) {
  dafr <- dafr[, unlist(lapply(1:ncol(dafr), function(index, d) {
    is.numeric(d[, index])
  }, dafr))]
  dafr <- as.data.frame(dafr, stringsAsFactors = TRUE)
  if (ncol(dafr) == 1) {
    dafr[, 1]
  } else {
    start <- dafr[, 1]
    for (col in 2:ncol(dafr)) {
      start <- start * dafr[, col]
    }
    start
  }
}

subtract.transform <- function(dafr, columns) {
  dafr <- as.data.frame(dafr, stringsAsFactors = TRUE)
  colnames(dafr) <- columns
  if (is.null(dafr)) {
    return(NULL)
  } else {
    if (ncol(as.data.frame(
      stringsAsFactors = TRUE,
      dafr[, unlist(lapply(1:ncol(dafr), function(index, d) {
        is.numeric(d[, index])
      }, dafr))]
    )) == 1) {
      temp <- as.data.frame(
        stringsAsFactors = TRUE,
        dafr[, unlist(lapply(1:ncol(dafr), function(index, d) {
          is.numeric(d[, index])
        }, dafr))]
      )
      colnames(temp) <- colnames(dafr)[unlist(lapply(
        1:ncol(dafr),
        function(index, d) {
          is.numeric(d[, index])
        }, dafr
      ))]
    } else if (ncol(as.data.frame(
      stringsAsFactors = TRUE,
      dafr[, unlist(lapply(1:ncol(dafr), function(index, d) {
        is.numeric(d[, index])
      }, dafr))]
    )) > 1) {
      temp <- as.data.frame(
        stringsAsFactors = TRUE,
        subtract(dafr[, unlist(lapply(1:ncol(dafr), function(index, d) {
          is.numeric(d[, index])
        }, dafr))])
      )
      colnames(temp) <- paste0(
        "subtract.",
        paste(colnames(dafr)[unlist(lapply(1:ncol(dafr), function(index, d) {
          is.numeric(d[, index])
        }, dafr))], collapse = ".")
      )
    } else {
      return(NULL)
    }
  }
  temp
}

subtract <- function(dafr) {
  dafr <- dafr[, unlist(lapply(1:ncol(dafr), function(index, d) {
    is.numeric(d[, index])
  }, dafr))]
  dafr <- as.data.frame(
    stringsAsFactors = TRUE,
    dafr
  )
  if (ncol(dafr) == 1) {
    dafr[, 1]
  } else {
    start <- dafr[, 1]
    for (col in 2:ncol(dafr)) {
      start <- start - dafr[, col]
    }
    start
  }
}

add.transform <- function(temp, columns) {
  temp <- as.data.frame(temp, stringsAsFactors = TRUE)
  colnames(temp) <- columns
  if (is.null(temp)) {
    return(NULL)
  } else {
    ret <- as.data.frame(
      stringsAsFactors = TRUE,
      temp[, unlist(lapply(1:ncol(temp), function(index, d) {
        is.numeric(d[, index])
      }, temp))]
    )
    if (ncol(ret) > 1) {
      ret <- as.data.frame(
        stringsAsFactors = TRUE,
        apply(ret, 1, function(row) {
          sum(row)
        })
      )
      colnames(ret) <- paste0("add_", paste(colnames(temp), collapse = "_"))
    } else {
      return(NULL)
    }
  }
  ret
}

# returns the transformed columns and the original data as
# dataframe (cbind(data,<transformed columns>)).
transform.perform <- function(dafr, type, columns) {
  temp <- transform.get.temp(dafr, type, columns)
  if (!is.null(temp)) {
    temp <- cbind(dafr, temp)
  }
  temp
}

# returns the transformed columns and the original columns as
# dataframe (cbind(<original columns>,<transformed columns>)).
transform.tempTable <- function(dafr, type, columns) {
  temp1 <- as.data.frame(
    stringsAsFactors = TRUE,
    dafr[, which(colnames(dafr) %in% columns)]
  )
  colnames(temp1) <- columns
  temp2 <- transform.get.temp(dafr, type, columns)
  if (!is.null(temp2)) {
    temp1 <- data.frame(stringsAsFactors = TRUE, temp1, temp2)
  }
  temp1
}

# transorms the columns named columns in data with the selected
# type (type) of transformation.
transform.get.temp <- function(dafr, type, columns) {
  temp <- NULL
  if (!is.null(columns) && type %in% "log") {
    temp <- log.transform(dafr[, columns], columns)
  } else if (!is.null(columns) & type %in% "add") {
    temp <- add.transform(dafr[, columns], columns)
  } else if (!is.null(columns) & type %in% "subtract") {
    temp <- subtract.transform(dafr[, columns], columns)
  } else if (!is.null(columns) & type %in% "multiply") {
    temp <- multiply.transform(dafr[, columns], columns)
  } else if (!is.null(columns) & type %in% "divide") {
    temp <- divide.transform(dafr[, columns], columns)
  } else if (!is.null(columns) & type %in% "root") {
    temp <- root.transform(dafr[, columns], columns)
  } else if (!is.null(columns) & type %in% "square") {
    temp <- square.transform(dafr[, columns], columns)
  } else if (!is.null(columns) & type %in% "abs") {
    temp <- abs.transform(dafr[, columns], columns)
  } else if (!is.null(columns) & type %in% "center") {
    temp <- center.transform(dafr[, columns], columns)
  } else if (!is.null(columns) & type %in% "standardize") {
    temp <- standardize.transform(dafr[, columns], columns)
  } else if (!is.null(columns) & type %in% "median split") {
    temp <- median.split.transform(dafr[, columns], columns)
  } else if (!is.null(columns) & type %in% "reverse-coding") {
    temp <- reverse.coding.transform(dafr[, columns], columns)
  } else if (!is.null(columns) & type %in% "copy") {
    temp <- copy.transform(dafr[, columns], columns)
  } else if (!is.null(columns) & type %in% "change sign") {
    temp <- change.sign.transform(dafr[, columns], columns)
  } else if (!is.null(columns) & type %in% "change to factor") {
    temp <- change.factor.transform(dafr[, columns], columns)
  } else if (!is.null(columns) & type %in% " ") {
    temp <- NULL
  }
  temp
}

log.transform <- function(dafr, columns) {
  dafr <- as.data.frame(dafr, stringsAsFactors = TRUE)
  colnames(dafr) <- columns
  temp <- as.data.frame(
    stringsAsFactors = TRUE,
    do.call(cbind, lapply(1:ncol(dafr), function(index, dafr) {
      if (is.numeric(dafr[, index])) {
        log(dafr[, index])
      } else {
        NULL
      }
    }, dafr))
  )
  if (!is.null(temp) && dim(temp)[1] > 0 && dim(temp)[2] > 0) {
    colnames(temp) <- unlist(lapply(1:ncol(dafr), function(index, dafr) {
      if (is.numeric(dafr[, index])) {
        paste0("log.", colnames(dafr)[index])
      } else {
        NULL
      }
    }, dafr))
    temp
  } else {
    NULL
  }
}

root.transform <- function(dafr, columns) {
  dafr <- as.data.frame(dafr, stringsAsFactors = TRUE)
  colnames(dafr) <- columns
  temp <- as.data.frame(
    stringsAsFactors = TRUE,
    do.call(cbind, lapply(1:ncol(dafr), function(index, d) {
      if (is.numeric(d[, index])) {
        sqrt(d[, index])
      } else {
        NULL
      }
    }, dafr))
  )
  ##  temp = as.data.frame(temp)
  if (dim(temp)[1] > 0 && dim(temp)[2] > 0) {
    colnames(temp) <- unlist(lapply(1:ncol(dafr), function(index, d) {
      if (is.numeric(d[, index])) {
        paste0("root.", colnames(d)[index])
      } else {
        NULL
      }
    }, dafr))
    temp
  } else {
    NULL
  }
}

square.transform <- function(dafr, columns) {
  dafr <- as.data.frame(dafr, stringsAsFactors = TRUE)
  colnames(dafr) <- columns
  temp <- as.data.frame(
    stringsAsFactors = TRUE,
    do.call(cbind, lapply(1:ncol(dafr), function(index, d) {
      if (is.numeric(d[, index])) {
        d[, index]^2
      } else {
        NULL
      }
    }, dafr))
  )
  ##  temp = as.data.frame(temp)
  if (dim(temp)[1] > 0 && dim(temp)[2] > 0) {
    colnames(temp) <- unlist(lapply(1:ncol(dafr), function(index, d) {
      if (is.numeric(d[, index])) {
        paste0("square.", colnames(d)[index])
      } else {
        NULL
      }
    }, dafr))
    temp
  } else {
    NULL
  }
}

abs.transform <- function(dafr, columns) {
  dafr <- as.data.frame(dafr, stringsAsFactors = TRUE)
  colnames(dafr) <- columns
  temp <- as.data.frame(
    stringsAsFactors = TRUE,
    do.call(cbind, lapply(1:ncol(dafr), function(index, d) {
      if (is.numeric(d[, index])) {
        abs(d[, index])
      } else {
        NULL
      }
    }, dafr))
  )
  if (dim(temp)[1] > 0 && dim(temp)[2] > 0) {
    colnames(temp) <- unlist(lapply(1:ncol(dafr), function(index, d) {
      if (is.numeric(d[, index])) {
        paste0("abs.", colnames(d)[index])
      } else {
        NULL
      }
    }, dafr))
    temp
  } else {
    NULL
  }
}

delete.old.files <- function(data_dir, days) {
  if (length(list.files(paste0(data_dir, "/Imported"))) > 0) {
    unlink(list.files(paste0(data_dir, "/Imported"))[
      difftime(Sys.time(),
        file.info(list.files(
          paste0(data_dir, "/Imported"),
          full.name = T
        ))
        [, "mtime"],
        units = "days"
      ) > days
    ])
  }
}

###  A function for displaying help messages.

help.display <- function(title, id, file) {
  HTML(paste("<div class='modal fade' id='", id,
    "' tabindex='-1' role='dialog' aria-labelledby='basicModal'
       aria-hidden='true'>
             <div class='modal-dialog'>
             <div class='modal-content'>
             <div class='modal-header'>
             <h4 class='modal-title' id='myModalLabel'>", title, "</h4>
             </div>
             <div class='modal-body'>",
    mark_html(file = file, output = NULL, template = FALSE),
    "</div>
             <div class='modal-footer'>
             </div>
             </div>
             </div>
             </div>
             <a href='#' class='btn btn-xs btn-success' data-toggle='modal'
              data-target='#", id, "'>Help</a>",
    sep = ""
  ))
}

## reads a data set from a filename in the data directory
load.data <- function(data_dir, fileID = NULL, path = NULL) {
  temp <- NULL
  full.name <- list.files(data_dir, full.names = T, recursive = T)
  if (!is.null(fileID)) {
    if (is.null(path)) {
      indexes <- grep(paste(fileID, ".", sep = ""), full.name, fixed = T)
    } else if (!is.null(path) & file.exists(path)) {
      full.name <- path
      indexes <- 1
    } else {
      return(list(NULL, NULL))
    }
    if (length(indexes[1]) > 0) {
      ext <- strsplit(full.name[indexes[1]], ".", fixed = T)[[1]]
      ext <- ext[length(ext)]
      if (!(tolower(ext) %in% c(
        "rds", "rda", "rdata", "csv", "txt", "xls", "xlsx"
      ))) {
        ext <- strsplit(fileID, ".", fixed = T)[[1]]
        ext <- ext[length(ext)]
      }
      if (!file.exists(full.name[indexes[1]])) {
        return(list(NULL, NULL))
      }
      # catch possible problems with user data.
      tryCatch({
        if (tolower(ext) %in% "rds") {
          temp <- readRDS(file = full.name[indexes[1]])
        } else if (tolower(ext) %in% "rda" | tolower(ext) %in% "rdata") {
          name <- load(full.name[indexes[1]])
          temp <- get(name)
        } else if (tolower(ext) %in% "csv") {
          temp <- read.csv(full.name[indexes[1]],
            comment.char = "#",
            na.strings = c("NULL", "NA", "N/A", "#N/A", "", "<NA>"),
            stringsAsFactors = TRUE
          )
        } else if (tolower(ext) %in% "txt") {
          temp <- read.delim(full.name[indexes[1]],
            comment.char = "#",
            na.strings = c("NULL", "NA", "N/A", "#N/A", "", "<NA>"),
            stringsAsFactors = TRUE
          )
        } else if (tolower(ext) %in% "xls") {
          temp <- as.data.frame(
            stringsAsFactors = TRUE,
            read_excel(full.name[indexes[1]])
          )
        } else if (tolower(ext) %in% "xlsx") {
          temp <- as.data.frame(
            stringsAsFactors = TRUE,
            read_excel(full.name[indexes[1]])
          )
        } else if (tolower(ext) %in% "sas7bdat") {
          temp <- as.data.frame(
            stringsAsFactors = TRUE,
            read.sas7bdat(full.name[indexes[1]])
          )
        } else if (tolower(ext) %in% "dta") {
          temp <- as.data.frame(
            stringsAsFactors = TRUE,
            read.dta(full.name[indexes[1]])
          )
        } else if (tolower(ext) %in% "sav") {
          temp <- as.data.frame(
            stringsAsFactors = TRUE,
            read.spss(full.name[indexes[1]],
              use.value.labels = FALSE, to.data.frame = TRUE
            )
          )
        }
      }, error = function(e) {
        print(e)
      }, finally = {})
    }
  }
  if (is.null(fileID)) {
    list(NULL, temp)
  } else {
    list(data.name = basename(fileID), data.set = temp)
  }
}

## returns directories in the data directory
get.data.dirs <- function(data_dir) {
  list.files(data_dir,
    include.dirs = T,
    full.names = T
  )[file.info(paste(data_dir,
    list.files(data_dir),
    sep = "/"
  ))[, "isdir"]]
}

## returns a radioButton widget, for every filename in the dir.lable directory.
get.radio.list <- function(dir.label, idlabel) {
  files <- c()
  files <- list.files(dir.label,
    recursive = T,
    full.name = T
  )[!(file.info(list.files(dir.label,
    recursive = T,
    full.names = T
  ))[, "isdir"])]
  temp.files <- strsplit(files, "/")
  files <- unlist(lapply(
    temp.files,
    function(x, label) {
      paste(x[(which(x %in% label) + 1):length(x)], collapse = "==>")
    },
    strsplit(dir.label, "/", fixed = T)[[1]][
      length(strsplit(dir.label, "/", fixed = T)[[1]])
    ]
  ))
  ret <- NULL
  if (length(files) > 0) {
    columns <- lapply(
      1:length(files),
      function(i, ns) {
        paste(strsplit(ns[i], ".", fixed = T)[[1]][
          1:(length(strsplit(ns[i], ".", fixed = T)[[1]]) - 1)
        ], collapse = ".")
      },
      basename(files)
    )
    ret <- radioButtons(
      inputId = paste(basename(dir.label), idlabel, sep = ""),
      label = basename(dir.label), choices = columns,
      selected = columns[1]
    )
  }
  ret
}

change.file.ext <- function(name, new.ext) {
  splity <- strsplit(name, ".", fixed = T)[[1]]
  if (length(splity) > 1) {
    splity <- paste(paste(splity[1:(length(splity) - 1)], collapse = "."),
      new.ext,
      sep = "."
    )
  } else {
    splity <- paste0(splity, ".", new.ext)
  }
  splity
}

get.vars <- function(vars.path) {
  lines <- c()
  if (is.null(vars.path)) {
    vars.path <- "VARS"
  }
  if (!file.exists(vars.path)) vars.path <- "VARS.default"
  if (file.exists(vars.path)) {
    lines <- scan(vars.path, what = "character", sep = "\n", quiet = T)
  } else {
    stop("The VARS file does not exist.")
  }
  if (length(lines) > 0) {
    ret <- NULL
    for (line in lines) {
      if (!grepl("^#", line)) {
        if (grepl("#", line)) {
          line <- strsplit(line, "#")[[1]][1]
        }
        if (grepl("=", line) && length(strsplit(line, "=")[[1]]) > 1) {
          if (is.null(ret)) {
            ret <- list()
          }
          ret[[trim(strsplit(line, "=")[[1]][1])]] <-
            trim(strsplit(line, "=")[[1]][2])
        }
      }
    }
    ret
  }
}

#' Tests whether a directory has read write execute permissions.
#'
#' @param file The directory path to test
#'
#' @return TRUE if writable and the file exists, otherwise FALSE
#'
#' @note This is a Unix only function. On Windows and all other
#' OS where \code{.Platform$OS.type} is not unix the function
#' returns always TRUE. Extend this function if necessary. Only
#' relevant permission types have been added.
#'
#' @author Christoph Knapp
file.writable <- function(file, debug) {
  tryCatch({
    if (file.exists(file) &&
      "unix" %in% .Platform$OS.type &&
      "Linux" %in% Sys.info()["sysname"]) {
      grepl(
        "777",
        strsplit(system(paste("stat -c \"%a %n\" ", file, sep = ""),
          intern = T
        ), " ")[[1]][1]
      ) ||
        grepl(
          "775",
          strsplit(system(paste("stat -c \"%a %n\" ", file, sep = ""),
            intern = T
          ), " ")[[1]][1]
        ) ||
        grepl(
          "755",
          strsplit(system(paste("stat -c \"%a %n\" ", file, sep = ""),
            intern = T
          ), " ")[[1]][1]
        )
    } else {
      FALSE
    }
  }, error = function(e) {
    return(FALSE)
  }, finally = {})
}

#' Wrapper function for \code{dir.create} which returns
#' whether information whether the directory was created.
#'
#' @param path a character vector containing a single
#' path name. Tilde expansion (see ?path.expand) is done.
#' @param showWarnings logical; should the warnings on
#' failure be shown?
#' @param recursive logical. Should elements of the path
#' other than the last be created? If true, like the Unix
#' command \code{mkdir -p}.
#' @param mode the mode to be used on Unix-alikes: it
#' will be coerced by \code{?as.octmode}. For
#' \code{Sys.chmod} it is recycled along paths.
#'
#' @note This function does most likely not work on a
#' windows System.
#'
#' @return TRUE if the directory was created, FALSE if
#' not.
#'
#' @author Christoph Knapp
dir.create.logical <- function(path,
                               showWarnings = TRUE,
                               recursive = FALSE,
                               mode = "0777") {
  result <- tryCatch({
    if (!file.exists(path)) {
      dir.create(path, showWarnings, recursive, mode)
    }
    TRUE
  }, warning = function(w) {
    return(FALSE)
  }, error = function(e) {
    return(FALSE)
  }, finally = {})
}

trim <- function(x) gsub("^\\s+|\\s+$", "", x)

get.quantiles <- function(subx) {
  g1 <- rep("", length(subx))
  if (is.numeric(subx)) {
    quant <- quantile(subx, na.rm = T)
    g1[which(subx >= quant[1] & subx < quant[2])] <-
      paste(round(quant[1], 2), round(quant[2], 2), sep = "-")
    g1[which(subx >= quant[2] & subx < quant[3])] <-
      paste(round(quant[2], 2), round(quant[3], 2), sep = "-")
    g1[which(subx >= quant[3] & subx < xquant[4])] <-
      paste(round(quant[3], 2), round(quant[4], 2), sep = "-")
    g1[which(subx >= quant[4] & subx <= quant[5])] <-
      paste(round(quant[4], 2), round(quant[5], 2), sep = "-")
    g1 <- as.factor(g1)
  }
  g1
}

#' Make Syntactically Valid Names
#'
#' @param names vector to be coerced to syntactically valid names.
#'
#' @description Replace spaces with underscores and any other
#' invalid characters to dots
#'
#' @return Character vector of valid names
make_names <- function(names) {
  names <- gsub("\\s+", "_", names)
  names <- make.names(names)

  return(names)
}

#' Loads data from a specified URL
#'
#' @param URL A valid URL pointing to a data set
#' @param data.dir.import The directory the data set
#' should be downloaded to
#'
#' @return A list of two elements.
#'         data.set = A data.frame object containing the loaded data.set
#'         data.name = The name of the data set as retrieved from the URL
#'
#' @note This method is using the function download.file and the wget method.
#' This might not work in all possible cases.
#'
#' @author Christoph Knapp

parseQueryString <- function(str) {
  if (grepl("docs.google.com", str)) {
    return(list(
      url = sub(".*?url=(.*?)&land.*", "\\1", str),
      land = sub(".*?&land=(.*?)", "\\1", str)
    ))
  } else {
    shiny::parseQueryString(str)
  }
}

# # deprecated
get.data.from.URL <- function(URL, data.dir.import) {
  ret <- list()
  URL <- URLencode(URL)

  if (grepl("docs.google.com", URL)) {
    url.index <- gregexpr("output=", URL)
    url.index <- unlist(url.index)
    file.type <- substr(URL, url.index + 7, nchar(URL))
    temp.file.name <- tempfile()
    temp.file.name.index <- gregexpr("file", temp.file.name)
    temp.file.name.index <- unlist(temp.file.name.index)
    file.name <- substr(
      temp.file.name,
      temp.file.name.index, nchar(temp.file.name)
    )
    name <- paste(file.name, file.type, sep = ".")
  } else {
    name <- strsplit(URL, "/")[[1]]
    name <- strsplit(name[length(name)], "?", fixed = T)[[1]][1]
  }

  if (!file.exists(paste(data.dir.import, "/Imported", sep = "")) &&
    file.writable(data.dir.import)) {
    dir.create(paste(data.dir.import, "/Imported", sep = ""), recursive = TRUE)
  }

  tryCatch({
    if (Sys.info()["sysname"] %in% c("Windows", "Linux")) {
      download.file(
        url = URL,
        destfile = paste0(data.dir.import, "/Imported/", name), method = "auto"
      )
    } else {
      download.file(
        url = URL,
        destfile = paste0(data.dir.import, "/Imported/", name), method = "auto"
      )
    }

    temp <- load.data(data.dir.import,
      fileID = name,
      path = paste0(data.dir.import, "/Imported/", name)
    )
    if (!is.null(temp[[2]])) {
      ret$data.set <- temp[[2]]
      ret$data.name <- name
    } else {
      return(NULL)
    }
    ret
  }, error = function(e) {
    if (file.exists(paste0(data.dir.import, "/Imported/", name))) {
      unlink(paste0(data.dir.import, "Imported/", name))
    }
    print(e)
  }, warning = function(w) {
    print(w)
  }, finally = {
    if (file.exists(paste0(data.dir.import, "/Imported/", name))) {
      unlink(paste0(data.dir.import, "/Imported/", name))
    }
  })
}

get.data.name.from.URL <- function(URL) {
  if (grepl("docs.google.com", URL)) {
    url.index <- gregexpr("output=", URL)
    url.index <- unlist(url.index)
    file.type <- substr(URL, url.index + 7, nchar(URL))
    temp.file.name <- tempfile()
    temp.file.name.index <- gregexpr("file", temp.file.name)
    temp.file.name.index <- unlist(temp.file.name.index)
    file.name <- substr(
      temp.file.name,
      temp.file.name.index, nchar(temp.file.name)
    )
    name <- paste(file.name, file.type, sep = ".")
  } else {
    name <- strsplit(URL, "/")[[1]]
    name <- strsplit(name[length(name)], "?", fixed = T)[[1]][1]
  }
  return(name)
}

# get data from google docs urls
get.data.from.googledocs <- function(URL, data.dir.import) {
  ret <- list()
  URL <- URLencode(URL)
  url.index <- gregexpr("output=", URL)
  url.index <- unlist(url.index)
  file.type <- substr(URL, url.index + 7, nchar(URL))
  temp.file.name <- tempfile()
  temp.file.name.index <- gregexpr("file", temp.file.name)
  temp.file.name.index <- unlist(temp.file.name.index)
  file.name <- substr(
    temp.file.name,
    temp.file.name.index, nchar(temp.file.name)
  )
  name <- paste(file.name, file.type, sep = ".")
  if (!file.exists(paste(data.dir.import, "/Imported", sep = "")) &&
    file.writable(data.dir.import)) {
    dir.create(paste(data.dir.import, "/Imported", sep = ""), recursive = TRUE)
  }
  tryCatch({
    if (Sys.info()["sysname"] %in% c("Windows", "Linux")) {
      download.file(
        url = URL,
        destfile = paste0(data.dir.import, "/Imported/", name), method = "auto"
      )
    } else {
      download.file(
        url = URL,
        destfile = paste0(data.dir.import, "/Imported/", name), method = "auto"
      )
    }

    temp <- load.data(data.dir.import,
      fileID = name,
      path = paste0(data.dir.import, "/Imported/", name)
    )
    if (!is.null(temp[[2]])) {
      ret$data.set <- temp[[2]]
      ret$data.name <- name
    } else {
      return(NULL)
    }
    ret
  }, error = function(e) {
    if (file.exists(paste0(data.dir.import, "/Imported/", name))) {
      unlink(paste0(data.dir.import, "Imported/", name))
    }
    print(e)
  }, warning = function(w) {
    print(w)
  }, finally = {})
}

#' Connerts transparency or alpha value to a
#' percentage integer.
#'
#' @param value Value to convert. Either a
#' value between 0 and 1 in steps of 0.01
#' (back = T) or a value between 0 and 100
#' (back = F).
#' @param back Wether to convert from
#' percentage into fraction (back = T) or
#' from fraction to percentage (back = F).
#'
convert.to.percent <- function(value, back = F) {
  # percentage to numeric
  if (is.null(value)) {
    if (!back) {
      x <- 0
    } else {
      x <- 1
    }
  } else {
    if (back) {
      x <- (100 - value) * 0.01
    } else {
      x <- (1 - value) * 100
    }
  }
  x
}

get.transformation.string <- function(transform_select,
                                      transform_variable_select,
                                      arg3) {
  transformation.string <- ""
  if (transform_select %in% "log") {
    transformation.string <- paste0(
      "log(",
      transform_variable_select,
      ")"
    )
  } else if (transform_select %in% "sqrt") {
    transformation.string <- paste0(
      "sqrt(",
      transform_variable_select,
      ")"
    )
  } else if (transform_select %in% "by degree" &&
    !arg3 %in% "") {
    transformation.string <- paste0(
      "I(",
      transform_variable_select,
      "^",
      arg3,
      ")"
    )
  } else if (transform_select %in% "polynomial of degree" &&
    !arg3 %in% "") {
    transformation.string <- paste0(
      "poly(",
      transform_variable_select,
      ",", arg3, ")"
    )
  }
  transformation.string
}
#' Searches a list recursivly for a name and
#' returns the value associated with the name
#'
#' @param list.seach A list to search
#' @param search.name A name to be found in a list.
#' If null, the whole simplified list is returned.
#'
#' @return The value found in the list associated with
#' search.name, NULL if not there.
#'
#' @note This function is used to change the
#' everchanging plot output from iNZightPlot.
#'
#' @author Christoph Knapp
search.name <- function(list.search, search.name = NULL) {
  list.out <- list()
  search <- function(input.list, nam = NULL) {
    if (
      #       "list"%in%class(input.list)||
      "inzplotoutput" %in% class(input.list) ||
        "inzgrid" %in% class(input.list) ||
        "inzpar.list" %in% class(input.list) ||
        "inzdot" %in% class(input.list) ||
        "inzhist" %in% class(input.list) ||
        "inzscatter" %in% class(input.list) ||
        "inzbar" %in% class(input.list)) {
      for (i in 1:length(input.list)) {
        if (!is.null(names(input.list)[i])) {
          nam <- names(input.list)[i]
        } else {
          nam <- i
        }
        search(input.list[[nam]], nam)
      }
    } else {
      if (is.null(nam)) {
        nam <- length(list.out) + 1
      }
      if (!is.null(input.list)) {
        if (nam %in% names(list.out)) {
          temp <- list.out[[nam]]
          list.out[[nam]][[length(list.out[[nam]]) + 1]] <<- input.list
        } else {
          list.out[[nam]] <<- list(input.list)
        }
      }
    }
  }
  search(list.search)
  if (is.null(search.name)) {
    list.out
  } else {
    list.out[[search.name]]
  }
}

modifyList <- function(x, val, keep.null = FALSE) {
  stopifnot(is.list(x), is.list(val))
  xnames <- names(x)
  vnames <- names(val)
  vnames <- vnames[vnames != ""]
  if (keep.null) {
    for (v in vnames) {
      x[v] <- if (v %in% xnames && is.list(x[[v]]) && is.list(val[[v]])) {
        list(modifyList(x[[v]], val[[v]], keep.null = keep.null))
      } else {
        val[v]
      }
    }
  } else {
    for (v in vnames) {
      x[[v]] <- if (v %in% xnames && is.list(x[[v]]) &&
        is.list(val[[v]])) {
        modifyList(x[[v]], val[[v]], keep.null = keep.null)
      } else {
        val[[v]]
      }
    }
  }
  x
}


#' fit the regression model using n-way anova (n = 1,2,3)
#'
#' @param y response variable.
#' @param x covariates.
#' @param data Dataset
#' @param blocking blocking variable
#' @param name name of fitted model
#' @param data.name name of data
#'
#' @return A fitted model with 'code' attribute

anova.fit <- function(y, x, data = NULL, blocking = NULL, name, data.name) {
  # code.list = list()
  fit.str <- NULL
  if (!is.null(blocking)) {
    fit.str <- sprintf("%s ~ %s", y, paste(x, collapse = " * "))
    fit <- nlme::lme(as.formula(fit.str),
      random = as.formula(sprintf("~1|%s", blocking)), data = data
    )
    attr(fit, "code") <- sprintf(
      "%s = nlme::lme(%s ~ %s, random = ~1|%s, data = %s)",
      name, y, paste(x, collapse = " * "), blocking, data.name
    )
  } else {
    fit.str <- sprintf("%s ~ %s", y, paste(x, collapse = " * "))
    fit <- lm(as.formula(fit.str), data = data)
    attr(fit, "code") <- sprintf(
      "%s = lm(%s ~ %s, data = %s)", name, y,
      paste(x, collapse = " * "), data.name
    )
  }
  fit
}


#' fit user's own mixed effect model which include a code attribute
#'
#' @param y response variable.
#' @param x fixed effect
#' @param data Dataset
#' @param blocking random effect
#' @param name name of fitted model
#' @param data.name name of data
#'
#' @return A fitted model with 'code' attribute

fit.own <- function(y, x, data = NULL, blocking = NULL, name, data.name) {
  fit.str <- NULL
  if (!is.null(blocking)) {
    fit.str <- sprintf("%s ~ %s", y, x)
    fit <- nlme::lme(as.formula(fit.str),
      random = as.formula(blocking), data = data
    )
    attr(fit, "code") <- sprintf(
      "%s = nlme::lme(%s ~ %s, random = %s, data = %s)",
      name, y, x, blocking, data.name
    )
  } else {
    fit.str <- sprintf("%s ~ %s", y, x)
    fit <- lm(as.formula(fit.str), data = data)
    attr(fit, "code") <- sprintf(
      "%s = lm(%s ~ %s, data = %s)", name, y,
      x, data.name
    )
  }
  fit
}

#' fit ANOVA (n = 1,2,3)
#'
#' @param y response variable.
#' @param x covariates.
#' @param data Dataset
#' @param blocking blocking variable
#' @param name name of fitted model
#' @param data.name name of data
#'
#' @return ANOVA with 'code' attribute

aov.fit <- function(y, x, data = NULL, blocking = NULL, name, data.name) {
  if (!is.null(blocking)) {
    fit <- aov(as.formula(
      sprintf("%s ~ %s + Error(%s)", y, paste(x, collapse = " * "), blocking)
    ), data = data)
    attr(fit, "code") <- c(
      sprintf(
        "aov_%s = aov(%s ~ %s + Error(%s), data = %s)",
        name, y, paste(x, collapse = " * "), blocking, data.name
      ),
      sprintf("summary(%s)", paste0("aov_", name))
    )
  } else {
    fit <- aov(as.formula(sprintf("%s ~ %s", y, paste(x, collapse = " * "))),
      data = data
    )
    attr(fit, "code") <- c(sprintf(
      "aov_%s = aov(%s ~ %s, data = %s)", name, y,
      paste(x, collapse = " * "), data.name
    ), sprintf("summary(%s)", paste0("aov_", name)))
  }
  fit
}


#' ANOVA for customized which include a code attribute
#'
#' @param y response variable.
#' @param x fixed effect
#' @param data Dataset
#' @param blocking random effect
#' @param name name of fitted model
#' @param data.name name of data
#'
#' @return ANOVA with 'code' attribute

aov.own <- function(y, x, data = NULL, blocking = NULL, name, data.name) {
  fit.str <- sprintf("%s ~ %s", y, x)

  if (!is.null(blocking) && blocking != "") {
    fit <- aov(
      as.formula(sprintf("%s ~ %s + Error(%s)", y, x, blocking)),
      data = data
    )
    attr(fit, "code") <- c(
      sprintf(
        "aov_%s = aov(%s ~ %s + Error(%s), data = %s)",
        name, y, x, blocking, data.name
      ),
      sprintf("summary(%s)", paste0("aov_", name))
    )
  } else {
    fit <- aov(as.formula(sprintf("%s ~ %s", y, x)), data = data)
    attr(fit, "code") <- c(sprintf(
      "aov_%s = aov(%s ~ %s, data = %s)", name, y,
      x, data.name
    ), sprintf("summary(%s)", paste0("aov_", name)))
  }
  fit
}


construct_call <- function(settings, model, vartypes,
                           data = quote(.dataset),
                           design = quote(.design),
                           what = c("plot", "summary", "inference")) {
  if (is.null(model$dataDesign)) design <- NULL
  iNZightPlots:::construct_call(settings, vartypes, data, design, what)
}