241023 weijun

learn_lm.R

@@ -0,0 +1,77 @@
+learn_ml <- function (formula, data, subset, weights, na.action, method = "qr",
+    model = TRUE, x = FALSE, y = FALSE, qr = TRUE, singular.ok = TRUE,
+    contrasts = NULL, offset, ...) {
+    ret.x <- x
+    ret.y <- y
+    cl <- match.call()
+    mf <- match.call(expand.dots = FALSE)
+    m <- match(c("formula", "data", "subset", "weights", "na.action",
+        "offset"), names(mf), 0L)
+    mf <- mf[c(1L, m)]
+    mf$drop.unused.levels <- TRUE
+    mf[[1L]] <- quote(stats::model.frame)
+    mf <- eval(mf, parent.frame())
+    if (method == "model.frame")
+        return(mf)
+    else if (method != "qr")
+        warning(gettextf("method = '%s' is not supported. Using 'qr'",
+            method), domain = NA)
+    mt <- attr(mf, "terms")
+    y <- model.response(mf, "numeric")
+    w <- as.vector(model.weights(mf))
+    if (!is.null(w) && !is.numeric(w))
+        stop("'weights' must be a numeric vector")
+    offset <- model.offset(mf)
+    mlm <- is.matrix(y)
+    ny <- if (mlm)
+        nrow(y)
+    else length(y)
+    if (!is.null(offset)) {
+        if (!mlm)
+            offset <- as.vector(offset)
+        if (NROW(offset) != ny)
+            stop(gettextf("number of offsets is %d, should equal %d (number of observations)",
+                NROW(offset), ny), domain = NA)
+    }
+    if (is.empty.model(mt)) {
+        x <- NULL
+        z <- list(coefficients = if (mlm) matrix(NA_real_, 0,
+            ncol(y)) else numeric(), residuals = y, fitted.values = 0 *
+            y, weights = w, rank = 0L, df.residual = if (!is.null(w)) sum(w !=
+            0) else ny)
+        if (!is.null(offset)) {
+            z$fitted.values <- offset
+            z$residuals <- y - offset
+        }
+    }
+    else {
+        x <- model.matrix(mt, mf, contrasts)
+        z <- if (is.null(w))
+            lm.fit(x, y, offset = offset, singular.ok = singular.ok,
+                ...)
+        else lm.wfit(x, y, w, offset = offset, singular.ok = singular.ok,
+            ...)
+    }
+    class(z) <- c(if (mlm) "mlm", "lm")
+    z$na.action <- attr(mf, "na.action")
+    z$offset <- offset
+    z$contrasts <- attr(x, "contrasts")
+    z$xlevels <- .getXlevels(mt, mf)
+    z$call <- cl
+    z$terms <- mt
+    if (model)
+        z$model <- mf
+    if (ret.x)
+        z$x <- x
+    if (ret.y)
+        z$y <- y
+    if (!qr)
+        z$qr <- NULL
+    z
+}
+
+set.seed(123) # 保证随机数可重复
+x <- rnorm(100)
+y <- 20 * x + 23 + rnorm(100)
+
+model <- learn_ml(y ~ x, data = data.frame(x = x, y = y))

mycode/T.R

