Nothing
has.intercept <- function(object, ...) {
UseMethod("has.intercept")
}
has.intercept.default <- function(object, ...) {
has.intercept(formula(object), ...)
}
has.intercept.formula <- function(object, ...) {
attr(terms(object), "intercept") == 1L
}
has.intercept.Formula <- function(object, rhs = NULL, ...) {
## NOTE: return a logical vector of the necessary length
## (which might be > 1)
if(is.null(rhs)) rhs <- 1:length(attr(object, "rhs"))
sapply(rhs, function(x) has.intercept(formula(object, lhs = 0, rhs = x)))
}
has.intercept.mFormula <- function(object, ...){
attr(object, "class") <- "Formula"
has.int <- has.intercept(object)
ifelse(length(has.int) > 1, has.int[2], has.int[1])
}
#' Model formula for logit models
#'
#' Two kinds of variables are used in logit models: alternative specific and
#' individual specific variables. `mFormula` provides a relevant class to
#' deal with this specificity and suitable methods to extract the elements of
#' the model.
#'
#' @name mFormula
#' @aliases mFormula is.mFormula mFormula.formula
#' model.matrix.mFormula model.frame.mFormula
#' @import Formula
#' @param object for the `mFormula` function, a formula, for the
#' `update` and `model.matrix` methods, a `mFormula` object,
#' @param formula a `mFormula` object,
#' @param data a `data.frame`,
#' @param lhs see `Formula`,
#' @param rhs see `Formula`,
#' @param alt.subset a vector of subset of alternatives one want to
#' select,
#' @param reflevel the alternative selected to be the reference
#' alternative,
#' @param ... further arguments.
#' @details Let `J` being the number of alternatives. The formula may
#' include alternative-specific and individual specific
#' variables. For the latter, `J - 1` coefficients are estimated for
#' each variable. For the former, only one (generic) coefficient
#' or `J` different coefficient may be estimated.
#'
#' A `mFormula` is a formula for which the right hand side may contain
#' three parts: the first one contains the alternative specific
#' variables with generic coefficient, *i.e.* a unique coefficient for
#' all the alternatives ; the second one contains the individual
#' specific variables for which one coefficient is estimated for all
#' the alternatives except one of them ; the third one contains the
#' alternative specific variables with alternative specific
#' coefficients. The different parts are separeted by a `|` sign. If
#' a standard formula is writen, it is assumed that there are only
#' alternative specific variables with generic coefficients.
#'
#' The intercept is necessarely alternative specific (a generic
#' intercept is not identified because only utility differences are
#' relevant). Therefore, it deals with the second part of the
#' formula. As it is usual in `R`, the default behaviour is to include
#' an intercept. A model without an intercept may be specified by
#' including `+ 0` or `- 1` in the second right-hand side part of the
#' formula. `+ 0` or `- 1` in the first and in the third part of the
#' formula are simply ignored.
#'
#' Specific methods are provided to build correctly the model matrix
#' and to update the formula. The `mFormula` function is not intended
#' to be use directly. While using the [mlogit()] function, the first
#' argument is automaticaly coerced to a `mFormula` object.
#' @return an object of class `mFormula`.
#' @export
#' @author Yves Croissant
#' @keywords models
#' @examples
#'
#' data("Fishing", package = "mlogit")
#' Fish <- mlogit.data(Fishing, varying = c(2:9), shape = "wide", choice =
#' "mode")
#'
#' # a formula with to alternative specific variables (price and
#' # catch) and an intercept
#' f1 <- mFormula(mode ~ price + catch)
#' head(model.matrix(f1, Fish), 2)
#'
#' # same, with an individual specific variable (income)
#' f2 <- mFormula(mode ~ price + catch | income)
#' head(model.matrix(f2, Fish), 2)
#'
#' # same, without an intercept
#' f3 <- mFormula(mode ~ price + catch | income + 0)
#' head(model.matrix(f3, Fish), 2)
#'
#' # same as f2, but now, coefficients of catch are alternative
#' # specific
#' f4 <- mFormula(mode ~ price | income | catch)
#' head(model.matrix(f4, Fish), 2)
#'
mFormula <- function(object){
UseMethod("mFormula")
}
#' @rdname mFormula
#' @method mFormula formula
#' @export
mFormula.formula <- function(object){
if (!inherits(object, "Formula")) object <- Formula(object)
class(object) <- c("mFormula", "Formula", "formula")
object
}
mFormula.default <- function(object){
stopifnot(inherits(object, "formula"))
if (!inherits(object, "Formula")) object <- Formula(object)
if (!inherits(object, "mFormula"))
class(object) <- c("mFormula", class(object))
object
}
#' @rdname mFormula
#' @export
is.mFormula <- function(object){
inherits(object, "mFormula")
}
#' @rdname mFormula
#' @method model.frame mFormula
#' @export
model.frame.mFormula <- function(formula, data, ..., lhs = NULL, rhs = NULL, alt.subset = NULL, reflevel = NULL){
if (is.null(rhs)) rhs <- 1:(length(formula)[2])
if (is.null(lhs)) lhs <- ifelse(length(formula)[1] > 0, 1, 0)
index <- attr(data, "index")
mf <- model.frame(as.Formula(formula), as.data.frame(data), ..., rhs = rhs)
if (inherits(data, "mlogit.data")){
# obvious condition, model.frame.mFormula is intended for
# mlogit.data and not ordinary data.frame, but the mpbart
# package use it in this way
index <- index[rownames(mf), ]
oindex <- index
# a/ coerce the response to a logical if necessary
y <- model.response(mf)
if (! is.logical(y)){
if (is.factor(y)){
if (length(levels(y)) != 2)
stop("the number of levels for the choice variable should equal two")
y <- y == levels(y)[2]
}
if (is.numeric(y)) y <- y != 0
}
mf[[1]] <- y
# b/ change the reference level of the response if required
if (! is.null(reflevel)){
attr(index, "alt.ordering") <- levels(index$alt)
index$alt <- relevel(index$alt, reflevel)
}
# c/ compute the relevent subset if required
if (! is.null(alt.subset)){
# we keep only choices that belong to the subset
choice <- index$alt[model.response(mf)]
choice <- choice %in% alt.subset
unid <- unique(index$chid)
names(choice) <- as.character(unid)
id.kept <- choice[as.character(index$chid)]
# we keep only the relevant alternatives
alt.kept <- index$alt %in% alt.subset
# the relevant subset for the data.frame and the indexes
mf <- mf[id.kept & alt.kept, , drop = FALSE]
index <- index[id.kept & alt.kept, , drop = FALSE]
# drop the non-selected levels
index$alt <- index$alt[drop = TRUE]
if (! is.null(attr(index, "alt.ordering"))){
attr(index, "alt.ordering") <-
intersect(attr(index, "alt.ordering"), levels(index$alt))
}
}
# d/ balance the data.frame i.e. insert rows with NA when an
# alternative is not relevant
# alt.un <- unique(index$alt)
alt.un <- levels(index$alt)
# be very careful, if some observations are missing unique may
# be different from levels
chid.un <- unique(index$chid)
alt.lev <- levels(index$alt)
J <- length(alt.lev)
n <- length(chid.un)
T <- length(alt.un)
if (nrow(mf) != (n * T)){
rownames(mf) <- paste(index$chid, index$alt, sep = ".")
all.rn <- as.character(t(outer(chid.un, alt.un, paste, sep = ".")))
mf <- mf[all.rn, ]
rownames(mf) <- all.rn
chid <- rep(chid.un, each = T)
alt <- factor(rep(alt.un, n), levels = alt.un, labels = alt.un)
# take care here to make a factor with the levels in the
# correct order
alt[is.na(mf[[1]])] <- NA
index <- data.frame(chid = chid, alt = alt, row.names = rownames(mf))
if (! is.null(oindex$group)){
ra <- oindex[c("alt", "group")][! duplicated(oindex$alt), ]
gps <- ra$group
names(gps) <- ra$alt
index$group <- gps[index$alt]
}
if (! is.null(oindex$id)){
ra <- oindex[c("chid", "id")][! duplicated(oindex$chid), ]
ids <- ra$id
names(ids) <- ra$chid
# YC 2019/12/09 : factor indexation leads to a position and not a character indexing
# index$id <- ids[index$chid]
index$id <- ids[as.character(index$chid)]
index$id <- index$id[drop = TRUE]
}
}
}
# index <- data.frame(lapply(index, function(x) x[drop = TRUE]), row.names = rownames(index))
index$chid <- index$chid[drop = TRUE]
structure(mf,
index = index,
formula = formula,
choice = names(mf)[1],
class = c("mlogit.data", class(mf)))
}
#' @rdname mFormula
#' @method model.matrix mFormula
#' @export
model.matrix.mFormula <- function(object, data, ...){
if (length(object)[2] == 4) object <- formula(object, rhs = 1:3)
K <- length(data)
omitlines <- attr(na.omit(data), "na.action")
index <- attr(data, "index")
alt <- index[["alt"]]
chid <- index[["chid"]]
data$alt <- alt
resp.name <- as.character(attr(object, "lhs")[[1]])
# keep track of the existence of an intercept
has.int <- has.intercept(object)
if (has.int) intercept.char <- "alt" else intercept.char <- NULL
## for ind.spec : remove any 0 or 1 or -1 in the formula and get the
## list of the variables
if (length(object)[2] > 1){
ind.spec <- formula(object, rhs = 2, lhs = 0)
if (!has.int) ind.spec <- update(ind.spec, ~ . + 1)
ind.spec <- update(ind.spec, ~ .)
ind.spec.char <- as.character(ind.spec)[2]
if (ind.spec.char == "1") ind.spec.char <- ind.spec.var <- NULL
else{
# ind.spec.var <- attr(terms(ind.spec), "term.labels") the
# following lines extract the effects and not the variable
# names, useful for factors
ind.spec.var <- colnames(model.matrix(update(ind.spec, ~.+1), data))[-1]
ind.spec.char <- paste("(", ind.spec.char, "):alt", sep="")
}
}
else ind.spec <- ind.spec.char <- ind.spec.var <- NULL
# alternative specific variables
alt.spec <- formula(object, rhs = 1, lhs = 0)
alt.spec <- update(update(alt.spec, ~ . + 1), ~ .)
alt.spec.char <- as.character(alt.spec)[2]
if (alt.spec.char == "1") als.spec <- alt.spec.char <- NULL
# specific coefficient for alternative specific variables
if (length(object)[2] == 3){
coef.spec <- formula(object, rhs = 3, lhs = 0)
coef.spec <- update(update(coef.spec, ~ . + 1), ~ .)
coef.spec.char <- as.character(coef.spec)[2]
if (!is.null(coef.spec.char)) coef.spec.char <- paste("(", coef.spec.char, "):alt", sep="")
}
else coef.spec <- coef.spec.char <- NULL
form.char <- paste(c(intercept.char, alt.spec.char,
ind.spec.char, coef.spec.char),
collapse = "+")
formula <- as.formula(paste(resp.name, " ~ ", form.char))
X <- model.matrix(formula, data)[, -1, drop = F]
lev1 <- levels(alt)[1]
lev1 <- paste("alt", lev1, sep = "")
toremove <- unlist(lapply(as.list(ind.spec.var), function(x) paste(lev1, x, sep = ":")))
revtoremove <- unlist(lapply(as.list(ind.spec.var), function(x) paste(x, lev1, sep = ":")))
toremove <- colnames(X) %in% c(toremove, revtoremove)
X <- X[, ! toremove, drop = FALSE]
# the following lines suppress the mentions to 'alt' in the names of
# the effects and add a mention to '(intercept)'
namesX <- colnames(X)
for (i in 1:length(namesX)) namesX[i] <- sub('alt', '', namesX[i])
z <- match(levels(alt), namesX)
namesX[na.omit(z)] <- paste(levels(alt)[!is.na(z)], '(intercept)', sep=":")
colnames(X) <- namesX
qrX <- qr(na.omit(X))
# remove the linear dependant columns
# X <- X[, qrX$pivot[1:qrX$rank], drop = FALSE]
attr(X, "index") <- index
X
}
as.Formula.mFormula <- function(x, ...){
class(x) <- class(x)[-1]
x
}
#' data.frame for logit model
#'
#' shape a `data.frame` in a suitable form for the use of the
#' `mlogit` function.
#'
#' @name mlogit.data
#' @aliases mlogit.data [[<-.mlogit.data $<-.mlogit.data print.pseries
#' index mean.mlogit.data formula.mlogit.data print.mlogit.data
#' @param data a `data.frame`,
#' @param x,object a `mlogit.data` or a `pseries` object,
#' @param choice the variable indicating the choice made: it can be
#' either a logical vector, a numerical vector with 0 where the
#' alternative is not chosen, a factor with level 'yes' when the
#' alternative is chosen
#' @param shape the shape of the `data.frame`: whether `long` if each
#' row is an alternative or `wide` if each row is an observation,
#' @param varying the indexes of the variables that are alternative
#' specific,
#' @param sep the seperator of the variable name and the alternative
#' name (only relevant for a `wide` `data.frame`),
#' @param alt.var the name of the variable that contains the
#' alternative index (for a `long` `data.frame` only) or the name
#' under which the alternative index will be stored (the default
#' name is `alt`),
#' @param chid.var the name of the variable that contains the choice
#' index or the name under which the choice index will be stored,
#' @param alt.levels the name of the alternatives: if null, for a
#' `wide` data.frame, they are guessed from the variable names and
#' the choice variable (both should be the same), for a `long`
#' `data.frame`, they are guessed from the `alt.var` argument,
#' @param id.var the name of the variable that contains the individual
#' index if any,
#' @param group.var the name of the variable that contains the group
#' index if any,
#' @param opposite returns the opposite of the specified variables,
#' @param drop.index should the index variables be dropped from the
#' `data.frame`,
#' @param ranked a logical value which is true if the response is a
#' rank,
#' @param subset a logical expression which defines the subset of
#' observations to be selected,
#' @param i the rows to extract,
#' @param j the columns to extract,
#' @param y the column of the `data.frame` to extract or to replace,
#' @param value the replacement value,
#' @param drop a boolean, equal to `FALSE` if one wants that a
#' `data.frame` is always returned,
#' @param ... further arguments passed to `reshape`.
#' @return A `mlogit.data` object, which is a `data.frame` in `long`
#' format, *i.e.* one line for each alternative. It has a `index`
#' attribute, which is a `data.frame` that contains the index of
#' the choice made (`chid`), the index of the alternative (`alt`)
#' and, if any, the index of the individual (`id`) and of the
#' alternative groups (`group`). The choice variable is a boolean
#' which indicates the choice made. This function use
#' [stats::reshape()] if the `data.frame` is in `wide` format.
#' @export
#' @author Yves Croissant
#' @seealso [stats::reshape()]
#' @keywords attribute
#' @examples
#' # ModeChoice is a long data.frame
#'
#' data("TravelMode", package = "AER")
#' TM <- mlogit.data(TravelMode, choice = "choice", shape = "long",
#' alt.levels = c("air", "train", "bus", "car"))
#'
#' # Same but the alt variable called mode is provided
#'
#' TM <- mlogit.data(TravelMode ,choice = "choice", shape = "long",
#' alt.var = "mode")
#'
#' # Same but the chid variable called individual is provided
#'
#' TM <- mlogit.data(TravelMode, choice = "choice",
#' shape = "long", id.var = "individual",
#' alt.levels = c("air", "train", "bus", "car"))
#'
#' # Same but with two own provided variables
#'
#' TM <- mlogit.data(TravelMode, choice = "choice", shape = "long",
#' id.var = "individual", alt.var = "mode")
#'
#' # Same but with two own provided variables which are deleted from the
#' # data.frame
#'
#' TM <- mlogit.data(TravelMode, choice = "choice", shape = "long",
#' id.var = "individual", alt.var = "mode", drop.index = TRUE)
#'
#' # Train is a wide data.frame with columns 'choiceid' is the choice
#' # index, the alternatives are named "ch1" and "ch2", the opposite of
#' # the variables is returned
#'
#' data("Train", package = "mlogit")
#' Train <- mlogit.data(Train, choice = "choice", shape = "wide",
#' varying = 4:11, alt.levels = c("A", "B"), sep = "_",
#' opposite = c("price", "time", "change", "comfort"))
#'
#' data("HC", package = "mlogit")
#' HC <- mlogit.data(HC, choice = "depvar", varying=c(2:8, 10:16), shape="wide")
#'
#' # Game is a data.frame in wide format for which the response is a
#' # ranking variable
#'
#' data("Game", package = "mlogit")
#' G <- mlogit.data(Game, shape="wide", varying = 1:12, alt.var = 'platform',
#' drop.index = TRUE, choice="ch", ranked =TRUE)
#'
#' # Game2 contains the same data, but in long format
#' data("Game2", package = "mlogit")
#' G2 <- mlogit.data(Game2, shape='long', choice="ch", alt.var = 'platform', ranked = TRUE)
mlogit.data <- function(data, choice = NULL, shape = c("long", "wide"), varying = NULL,
sep = ".", alt.var = NULL, chid.var = NULL,
alt.levels = NULL, id.var = NULL, group.var = NULL,
opposite = NULL, drop.index = FALSE, ranked = FALSE,
subset = NULL, ...){
# chid.name, alt.name : the name of the index variables
# chid, alt : the index variables
# if a subset argument is prodided, subset the original data frame
cldata <- match.call(expand.dots = TRUE)
if (match("subset", names(cldata), 0)){
m <- match(c("data", "subset"), names(cldata), 0)
cldata <- cldata[c(1, m)]
names(cldata)[2] <- "x"
cldata[[1]] <- as.name("subset")
data <- eval(cldata, parent.frame())
}
# the long shape is now the default
shape <- match.arg(shape)
if (shape == "long"){
if (is.null(chid.var)){
chid.name <- "chid"
chid.is.variable <- FALSE
}
else{
chid.name <- chid.var
chid.is.variable <- ifelse(is.null(data[[chid.var]]), FALSE, TRUE)
}
if (is.null(alt.var) && is.null(alt.levels))
stop("at least one of alt.var and alt.levels should be filled")
if (! is.null(alt.levels)){
J <- length(alt.levels)
n <- nrow(data) / J
alt <- factor(rep(alt.levels, n), levels = alt.levels)
if (!is.null(alt.var) && !is.null(data[[alt.var]])){
warning(paste("variable", alt.var, "exists and will be replaced"))
alt.is.variable <- TRUE
}
else alt.is.variable <- FALSE
alt.name <- ifelse(is.null(alt.var), "alt", alt.var)
}
else{
alt.name <- alt.var
alt.is.variable <- TRUE
if (!is.factor(data[[alt.name]])) data[[alt.name]] <- factor(data[[alt.name]])
alt.levels <- levels(data[[alt.name]])
J <- length(alt.levels)
alt <- data[[alt.name]]
}
n <- nrow(data) / J
if (! chid.is.variable) chid <- rep(1:n, each = J) else chid <- data[[chid.name]]
if (! ranked & ! is.null(choice)){
choice.name <- choice
choice <- data[[choice]]
# coerce the choice variable to a logical if necessary
if (! is.logical(choice)){
if (is.factor(choice)){
if (length(levels(choice)) != 2)
stop("the number of levels for the choice variable should equal two")
choice <- choice == levels(choice)[2]
}
if (is.numeric(choice)) choice <- choice != 0
}
data[[choice.name]] <- choice
}
chid <- as.factor(chid)
alt <- as.factor(alt)
row.names(data) <- paste(chid, alt, sep = ".")
}
if (shape == "wide"){
if (! ranked){
if (is.null(choice)) stop("the choice argument is mandatory for wide-shaped data.frame")
choice.name <- choice
if (is.ordered(data[[choice]])) class(data[[choice]]) <- "factor"
else data[[choice]] <- as.factor(data[[choice]])
}
# this doesn't work for ordered factors which remains ordered
if (is.null(alt.var)) alt.name <- "alt" else alt.name <- alt.var
if (is.null(chid.var)) chid.name <- "chid" else chid.name <- chid.var
if (! is.null(varying)){
data <- reshape(data, varying = varying, direction = "long", sep = sep,
timevar = alt.name, idvar = chid.name, ...)
}
else{
if (ranked)
stop("for ranked data in wide format, the varying argument is mandatory and should contain at least the choice variable")
id.names <- as.numeric(rownames(data))
nb.id <- length(id.names)
data[[chid.name]] <- id.names
lev.ch <- levels(data[[choice]])
data <- data.frame(lapply(data, rep, length(lev.ch)))
data[[alt.name]] <- rep(lev.ch, each = nb.id)
row.names(data) <- paste(data[[chid.name]], data[[alt.name]], sep = ".")
}
data <- data[order(data[[chid.name]], data[[alt.name]]), ]
chid <- as.factor(data[[chid.name]])
alt <- as.factor(data[[alt.name]])
if (! is.null(alt.levels)){
levels(data[[choice]]) <- alt.levels
levels(alt) <- alt.levels
row.names(data) <- paste(chid, alt, sep = ".")
}
if (! ranked){
#YC 20180106 never chosen alternatives are added to the levels of the choice variable
data[[choice]] <- factor(data[[choice]], levels = levels(alt))
data[[choice]] <- data[[choice]] == alt
}
else{
if (is.null(data[[choice]])) stop("the choice variable doesn't exist")
}
}
chidpos <- which(names(data) == chid.name)
altpos <- which(names(data) == alt.name)
if (! is.null(id.var)){
idpos <- which(names(data) == id.var)
id.var <- as.factor(data[[id.var]])
}
if (! is.null(group.var)){
grouppos <- which(names(data) == group.var)
group.var <- as.factor(data[[group.var]])
}
if (drop.index){
if (! is.null(id.var)) data <- data[, -c(chidpos, altpos, idpos)]
else data <- data[, -c(chidpos, altpos)]
}
if (!is.null(opposite)){
for (i in opposite){
data[[i]] <- - data[[i]]
}
}
index <- data.frame(chid = chid, alt = alt)
if (! is.null(id.var)) index <- cbind(index, id = id.var)
if (! is.null(group.var)) index <- cbind(index, group = group.var)
rownames(index) <- rownames(data)
attr(data, "index") <- index
attr(data, "class") <- c("mlogit.data", "data.frame")
if (ranked) data <- mlogit2rank(data, choicename = choice)
if (! ranked & ! is.null(choice)) attr(data, "choice") <- choice.name
data
}
formula.mlogit.data <- function(x, ...) attr(x, "formula")
#' @rdname mlogit.data
#' @export
print.mlogit.data <- function(x, ...){
attr(x, "index") <- NULL
class(x) <- "data.frame"
print(x, ...)
}
#' @rdname mlogit.data
#' @export
index.mlogit.data <- function(x, ...){
attr(x, "index")
}
#' @rdname mlogit.data
#' @export
"[.mlogit.data" <- function(x, i, j, drop = TRUE){
mydata <- `[.data.frame`(x, i, j, drop = drop)
index <- "[.data.frame"(attr(x, "index"), i,)
index <- data.frame(lapply(index, function(x) x[drop = TRUE]), row.names = rownames(mydata))
if (is.null(dim(mydata))){
structure(mydata,
index = index,
class = c("pseries", class(mydata))
)
}
else{
structure(mydata,
index = index,
class = c("mlogit.data", "data.frame"))
}
}
#' @rdname mlogit.data
#' @export
"[[.mlogit.data" <- function(x, y){
index <- attr(x, "index")
attr(x, "index") <- NULL
class(x) <- "data.frame"
result <- x[[y]]
if (!is.null(result)){
result <- structure(result,
class = c("pseries", class(x[[y]])),
index = index,
names = row.names(x)
)
}
result
}
#' @rdname mlogit.data
#' @export
"$.mlogit.data" <- function(x,y){
"[["(x, paste(as.name(y)))
}
#' @rdname mlogit.data
#' @export
"$<-.mlogit.data" <- function(object, y, value){
# object : le data.frame
# y : la variable
# value : la nouvelle valeur
object[[y]] <- value
object
}
#' @rdname mlogit.data
#' @export
"[[<-.mlogit.data" <- function(object, y, value){
if (class(value)[1] == "pseries"){
class(value) <- class(value)[-1]
attr(value, "index") <- NULL
}
object <- "[[<-.data.frame"(object, y, value = value)
object
}
#' @rdname mlogit.data
#' @method mean mlogit.data
#' @export
mean.mlogit.data <- function(x, ...){
alt <- index(x)$alt
J <- length(levels(alt))
result <- data.frame(lapply(x,
function(x){
if (is.numeric(x)) result <- as.numeric(tapply(x, alt, mean))
else{
if (is.logical(x)){
z <- tapply(x, alt, sum)
result <- z == max(z)
}
if(is.character(x)){
x <- factor(x, levels = unique(x))
}
if (is.factor(x)){
result <- factor(names(which.max(table(x))), levels = levels(x))
}
}
result
}
)
)
attr(result, "index") <- data.frame(alt = factor(levels(alt), levels = levels(alt)), chid = rep(1, J))
rownames(result) <- rownames(attr(result, "index")) <- paste(rep(1, J), levels(alt), sep = ".")
class(result) <- c("mlogit.data", "data.frame")
result
}
mlogit2rank <- function(x, choicename, ...){
choicepos <- match(choicename, names(x))
id <- attr(x, "index")$chid
lev.id <- levels(id)
theid <- as.numeric(id)
oalt <- attr(x, "index")$alt
lev.alt <- levels(oalt)
choice <- x[[choicename]]
J <- length(unique(choice))
d <- data.frame()
chid <- c()
alt <- c()
id <- c()
k <- 0
for (i in unique(theid)){
aid <- which(theid == i)
adata <- x[aid, - choicepos]
achoice <- choice[aid]
aalt <- oalt[aid]
remAlts <- rep(TRUE, J)
alogchoice <- achoice == 1
d <- rbind(d, cbind(adata, alogchoice))
Z <- sum(remAlts)
k <- k + 1
chid <- c(chid, rep(k, Z))
id <- c(id, rep(i, Z))
alt <- c(alt, aalt)
for (j in 1:(J - 2)){
k <- k + 1
min.index <- achoice == j
remAlts[min.index] <- FALSE
Z <- sum(remAlts)
chid <- c(chid, rep(k, Z))
alt <- c(alt, aalt[remAlts])
id <- c(id, rep(i, Z))
alogchoice <- achoice[remAlts] == j + 1
d <- rbind(d, cbind(adata[remAlts,], alogchoice))
}
}
colnames(d)[length(d)] <- choicename
alt <- factor(alt, labels = lev.alt)
index <- data.frame(chid = chid, alt = alt, id = id)
rownames(d) <- rownames(index) <- paste(chid, as.character(alt), sep = ".")
structure(d, index = index, class = c('mlogit.data', 'data.frame'))
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.