@@ -0,0 +1,70 @@
+lin_reg <- function(formula, data, subset, save_model = TRUE,
+                    weights = NULL, na.action = na.fail,
+                    model_save_path = NULL, ...) {
+
+  mf <- match.call(expand.dots = FALSE)
+  mf <- mf[c(1L, match(c("formula", "data", "subset", "save_model", "weights", "na.action", "model_save_path"), names(mf), 0L))]
+  mf$drop.unused.levels <- TRUE
+  mf[[1L]] <- as.name("model.frame")
+  mf <- eval(mf, parent.frame())
+
+  mt <- attr(mf, "terms")
+  y <- model.response(mf, "numeric")
+
+  if (!is.null(weights)) {
+    if (!is.numeric(weights))
+      stop("'weights' must be a numeric vector")
+  }
+
+  x <- model.matrix(mt, mf)
+
+  if (is.null(weights)) {
+    coef <- lm.fit(x, y)$coefficients
+  } else {
+    coef <- lm.wfit(x, y, weights)$coefficients
+  }
+
+  model <- structure(list(coefficients = coef, residuals = y - x %*% coef,
+                          call = match.call(), terms = mt, model = mf,
+                          na.action = attr(mf, "na.action"),
+                          xlevels = .getXlevels(mt, mf)),
+                     class = "lin_reg")
+
+  if (save_model) {
+    if (is.null(model_save_path)) {
+      curr_dir <- getwd()
+      model_save_path <- paste(curr_dir, "linear_model.rda", sep = "/")
+    }
+
+    # check model_save_path fairness
+    dir_path <- dirname(model_save_path)
+    if (!file.exists(dir_path)) {
+      dir.create(dir_path, recursive = TRUE)
+    }
+
+    # Check if file already exists, modify filename if needed
+    base_name <- basename(model_save_path)
+    pattern <- paste0("^", gsub("[.]", "\\.", base_name), "$")
+    dir_files <- list.files(dir_path, pattern = pattern, full.names = FALSE)
+
+    i <- 1
+    basename_omit <- strsplit(base_name, "\\.")[[1L]][[1L]]
+    while (base_name %in% dir_files) {
+      base_name <- paste0(basename_omit, i, ".rda")
+      i <- i + 1
+    }
+
+    model_save_path <- file.path(dir_path, base_name)
+    print(cat("model will be save in ", model_save_path))
+    save(model, file = model_save_path)
+  }
+
+  model
+}
+
+# 创建一些数据
+x <- rnorm(100)
+y <- 20 * x + 23 + rnorm(100)
+
+# 使用 lin_reg 训练模型
+model <- lin_reg(y ~ x, data = data.frame(x = x, y = y))

mycode/test1.R

@@ -0,0 +1,30 @@
+if (!requireNamespace("animation")) install.packages("animation")
+library(animation)
+
+# 设置动画参数
+interval <- 20
+ani.options(interval = interval) # 设置帧间隔时间
+
+# 动态拟合线性模型
+dynamic_fit <- function(n_points_max = 100, step = 20) {
+  set.seed(123) # 设置随机种子确保可重复性
+  x <- rnorm(n_points_max)
+  y <- 20 * x + 23 + rnorm(n_points_max) # 生成带有噪声的线性数据
+
+  saveGIF({
+    for (n in seq(step, n_points_max, by = step)) {
+      # 使用前n个点拟合模型
+      model <- lm(y ~ x, data = data.frame(x = x[1:n], y = y[1:n]))
+      # 预测整个x范围内的y值
+      predictions <- predict(model, data.frame(x = seq(min(x), max(x), length.out = 100)))
+      # 绘制当前拟合线
+      plot(x[1:n], y[1:n], pch=19, col="blue", main=paste0("Fitting with ", n, " points"),
+           xlab = "x", ylab = "y")
+      lines(seq(min(x), max(x), length.out = 100), predictions, col="red", lwd=2)
+
+      Sys.sleep(interval) # 暂停一下，让动画效果更明显
+    }
+  }, movie.name = "dynamic_fit.gif", interval = 0.1)
+}
+
+dynamic_fit()

mypkgs/mylin2024111211/.Rbuildignore

@@ -0,0 +1,2 @@
+^mylin2024111211\.Rproj$
+^\.Rproj\.user$

mypkgs/mylin2024111211/.gitignore

@@ -0,0 +1 @@
+.Rproj.user

mypkgs/mylin2024111211/DESCRIPTION

@@ -0,0 +1,12 @@
+Package: mylin2024111211
+Title: What the Package Does (One Line, Title Case)
+Version: 0.0.0.9000
+Authors@R: 
+    person("First", "Last", , "first.last@example.com", role = c("aut", "cre"),
+           comment = c(ORCID = "YOUR-ORCID-ID"))
+Description: What the package does (one paragraph).
+License: `use_mit_license()`, `use_gpl3_license()` or friends to pick a
+    license
+Encoding: UTF-8
+Roxygen: list(markdown = TRUE)
+RoxygenNote: 7.3.2

mypkgs/mylin2024111211/NAMESPACE

@@ -0,0 +1,6 @@
+# Generated by roxygen2: do not edit by hand
+
+S3method(print,lm)
+export(lin_reg)
+export(predict)
+export(save_model)

mypkgs/mylin2024111211/R/lin_reg.R

@@ -0,0 +1,77 @@
+#' Linear Regression Model
+#'
+#' @description train a linear model
+#' @param formula describle model formula, such as y ~ x
+#' @param data data build from data.frame, such as data.frame(x = x, y = y)
+#' @param subset Specify a subset, such as fitting only the portion of
+#'              data greater than 0 in the dataset.
+#' @param  save_model whether save model. Default TRUE
+#' @param weights Optional vector of case weights.
+#' @param na.action Function indicating what should happen when the data contain NAs.
+#'                  default na.fail, optional is [na.omit, ]
+#' @param model_save_path User define the model save path.
+#' @return return a list consist of coefficiences and formula
+#' @export
+lin_reg <- function(formula, data, subset, save_model = TRUE,
+                    weights = NULL, na.action = na.fail,
+                    model_save_path = NULL, ...) {
+
+  mf <- match.call(expand.dots = FALSE)
+  mf <- mf[c(1L, match(c("formula", "data", "subset", "save_model", "weights", "na.action", "model_save_path"), names(mf), 0L))]
+  mf$drop.unused.levels <- TRUE
+  mf[[1L]] <- as.name("model.frame")
+  mf <- eval(mf, parent.frame())
+
+  mt <- attr(mf, "terms")
+  y <- model.response(mf, "numeric")
+
+  if (!is.null(weights)) {
+    if (!is.numeric(weights))
+      stop("'weights' must be a numeric vector")
+  }
+
+  x <- model.matrix(mt, mf)
+
+  if (is.null(weights)) {
+    coef <- lm.fit(x, y)$coefficients
+  } else {
+    coef <- lm.wfit(x, y, weights)$coefficients
+  }
+
+  model <- structure(list(coefficients = coef, residuals = y - x %*% coef,
+                          call = match.call(), terms = mt, model = mf,
+                          na.action = attr(mf, "na.action"),
+                          xlevels = .getXlevels(mt, mf)),
+                     class = "lin_reg")
+
+  if (save_model) {
+    if (is.null(model_save_path)) {
+      curr_dir <- getwd()
+      model_save_path <- paste(curr_dir, "linear_model.rda", sep = "/")
+    }
+
+    # check model_save_path fairness
+    dir_path <- dirname(model_save_path)
+    if (!file.exists(dir_path)) {
+      dir.create(dir_path, recursive = TRUE)
+    }
+
+    # Check if file already exists, modify filename if needed
+    base_name <- basename(model_save_path)
+    pattern <- paste0("^", gsub("[.]", "\\.", base_name), "$")
+    dir_files <- list.files(dir_path, pattern = pattern, full.names = FALSE)
+
+    i <- 1
+    basename_omit <- strsplit(base_name, "\\.")[[1L]][[1L]]
+    while (base_name %in% dir_files) {
+      base_name <- paste0(basename_omit, i, ".rda")
+      i <- i + 1
+    }
+
+    model_save_path <- file.path(dir_path, base_name)
+    print(cat("model will be save in ", model_save_path))
+    save(model, file = model_save_path)
+  }
+
+  model
+}

mypkgs/mylin2024111211/R/predict.R

@@ -0,0 +1,19 @@
+#' Predict from a Simple Linear Regression Model
+#'
+#' Predict new responses given the regression model and new input values.
+#'
+#' @param object An object of class "mylin".
+#' @param newdata A data frame or matrix of new input values.
+#' @param ... Additional arguments.
+#' @return A vector of predicted values.
+#' @export
+predict.mylin <- function(object, newdata, ...) {
+  # Extract the coefficients
+  coef <- object$coefficients
+  # Create the model matrix for the new data
+  mm <- model.frame(object$terms, newdata)
+  x <- model.matrix(object$terms, mm)
+  # Compute predictions 
+  predict <- x %*% coef
+  predict
+}

mypkgs/mylin2024111211/R/print.R

@@ -0,0 +1,14 @@
+#' Print a Simple Linear Regression Model Summary
+#'
+#' Prints a summary of a simple linear regression model.
+#'
+#' @param x An object of class "mylin".
+#' @param ... Additional arguments.
+#' @export
+print.mylin <- function(x, ...) {
+  cat("\nCall:\n", deparse(x$call), "\n\n")
+  cat("Coefficients:\n")
+  print.default(format(x$coefficients), print.gap = 2L, quote = FALSE)
+  cat("\n")
+  invisible(x)
+}